Initial commit
This commit is contained in:
commit
3cba772836
1341 changed files with 532924 additions and 0 deletions
829
BDI2/app.R
Normal file
829
BDI2/app.R
Normal 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)
|
||||
Loading…
Add table
Add a link
Reference in a new issue