829 lines
26 KiB
R
829 lines
26 KiB
R
# 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)
|