server/DiagnostikApps
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit

Browse source
This commit is contained in:
Jonas Karneboge 2026-09-22 18:35:43 +02:00
commit 3cba772836
1341 changed files with 532924 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

BIN
BDI2/.RData Normal file
View file

Binary file not shown.

1
BDI2/.Rprofile Normal file
View file

@ -0,0 +1 @@
source("renv/activate.R")

13
BDI2/BDI2.Rproj Normal file
View file

@ -0,0 +1,13 @@
Version: 1.0
RestoreWorkspace: Default
SaveWorkspace: Default
AlwaysSaveHistory: Default
EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: UTF-8
RnwWeave: Sweave
LaTeX: pdfLaTeX

829
BDI2/app.R Normal file
View file

@ -0,0 +1,829 @@
# Präambel ####
AKZENT_FARBE = "#8B2635"
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_bdi2.R"
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
BDI2_DISCLAIMER = paste0(
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
"keine klinische Diagnose. Die Interpretation der Ergebnisse obliegt der ",
"behandelnden Person."
)
library(shiny)
library(dplyr)
library(ggplot2)
library(officer)
library(haven)
# Infrastruktur ####
APP_VERZEICHNIS = normalizePath(getwd())
absPath = function(pfad) {
if (grepl("^([A-Za-z]:[/\\\\]|/)", pfad)) return(pfad)
file.path(APP_VERZEICHNIS, pfad)
}
PFAD_DOWNLOAD_SKRIPT = normalizePath(absPath(PFAD_DOWNLOAD_SKRIPT), mustWork = FALSE)
PFAD_PSEUDONYM_SKRIPT = normalizePath(absPath(PFAD_PSEUDONYM_SKRIPT), mustWork = FALSE)
# Helper ####
# In formr-Exporten stehen Markdown-Sternchen im Itemwortlaut und in Choice-Texten.
strip_stars = function(x) {
if (is.null(x) || length(x) == 0) return(x)
gsub("\\*\\*", "", as.character(x))
}
# Items 16 und 18 haben 7 Stufen (0, 1a, 1b, 2a, 2b, 3a, 3b), alle anderen 4 (0-3).
extrahiere_stufe = function(spalte, wert) {
lbl = attr(spalte, "labels")
if (is.null(lbl) || length(lbl) == 0) {
return(list(stufe = as.integer(wert) - 1L, richtung = ""))
}
wert_num = as.numeric(wert)
idx = which(as.numeric(lbl) == wert_num)
if (length(idx) == 0) {
return(list(stufe = NA_integer_, richtung = ""))
}
label_text = strip_stars(names(lbl)[idx[1]])
# Beispiele: "0. Ich bin nicht..." -> stufe=0 | "1a. Ich schlafe..." -> stufe=1, richtung="a"
m = regexpr("^([0-9]+)([ab]?)\\.", label_text, perl = TRUE)
if (m == -1L) {
return(list(stufe = NA_integer_, richtung = ""))
}
matched = regmatches(label_text, m)
stufe = as.integer(sub("^([0-9]+)([ab]?)\\.", "\\1", matched))
richtung = sub("^([0-9]+)([ab]?)\\.", "\\2", matched)
list(stufe = stufe, richtung = richtung)
}
hole_antworttext = function(spalte, wert) {
lbl = attr(spalte, "labels")
if (is.null(lbl) || length(lbl) == 0) return(as.character(wert))
idx = which(as.numeric(lbl) == as.numeric(wert))
if (length(idx) == 0) return(as.character(wert))
trimws(strip_stars(names(lbl)[idx[1]]))
}
# Grenzwerte nach NVL Unipolare Depression.
klassifiziere = function(score) {
if (is.na(score)) {
return(list(text = "Nicht berechenbar", bereich = "", farbe = "#888888"))
}
if (score <= 13) {
return(list(text = "Keine/remittierte Depression", bereich = "0-13 Punkte",
farbe = "#2E7D32"))
}
if (score <= 19) {
return(list(text = "Milde Depression", bereich = "14-19 Punkte",
farbe = "#F57F17"))
}
if (score <= 28) {
return(list(text = "Mittlere Depression", bereich = "20-28 Punkte",
farbe = "#E65100"))
}
list(text = "Schwere Depression", bereich = "29-63 Punkte",
farbe = "#B71C1C")
}
erstelle_gauge = function(score) {
zonen = data.frame(
xmin = c( 0, 13, 19, 28),
xmax = c(13, 19, 28, 63),
zone = c("Keine (0-13)", "Mild (14-19)", "Mittel (20-28)", "Schwer (29-63)"),
stringsAsFactors = FALSE
)
zonen$zone = factor(zonen$zone, levels = zonen$zone)
zonen_farben = c(
"Keine (0-13)" = "#C8E6C9",
"Mild (14-19)" = "#FFF9C4",
"Mittel (20-28)" = "#FFE0B2",
"Schwer (29-63)" = "#FFCDD2"
)
zone_mitte = c(6.5, 16, 23.5, 45.5)
zone_labels = c("Keine\n0-13", "Mild\n14-19", "Mittel\n20-28", "Schwer\n29-63")
p = ggplot() +
geom_rect(data = zonen,
aes(xmin = xmin, xmax = xmax, ymin = 0, ymax = 1, fill = zone),
colour = "white", linewidth = 1) +
scale_fill_manual(values = zonen_farben, guide = "none") +
annotate("text", x = zone_mitte, y = 0.5, label = zone_labels,
size = 2.9, colour = "#444444", fontface = "bold", lineheight = 0.9) +
scale_x_continuous(limits = c(0, 63), expand = c(0, 0),
breaks = c(0, 13, 19, 28, 63)) +
scale_y_continuous(limits = c(-0.25, 1.35), expand = c(0, 0)) +
labs(x = "Summenscore (0-63)", y = NULL) +
theme_minimal(base_size = 11) +
theme(
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
panel.grid = element_blank(),
plot.background = element_rect(fill = "white", colour = NA),
panel.background = element_rect(fill = "white", colour = NA),
axis.line.x = element_line(colour = "#cccccc", linewidth = 0.5),
axis.text.x = element_text(colour = "#666666", size = 9)
)
if (!is.na(score)) {
p = p +
geom_segment(aes(x = score, xend = score, y = -0.1, yend = 1.1),
colour = AKZENT_FARBE, linewidth = 2.5, lineend = "round") +
annotate("text", x = score, y = 1.26,
label = as.character(score),
colour = AKZENT_FARBE, fontface = "bold", size = 4.2)
}
p
}
# UI ####
app_css = "
body {
font-family: 'Segoe UI', Helvetica, Arial, sans-serif;
background-color: #f4f4f4;
color: #222;
font-size: 14px;
}
.app-header {
background-color: #8B2635;
color: white;
padding: 15px 22px 13px;
margin-bottom: 18px;
border-radius: 5px;
}
.app-header h2 { margin: 0; font-size: 1.4em; font-weight: 700; }
.app-header p { margin: 4px 0 0; font-size: 0.87em; opacity: 0.88; }
.input-panel {
display: flex;
align-items: flex-end;
gap: 10px;
background: white;
border-radius: 6px;
padding: 14px 18px;
margin-bottom: 16px;
box-shadow: 0 1px 4px rgba(0,0,0,0.09);
flex-wrap: wrap;
}
.input-panel .form-group { margin-bottom: 0; }
.btn-laden {
background-color: #8B2635 !important;
border-color: #7A2030 !important;
color: white !important;
font-weight: 600;
padding: 6px 18px;
border-radius: 4px;
letter-spacing: 0.02em;
white-space: nowrap;
}
.btn-laden:hover, .btn-laden:focus {
background-color: #6E1E29 !important;
border-color: #6E1E29 !important;
outline: none;
box-shadow: 0 0 0 2px rgba(139,38,53,0.3) !important;
}
.abschnitt-karte {
background: white;
border-radius: 6px;
padding: 16px 20px;
margin-bottom: 14px;
box-shadow: 0 1px 4px rgba(0,0,0,0.09);
}
.abschnitt-titel {
color: #8B2635;
margin-top: 0;
margin-bottom: 12px;
font-size: 1em;
font-weight: 700;
letter-spacing: 0.01em;
}
.kopf-info {
color: #555;
font-size: 0.92em;
padding-bottom: 10px;
border-bottom: 1px solid #eee;
margin-bottom: 8px;
}
.kopf-info b { color: #333; }
.suizid-block {
background-color: #6D0000;
color: white;
border-radius: 5px;
padding: 14px 18px;
margin-bottom: 14px;
border-left: 6px solid #FF6B6B;
}
.suizid-block h4 { margin: 0 0 9px; font-size: 1.05em; font-weight: 700; }
.suizid-block .antwort-text {
background: rgba(255,255,255,0.12);
border-radius: 3px;
padding: 7px 10px;
margin: 6px 0;
font-size: 0.92em;
line-height: 1.5;
}
.suizid-block .disclaimer {
margin-top: 10px;
font-size: 0.82em;
opacity: 0.82;
font-style: italic;
}
.alert-warnung {
background-color: #FFFDE7;
border-left: 4px solid #F9A825;
border-radius: 3px;
padding: 9px 12px;
margin-bottom: 10px;
font-size: 0.88em;
color: #555;
line-height: 1.45;
}
.alert-fehler {
background-color: #FEECEB;
border-left: 4px solid #C62828;
border-radius: 4px;
padding: 13px 16px;
margin-bottom: 12px;
}
.alert-fehler h4 { color: #C62828; margin-top: 0; margin-bottom: 8px; }
.alert-fehler p, .alert-fehler li { color: #444; font-size: 0.92em; }
.score-label { font-size: 0.8em; color: #999; display: block; margin-bottom: 2px; }
.score-zahl { font-size: 3em; font-weight: 800; color: #8B2635; display: block;
line-height: 1.1; }
.klasse-text { font-size: 1.05em; font-weight: 700; display: block; margin-top: 4px; }
.bereich-text { font-size: 0.8em; color: #888; display: block; margin-top: 2px; }
.item-tabelle { width: 100%; border-collapse: collapse; font-size: 0.9em; }
.item-tabelle thead th {
text-align: left;
padding: 6px 10px;
border-bottom: 2px solid #8B2635;
color: #8B2635;
font-weight: 700;
font-size: 0.88em;
}
.item-tabelle tbody td {
padding: 6px 10px;
border-bottom: 1px solid #f0f0f0;
vertical-align: top;
line-height: 1.4;
}
.item-tabelle tbody tr:last-child td { border-bottom: none; }
.item-tabelle tbody tr:hover { background-color: #fafafa; }
.stufe-badge {
display: inline-block;
background-color: #8B2635;
color: white;
border-radius: 3px;
padding: 2px 8px;
font-size: 0.88em;
font-weight: 700;
min-width: 30px;
text-align: center;
font-family: monospace;
}
.stufe-badge-0 { background-color: #C8E6C9; color: #1B5E20; }
.stufe-badge-1 { background-color: #FFCDD2; color: #B71C1C; }
.stufe-badge-2 { background-color: #EF9A9A; color: #7B0000; }
.stufe-badge-3 { background-color: #B71C1C; color: white; }
.stufe-badge-na { background-color: #bbb; color: white; }
.antwort-zelle { display: flex; align-items: baseline; gap: 8px; }
.start-hinweis {
text-align: center;
color: #bbb;
padding: 40px 0;
font-size: 0.95em;
}
"
app_css = gsub("#8B2635", AKZENT_FARBE, app_css, fixed = TRUE)
ui = fluidPage(
tags$head(tags$style(HTML(app_css))),
div(class = "app-header",
tags$h2("BDI-II Auswertung"),
tags$p("Beck Depressions-Inventar - Revision • Einzelfall-Auswertung")
),
div(class = "input-panel",
div(style = "min-width: 360px; white-space: nowrap;",
textInput("pseudonym",
label = tagList(
"Pseudonym",
tags$span(style = "font-weight: normal; font-style: italic; font-size: 0.78em; color: #888; margin-left: 4px; white-space: nowrap;",
"optional, hat Vorrang vor Chiffre")
),
placeholder = "optional", width = "340px")
),
div(style = "min-width: 200px;",
textInput("chiffre", label = "Patientenchiffre",
placeholder = "z.B. P000123", width = "100%")
),
actionButton("btn_suchen", "Auswerten", class = "btn btn-primary btn-laden"),
div(style = "margin-left: auto;",
downloadButton("download_word", "Word-Export (.docx)")
)
),
uiOutput("ergebnis_ui")
)
# Word-Export ####
erstelle_bdi2_docx = function(erg) {
stufe_bg = function(stufe) {
if (is.na(stufe)) return("#EEEEEE")
switch(as.character(min(stufe, 3L)),
"0" = "#C8E6C9", "1" = "#FFCDD2",
"2" = "#EF9A9A", "3" = "#B71C1C", "#EEEEEE")
}
stufe_fg = function(stufe) {
if (is.na(stufe) || is.null(stufe) || stufe < 3L) "#333333" else "#FFFFFF"
}
fmt_titel = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18)
fmt_meta = fp_text(color = "#555555", bold = FALSE, font.size = 10)
fmt_warn = fp_text(color = "#B8860B", italic = TRUE, font.size = 9)
fmt_score_l = fp_text(color = "#888888", bold = FALSE, font.size = 10)
fmt_score = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 22)
fmt_klasse = fp_text(color = erg$klasse$farbe, bold = TRUE, font.size = 12)
fmt_abschn = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 12,
underlined = TRUE)
fmt_item_nr = fp_text(color = "#888888", bold = TRUE, font.size = 10)
fmt_item_tit = fp_text(color = "#333333", bold = FALSE, font.size = 10)
fmt_item_ant = fp_text(color = "#555555", bold = FALSE, font.size = 10)
fmt_disclaimer = fp_text(color = "#888888", italic = TRUE, font.size = 9)
doc = read_docx()
doc = body_add_fpar(doc, fpar(ftext("BDI-II Auswertung", fmt_titel)))
doc = body_add_fpar(doc, fpar(ftext(
paste0("Chiffre: ", erg$chiffre,
" Ausfuelldatum: ", erg$ausfuelldatum,
" Erstellt: ", format(Sys.Date(), "%d.%m.%Y")),
fmt_meta
)))
if (!is.null(erg$warnung_bdi))
doc = body_add_fpar(doc, fpar(ftext(paste0("Hinweis: ", erg$warnung_bdi), fmt_warn)))
doc = body_add_par(doc, "")
doc = body_add_fpar(doc, fpar(
ftext("Summenscore: ", fmt_score_l),
ftext(if (!is.na(erg$summenscore)) as.character(erg$summenscore) else "n/a",
fmt_score)
))
doc = body_add_fpar(doc, fpar(ftext(
paste0(erg$klasse$text,
if (nchar(erg$klasse$bereich) > 0) paste0(" (", erg$klasse$bereich, ")") else ""),
fmt_klasse
)))
doc = body_add_par(doc, "")
if (erg$suizid_flag) {
doc = body_add_fpar(doc, fpar(ftext(
"HINWEIS: Bitte Item 9 gesondert beachten (Selbstmordgedanken)",
fp_text(color = "#B71C1C", bold = TRUE, font.size = 11)
)))
doc = body_add_fpar(doc, fpar(ftext(
paste0("Gewaehlte Antwort: ", erg$item9$antwort),
fp_text(color = "#B71C1C", font.size = 10)
)))
doc = body_add_fpar(doc, fpar(ftext(
"(Aufmerksamkeitshinweis, kein automatisiertes klinisches Urteil)",
fp_text(color = "#888888", italic = TRUE, font.size = 9)
)))
doc = body_add_par(doc, "")
}
doc = body_add_fpar(doc, fpar(ftext("Einzelitems (21 Items)", fmt_abschn)))
for (it in erg$items) {
stufe_text = if (is.na(it$stufe)) "?" else paste0(it$stufe, it$richtung)
doc = body_add_fpar(doc, fpar(
ftext(sprintf("%2d. ", it$nr), fmt_item_nr),
ftext(paste0(it$titel, " "), fmt_item_tit),
ftext(paste0(" ", stufe_text, " "),
fp_text(color = stufe_fg(it$stufe),
bold = TRUE,
font.size = 9,
shading.color = stufe_bg(it$stufe))),
ftext(paste0(" ", it$antwort), fmt_item_ant)
))
}
doc = body_add_par(doc, "")
doc = body_add_fpar(doc, fpar(ftext(BDI2_DISCLAIMER, fmt_disclaimer)))
doc
}
# Server ####
server = function(input, output, session) {
# --- pseudonym-support-injection v1 ---
observe({
query = parseQueryString(session$clientData$url_search)
if (!is.null(query$pseudonym) && nchar(trimws(query$pseudonym)) > 0) {
updateTextInput(session, "pseudonym", value = trimws(query$pseudonym))
}
})
observe({
query = parseQueryString(session$clientData$url_search)
if (!is.null(query$chiffre) && nchar(trimws(query$chiffre)) > 0) {
updateTextInput(session, "chiffre", value = toupper(trimws(query$chiffre)))
}
})
ergebnis_r = eventReactive(input$btn_suchen, {
chiffre = toupper(trimws(input$chiffre))
if ((nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0)) {
return(list(typ = "leere_eingabe"))
}
if (!(nchar(trimws(input$pseudonym)) > 0 || grepl("^[A-Z][0-9]{6}$", chiffre))) {
return(list(typ = "format_fehler", chiffre = chiffre))
}
pfadfehler = character(0)
if (!file.exists(PFAD_DOWNLOAD_SKRIPT))
pfadfehler = c(pfadfehler,
paste0("Download-Skript nicht gefunden: >>", PFAD_DOWNLOAD_SKRIPT, "<<"))
if (!file.exists(PFAD_PSEUDONYM_SKRIPT))
pfadfehler = c(pfadfehler,
paste0("Pseudonym-Skript nicht gefunden: >>", PFAD_PSEUDONYM_SKRIPT, "<<"))
if (length(pfadfehler) > 0) {
return(list(typ = "skript_fehler",
meldung = paste("Bitte Pfade am Kopf der app.R anpassen:",
paste(pfadfehler, collapse = "\n"), sep = "\n")))
}
ok_dl = tryCatch({
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE); TRUE
}, error = function(e) {
list(typ = "skript_fehler",
meldung = paste0("Fehler im Download-Skript (",
basename(PFAD_DOWNLOAD_SKRIPT), "):\n", e$message))
})
if (is.list(ok_dl)) return(ok_dl)
db_ordner = local({
ordner = dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE))
gefunden = NULL
for (i in 1:5) {
if (file.exists(file.path(ordner, "pseudonyme.db"))) {
gefunden = ordner; break
}
elternteil = dirname(ordner)
if (elternteil == ordner) break
ordner = elternteil
}
gefunden
})
if (is.null(db_ordner)) {
return(list(typ = "skript_fehler",
meldung = paste0(
"pseudonyme.db nicht gefunden.\n",
"Gesucht ausgehend vom Pseudonym-Skript-Ordner bis zu 5 Ebenen nach oben.\n",
"Bitte sicherstellen, dass pseudonyme.db im selben oder einem ",
"uebergeordneten Ordner liegt."
)))
}
ok_ps = tryCatch({
alter_wd = getwd()
on.exit(setwd(alter_wd), add = TRUE)
setwd(db_ordner)
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
if (nchar(trimws(input$pseudonym)) > 0) {
.pw_wert = trimws(input$pseudonym)
.pw_tab = get("pseudo", envir = .GlobalEnv)
.pw_treffer = .pw_tab[.pw_tab$pseudonym == .pw_wert, ]
if (nrow(.pw_treffer) > 0) chiffre = toupper(trimws(.pw_treffer$chiffre[1]))
}; TRUE
}, error = function(e) {
list(typ = "skript_fehler",
meldung = paste0("Fehler im Pseudonym-Skript (",
basename(PFAD_PSEUDONYM_SKRIPT), "):\n", e$message))
})
if (is.list(ok_ps)) return(ok_ps)
if (!exists("daten_bdi2", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = paste0("Objekt 'daten_bdi2' fehlt nach dem Sourcen von:\n",
PFAD_DOWNLOAD_SKRIPT)))
}
if (!exists("pseudo", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = paste0("Objekt 'pseudo' fehlt nach dem Sourcen von:\n",
PFAD_PSEUDONYM_SKRIPT)))
}
dat_bdi = get("daten_bdi2", envir = globalenv())
dat_ps = get("pseudo", envir = globalenv())
ps_treffer = dat_ps[dat_ps$chiffre == chiffre, , drop = FALSE]
if (nrow(ps_treffer) == 0) {
return(list(typ = "chiffre_nicht_gefunden", chiffre = chiffre))
}
alle_session_ids = unique(as.character(ps_treffer$pseudonym))
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
bdi_treffer = dat_bdi[dat_bdi$session %in% alle_session_ids, , drop = FALSE]
if (nrow(bdi_treffer) == 0) {
return(list(typ = "session_nicht_gefunden",
chiffre = chiffre,
session_id = paste(alle_session_ids, collapse = ", ")))
}
warnung_bdi = NULL
if (nrow(bdi_treffer) > 1) {
n_ausfuell = nrow(bdi_treffer)
bdi_treffer = bdi_treffer %>%
arrange(desc(created)) %>%
slice(1)
datum_neu = format(as.POSIXct(bdi_treffer$created[1]),
"%d.%m.%Y %H:%M", tz = "Europe/Berlin")
warnung_bdi = paste0(
n_ausfuell, " Ausfuellungen gefunden. ",
"Es wird die neueste angezeigt (", datum_neu, ")."
)
}
zeile = bdi_treffer[1, , drop = FALSE]
ausfuelldatum = format(as.POSIXct(zeile$created[1]),
"%d.%m.%Y", tz = "Europe/Berlin")
item_cols = paste0("bdi2_", sprintf("%02d", 1:21))
# labels-Attribut wird aus der Original-Spalte gelesen, nicht aus dem subgesetteten
# Datensatz, weil haven die Attribute beim Subsetten zwar erhaelt, aber das Original
# die zuverlaessigere Quelle ist.
items = lapply(seq_along(item_cols), function(i) {
col_name = item_cols[i]
spalte_orig = dat_bdi[[col_name]]
wert = zeile[[col_name]]
item_label_roh = attr(spalte_orig, "label")
item_titel = if (!is.null(item_label_roh) && !is.na(item_label_roh)) {
strip_stars(as.character(item_label_roh))
} else {
paste0("Item ", i)
}
if (is.na(wert)) {
return(list(
nr = i,
titel = item_titel,
stufe = NA_integer_,
richtung = "",
antwort = "(keine Angabe)",
fehlt = TRUE
))
}
sr = extrahiere_stufe(spalte_orig, wert)
antwort = hole_antworttext(spalte_orig, wert)
list(
nr = i,
titel = item_titel,
stufe = sr$stufe,
richtung = sr$richtung,
antwort = antwort,
fehlt = FALSE
)
})
stufenwerte = sapply(items, `[[`, "stufe")
n_fehlt = sum(is.na(stufenwerte))
summenscore = if (n_fehlt == 0L) as.integer(sum(stufenwerte)) else NA_integer_
klasse = klassifiziere(summenscore)
item9 = items[[9]]
suizid_flag = !is.na(item9$stufe) && item9$stufe > 1L
list(
typ = "ergebnis",
chiffre = chiffre,
ausfuelldatum = ausfuelldatum,
warnung_bdi = warnung_bdi,
items = items,
summenscore = summenscore,
n_fehlt = n_fehlt,
klasse = klasse,
suizid_flag = suizid_flag,
item9 = item9
)
})
output$ergebnis_ui = renderUI({
if (input$btn_suchen == 0) {
return(div(class = "start-hinweis",
"Patientenchiffre eingeben und auf \"Auswerten\" klicken."
))
}
erg = ergebnis_r()
if (erg$typ == "skript_fehler") {
return(div(class = "alert-fehler",
tags$h4("Konfigurationsfehler"),
tags$pre(style = "font-size:0.88em; white-space:pre-wrap;", erg$meldung)
))
}
if (erg$typ == "leere_eingabe") {
return(div(class = "alert-warnung",
"Bitte eine Patientenchiffre eingeben."
))
}
if (erg$typ == "format_fehler") {
return(div(class = "alert-warnung",
"Ungültige Chiffre. Erwartet wird ein Großbuchstabe gefolgt von 6 Ziffern, z.B. P000123."
))
}
if (erg$typ == "chiffre_nicht_gefunden") {
return(div(class = "alert-fehler",
tags$h4("Chiffre nicht gefunden"),
tags$p("Die Chiffre ", tags$b(paste0("«", erg$chiffre, "»")),
" ist in der Pseudonymtabelle nicht vorhanden."),
tags$p("Bitte Schreibweise prüfen oder Pseudonymtabelle aktualisieren.")
))
}
if (erg$typ == "session_nicht_gefunden") {
return(div(class = "alert-fehler",
tags$h4("Kein BDI-II-Datensatz gefunden"),
tags$p("Zur Chiffre ", tags$b(paste0("«", erg$chiffre, "»")),
" existiert ein Pseudonymeintrag, aber kein Datensatz in ",
tags$code("daten_bdi2"), "."),
tags$p("Mögliche Ursachen: Bogen noch nicht ausgefüllt, ",
"oder Daten noch nicht heruntergeladen.")
))
}
kopf_block = div(class = "abschnitt-karte",
div(class = "kopf-info",
tags$b("Chiffre: "), erg$chiffre, " ",
tags$b("Ausfülldatum: "), erg$ausfuelldatum
),
if (!is.null(erg$warnung_bdi))
div(class = "alert-warnung", "⚠ Hinweis: ", erg$warnung_bdi)
)
suizid_block = if (erg$suizid_flag) {
div(class = "suizid-block",
tags$h4("⚠️ Bitte Item 9 gesondert beachten – Selbstmordgedanken"),
div(class = "antwort-text",
tags$b("Gewählte Antwort: "), erg$item9$antwort
),
tags$p(class = "disclaimer",
"Dieser Hinweis ist kein automatisiertes klinisches Urteil, ",
"sondern ein Aufmerksamkeitshinweis für die behandelnde Person."
)
)
} else NULL
fehlende_items_block = if (erg$n_fehlt > 0) {
div(class = "alert-warnung",
tags$b("⚠ "), erg$n_fehlt,
" Item(s) ohne Angabe – Summenscore kann nicht berechnet werden."
)
} else NULL
score_block = div(class = "abschnitt-karte",
fluidRow(
column(4,
tags$span(class = "score-label", "Summenscore BDI-II"),
tags$span(class = "score-zahl",
if (!is.na(erg$summenscore)) as.character(erg$summenscore) else "–"
),
tags$span(class = "klasse-text",
style = paste0("color:", erg$klasse$farbe, ";"),
erg$klasse$text
),
tags$span(class = "bereich-text", erg$klasse$bereich)
),
column(8,
style = "padding-top: 6px;",
plotOutput("gauge_plot", height = "110px")
)
),
fehlende_items_block
)
item_zeilen = lapply(erg$items, function(it) {
if (is.na(it$stufe)) {
badge_class = "stufe-badge stufe-badge-na"
badge_text = "?"
} else {
badge_class = paste0("stufe-badge stufe-badge-", min(it$stufe, 3L))
badge_text = paste0(it$stufe, it$richtung)
}
tags$tr(
tags$td(style = paste0("color:", AKZENT_FARBE, "; font-weight:700; width:32px;"),
paste0(it$nr, ".")),
tags$td(style = "color:#333; padding-right:14px;", it$titel),
tags$td(
div(class = "antwort-zelle",
tags$span(class = badge_class, badge_text),
tags$span(style = "color:#555;", it$antwort)
)
)
)
})
item_block = div(class = "abschnitt-karte",
tags$h4(class = "abschnitt-titel", "Einzelitems (21 Items)"),
tags$table(class = "item-tabelle",
tags$thead(tags$tr(
tags$th("Nr."),
tags$th("Itemtitel"),
tags$th("Antwort")
)),
tags$tbody(item_zeilen)
)
)
tagList(kopf_block, suizid_block, score_block, item_block)
})
output$gauge_plot = renderPlot({
req(input$btn_suchen > 0)
erg = ergebnis_r()
req(erg$typ == "ergebnis")
erstelle_gauge(erg$summenscore)
}, bg = "white")
output$download_word = downloadHandler(
filename = function() {
erg = ergebnis_r()
if (is.null(erg) || erg$typ != "ergebnis") return("BDI2_Auswertung.docx")
chiffre_esc = gsub("[^A-Za-z0-9_-]", "_", erg$chiffre)
ausfuelldatum_fn = format(as.Date(erg$ausfuelldatum, "%d.%m.%Y"), "%Y%m%d")
paste0("BDI2_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
},
content = function(file) {
req(ergebnis_r()$typ == "ergebnis")
erg = ergebnis_r()
doc = erstelle_bdi2_docx(erg)
print(doc, target = file)
}
)
}
# Start ####
shinyApp(ui = ui, server = server)

2879
BDI2/renv.lock Normal file
View file

File diff suppressed because it is too large Load diff