855 lines
29 KiB
R
855 lines
29 KiB
R
# Präambel ####
|
||
|
||
AKZENT_FARBE = "#8B2635"
|
||
|
||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_vds90.R"
|
||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
|
||
|
||
VDS90_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(haven)
|
||
library(officer)
|
||
library(DBI)
|
||
library(RSQLite)
|
||
|
||
|
||
# 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 ####
|
||
|
||
# Mapping ueber Position: kleinster Code = Stufe 0, naechster = Stufe 1 usw.
|
||
# Unabhaengig vom Labeltext – funktioniert mit "nicht/leicht/mittel/stark" und
|
||
# mit numerisch-kodierten Formaten gleichermassen.
|
||
stufe_aus_labels_fuer_wert = function(spalte_orig, rohwert) {
|
||
labels_attr = attr(spalte_orig, "labels")
|
||
if (is.null(labels_attr) || is.na(rohwert)) return(NA_real_)
|
||
codes_sortiert = sort(as.integer(labels_attr))
|
||
stufe = match(as.integer(rohwert), codes_sortiert) - 1L
|
||
if (is.na(stufe)) return(NA_real_)
|
||
as.numeric(stufe)
|
||
}
|
||
|
||
perzentil_nachschlagen = function(skalenwert_val, normtabelle, geschlecht) {
|
||
tab = if (geschlecht == "weiblich") normtabelle$frauen else normtabelle$maenner
|
||
if (is.na(skalenwert_val)) return(NA_real_)
|
||
if (skalenwert_val <= min(tab$skalenwert)) return(tab$perzentil[1])
|
||
if (skalenwert_val >= max(tab$skalenwert)) return(100)
|
||
approx(tab$skalenwert, tab$perzentil, xout = skalenwert_val)$y
|
||
}
|
||
|
||
perzentil_nachschlagen_ge = function(skalenwert_val, geschlecht) {
|
||
tab = if (geschlecht == "weiblich") vds90_ge_normtabelle_frauen else vds90_ge_normtabelle_maenner
|
||
if (is.na(skalenwert_val)) return(NA_real_)
|
||
if (skalenwert_val <= min(tab$skalenwert)) return(tab$perzentil[1])
|
||
if (skalenwert_val >= max(tab$skalenwert)) return(100)
|
||
approx(tab$skalenwert, tab$perzentil, xout = skalenwert_val)$y
|
||
}
|
||
|
||
berechne_prozentrang = function(summe_itemwerte, skalenwert_val, kuerzel, geschlecht) {
|
||
# Summe = 0 -> Prozentrang = 0, unabhaengig vom Normtabellenwert.
|
||
if (!is.na(summe_itemwerte) && summe_itemwerte == 0) return(0)
|
||
if (kuerzel == "GE") {
|
||
perzentil_nachschlagen_ge(skalenwert_val, geschlecht)
|
||
} else {
|
||
perzentil_nachschlagen(skalenwert_val, vds90_normtabellen[[kuerzel]], geschlecht)
|
||
}
|
||
}
|
||
|
||
gauge_ggplot = function(skalenwert_val, prozentrang_val) {
|
||
if (is.na(skalenwert_val)) skalenwert_val = 0
|
||
if (is.na(prozentrang_val)) prozentrang_val = 0
|
||
farb_grad = colorRampPalette(c("#28a745", "#ffc107", "#dc3545"))(101)
|
||
idx = max(1, min(101, round(skalenwert_val / 3 * 100) + 1))
|
||
fill_col = farb_grad[idx]
|
||
pr_label = sprintf("Mittelwert: %.3f | Prozentrang: %.0f%%", skalenwert_val, prozentrang_val)
|
||
|
||
ggplot() +
|
||
geom_rect(aes(xmin = 0, xmax = 3, ymin = 0.2, ymax = 0.8), fill = "#e9ecef") +
|
||
geom_rect(aes(xmin = 0, xmax = skalenwert_val, ymin = 0.2, ymax = 0.8), fill = fill_col) +
|
||
annotate("text", x = 3.08, y = 0.5, label = pr_label,
|
||
hjust = 0, vjust = 0.5, size = 3.3, color = "#333") +
|
||
scale_x_continuous(limits = c(0, 6.5), breaks = 0:3,
|
||
labels = c("0\nnicht", "1\nleicht", "2\nmittel", "3\nstark")) +
|
||
scale_y_continuous(limits = c(0, 1)) +
|
||
theme_void() +
|
||
theme(axis.text.x = element_text(size = 8, color = "#555", vjust = 1,
|
||
margin = margin(t = 2)),
|
||
axis.ticks.x = element_line(color = "#999"),
|
||
axis.ticks.length = unit(3, "pt"),
|
||
plot.margin = margin(4, 4, 8, 4))
|
||
}
|
||
|
||
make_uebersicht_df = function(subsk_erg, geschlecht) {
|
||
korder = vds90_kuerzel_reihenfolge
|
||
nm_col = if (geschlecht == "weiblich") "mittelwert_frauen" else "mittelwert_maenner"
|
||
norm_mw = setNames(vds90_norm_mittelwerte[[nm_col]], vds90_norm_mittelwerte$abkuerzung)
|
||
data.frame(
|
||
kuerzel = factor(korder, levels = korder),
|
||
mittelwert = sapply(korder, function(k) subsk_erg[[k]]$mittelwert),
|
||
prozentrang = sapply(korder, function(k) subsk_erg[[k]]$prozentrang),
|
||
norm_mw = norm_mw[korder],
|
||
stringsAsFactors = FALSE
|
||
)
|
||
}
|
||
|
||
plot_schweregrad = function(df) {
|
||
ggplot(df, aes(x = kuerzel, y = mittelwert)) +
|
||
geom_col(fill = AKZENT_FARBE, width = 0.65) +
|
||
scale_y_continuous(limits = c(0, 3), breaks = 0:3, expand = expansion(mult = c(0, 0.05))) +
|
||
labs(title = "Schweregrad (Skalenmittelwert)", x = NULL, y = "Mittelwert (0-3)") +
|
||
theme_minimal(base_size = 11) +
|
||
theme(axis.text.x = element_text(angle = 45, hjust = 1),
|
||
panel.grid.major.x = element_blank(),
|
||
plot.title = element_text(color = AKZENT_FARBE, face = "bold", size = 12))
|
||
}
|
||
|
||
plot_prozentrang = function(df) {
|
||
ggplot(df, aes(x = kuerzel, y = prozentrang)) +
|
||
geom_col(fill = AKZENT_FARBE, width = 0.65) +
|
||
scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 25),
|
||
expand = expansion(mult = c(0, 0.02))) +
|
||
labs(title = "Prozentränge", x = NULL, y = "Prozentrang") +
|
||
theme_minimal(base_size = 11) +
|
||
theme(axis.text.x = element_text(angle = 45, hjust = 1),
|
||
panel.grid.major.x = element_blank(),
|
||
plot.title = element_text(color = AKZENT_FARBE, face = "bold", size = 12))
|
||
}
|
||
|
||
plot_abweichung = function(df) {
|
||
df$abweichung = df$mittelwert - df$norm_mw
|
||
df$farbe = ifelse(df$abweichung >= 0, "#c0392b", "#27ae60")
|
||
ggplot(df, aes(x = kuerzel, y = abweichung, fill = farbe)) +
|
||
geom_col(width = 0.65) +
|
||
geom_hline(yintercept = 0, color = "#333", linewidth = 0.6) +
|
||
scale_fill_identity() +
|
||
labs(title = "Abweichung Patient von Normstichprobe",
|
||
x = NULL, y = "Patient - Norm (Mittelwert)") +
|
||
theme_minimal(base_size = 11) +
|
||
theme(axis.text.x = element_text(angle = 45, hjust = 1),
|
||
panel.grid.major.x = element_blank(),
|
||
plot.title = element_text(color = AKZENT_FARBE, face = "bold", size = 12))
|
||
}
|
||
|
||
plot_vergleich = function(df) {
|
||
df_long = data.frame(
|
||
kuerzel = rep(df$kuerzel, 2),
|
||
wert = c(df$mittelwert, df$norm_mw),
|
||
gruppe = factor(rep(c("Patient", "Normstichprobe"), each = nrow(df)),
|
||
levels = c("Patient", "Normstichprobe"))
|
||
)
|
||
ggplot(df_long, aes(x = kuerzel, y = wert, color = gruppe, group = gruppe)) +
|
||
geom_line(linewidth = 0.9) +
|
||
geom_point(size = 2) +
|
||
scale_color_manual(values = c("Patient" = AKZENT_FARBE, "Normstichprobe" = "#2980b9")) +
|
||
labs(title = "Patient vs. Normstichprobe (Skalenmittelwert)",
|
||
x = NULL, y = "Mittelwert", color = NULL) +
|
||
theme_minimal(base_size = 11) +
|
||
theme(axis.text.x = element_text(angle = 45, hjust = 1),
|
||
panel.grid.major.x = element_blank(),
|
||
legend.position = "bottom",
|
||
plot.title = element_text(color = AKZENT_FARBE, face = "bold", size = 12))
|
||
}
|
||
|
||
|
||
# Datenaufbereitung ####
|
||
|
||
source("vds90_normtabellen.R")
|
||
|
||
|
||
# UI ####
|
||
|
||
app_css = "
|
||
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; }
|
||
.container-fluid { max-width: 1100px; }
|
||
|
||
.app-header {
|
||
background: #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: #8B2635 !important;
|
||
border-color: #8B2635 !important;
|
||
color: white !important;
|
||
font-weight: 600;
|
||
padding: 6px 18px;
|
||
border-radius: 4px;
|
||
white-space: nowrap;
|
||
}
|
||
.btn-laden:hover, .btn-laden:focus {
|
||
background: #6e1e2a !important;
|
||
border-color: #6e1e2a !important;
|
||
color: white !important;
|
||
}
|
||
|
||
.alert-warnung {
|
||
background: #fff3cd;
|
||
border: 1px solid #ffc107;
|
||
padding: 10px 14px;
|
||
border-radius: 6px;
|
||
margin-bottom: 10px;
|
||
color: #856404;
|
||
}
|
||
|
||
.alert-fehler {
|
||
background: #f8d7da;
|
||
border: 1px solid #f5c2c7;
|
||
padding: 10px 14px;
|
||
border-radius: 6px;
|
||
color: #842029;
|
||
}
|
||
|
||
.abschnitt-karte {
|
||
background: white;
|
||
border: 1px solid #dee2e6;
|
||
border-radius: 8px;
|
||
padding: 14px 18px;
|
||
margin-bottom: 14px;
|
||
}
|
||
.abschnitt-titel {
|
||
color: #8B2635;
|
||
font-weight: 700;
|
||
font-size: 1.05em;
|
||
margin-bottom: 8px;
|
||
}
|
||
.abschnitt-titel .kuerzel {
|
||
background: #8B2635;
|
||
color: white;
|
||
padding: 1px 7px;
|
||
border-radius: 4px;
|
||
font-size: 0.82em;
|
||
margin-right: 6px;
|
||
}
|
||
|
||
.stufe-badge {
|
||
display: inline-block;
|
||
padding: 1px 9px;
|
||
border-radius: 10px;
|
||
font-weight: 600;
|
||
font-size: 0.82em;
|
||
margin-left: 6px;
|
||
vertical-align: middle;
|
||
white-space: nowrap;
|
||
}
|
||
.stufe-badge-0 { background: #28a745; color: white; }
|
||
.stufe-badge-1 { background: #ffb3b3; color: #333; }
|
||
.stufe-badge-2 { background: #dc3545; color: white; }
|
||
.stufe-badge-3 { background: #7b0000; color: white; }
|
||
|
||
.item-zeile {
|
||
margin-bottom: 5px;
|
||
padding: 6px 8px;
|
||
background: #fafafa;
|
||
border-radius: 4px;
|
||
border: 1px solid #eee;
|
||
font-size: 0.88em;
|
||
display: flex;
|
||
align-items: flex-start;
|
||
gap: 8px;
|
||
}
|
||
.item-nr { font-weight: 700; color: #555; min-width: 62px; flex-shrink: 0; }
|
||
.item-text { flex: 1; line-height: 1.4; }
|
||
.items-container { margin-top: 8px; }
|
||
|
||
summary { cursor: pointer; font-size: 0.9em; color: #666; padding: 4px 0; }
|
||
summary:hover { color: #8B2635; }
|
||
|
||
.uebersicht-box {
|
||
background: white;
|
||
border: 1px solid #dee2e6;
|
||
border-radius: 8px;
|
||
padding: 14px 18px;
|
||
margin-bottom: 22px;
|
||
}
|
||
|
||
.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-warn-box {
|
||
background: #7b0000;
|
||
color: white;
|
||
padding: 12px 18px;
|
||
border-radius: 8px;
|
||
margin-bottom: 16px;
|
||
font-weight: 600;
|
||
font-size: 1.0em;
|
||
border: 2px solid #ff4444;
|
||
}
|
||
.suizid-warn-box .suizid-detail {
|
||
font-weight: normal;
|
||
font-size: 0.9em;
|
||
margin-top: 4px;
|
||
opacity: 0.92;
|
||
}
|
||
|
||
.item-row-suizid { background: #fff0f0 !important; border-color: #dc3545 !important; }
|
||
.suizid-badge {
|
||
display: inline-block;
|
||
background: #7b0000;
|
||
color: white;
|
||
padding: 1px 7px;
|
||
border-radius: 10px;
|
||
font-size: 0.78em;
|
||
font-weight: 700;
|
||
margin-left: 4px;
|
||
vertical-align: middle;
|
||
white-space: nowrap;
|
||
}
|
||
|
||
.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)),
|
||
tags$script(HTML("
|
||
Shiny.addCustomMessageHandler('scroll_top', function(x) {
|
||
window.scrollTo(0, 0);
|
||
});
|
||
"))
|
||
),
|
||
|
||
div(class = "app-header",
|
||
tags$h2("VDS-90 Auswertung"),
|
||
tags$p("Veränderungsfragebogen des Erlebens und Verhaltens • 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")
|
||
)
|
||
|
||
|
||
# Word-Export ####
|
||
|
||
erstelle_vds90_docx = function(daten) {
|
||
|
||
ueb_df = make_uebersicht_df(daten$subsk_erg, daten$geschlecht)
|
||
|
||
plots_list = list(
|
||
Schweregrad = plot_schweregrad(ueb_df),
|
||
Prozentrang = plot_prozentrang(ueb_df),
|
||
Abweichung = plot_abweichung(ueb_df),
|
||
Vergleich = plot_vergleich(ueb_df)
|
||
)
|
||
|
||
plot_dateien = lapply(names(plots_list), function(nm) {
|
||
tmp = tempfile(fileext = ".png")
|
||
ggplot2::ggsave(tmp, plots_list[[nm]], width = 8, height = 3.8, dpi = 150, bg = "white")
|
||
tmp
|
||
})
|
||
|
||
badge_bg = c("0" = "#28a745", "1" = "#ffb3b3", "2" = "#dc3545", "3" = "#7b0000")
|
||
badge_fg = c("0" = "white", "1" = "#333333", "2" = "white", "3" = "white")
|
||
|
||
fp_titel = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18)
|
||
fp_meta = fp_text(color = "#555555", bold = FALSE, font.size = 10)
|
||
fp_warn = fp_text(color = "#856404", italic = TRUE, font.size = 9)
|
||
fp_abschn = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 12, underlined = TRUE)
|
||
fp_mono = fp_text(font.size = 9, font.family = "Courier New")
|
||
fp_normal = fp_text(font.size = 9)
|
||
fp_disclaimer = fp_text(color = "#888888", italic = TRUE, font.size = 9)
|
||
|
||
doc = read_docx()
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("VDS-90 Auswertung", fp_titel)))
|
||
doc = body_add_fpar(doc, fpar(ftext(
|
||
sprintf("Chiffre: %s Datum: %s Geschlecht: %s",
|
||
daten$chiffre, daten$datum, daten$geschlecht_label),
|
||
fp_meta
|
||
)))
|
||
|
||
if (!is.null(daten$warnung))
|
||
doc = body_add_fpar(doc,
|
||
fpar(ftext(paste0("Hinweis: ", daten$warnung), fp_warn)))
|
||
|
||
{
|
||
s25 = daten$stufen[["vds90_25"]]
|
||
s26 = daten$stufen[["vds90_26"]]
|
||
aktiv_25 = !is.na(s25) && s25 > 0
|
||
aktiv_26 = !is.na(s26) && s26 > 0
|
||
if (aktiv_25 || aktiv_26) {
|
||
detail_txt = paste0(
|
||
if (aktiv_25) sprintf("Item 25 (Suizidgedanken): Antwort %d", as.integer(s25)),
|
||
if (aktiv_25 && aktiv_26) " | ",
|
||
if (aktiv_26) sprintf("Item 26 (Suizidabsicht): Antwort %d", as.integer(s26))
|
||
)
|
||
doc = body_add_fpar(doc,
|
||
fpar(ftext(paste0("SUIZIDALITAET: Bitte Items 25/26 beachten -- ", detail_txt),
|
||
fp_text(color = "white", bold = TRUE, font.size = 11,
|
||
shading.color = "#7b0000")),
|
||
fp_p = fp_par(padding = 8))
|
||
)
|
||
}
|
||
}
|
||
|
||
doc = body_add_par(doc, "")
|
||
doc = body_add_fpar(doc, fpar(ftext("Uebersicht aller Subskalen", fp_abschn)))
|
||
|
||
korder = vds90_kuerzel_reihenfolge
|
||
for (sk in korder) {
|
||
erg = daten$subsk_erg[[sk]]
|
||
zeile_txt = sprintf("%-4s %-40s MW: %5.3f PR: %5.1f%%",
|
||
sk,
|
||
substr(vds90_bezeichnungen[[sk]], 1, 40),
|
||
erg$mittelwert,
|
||
erg$prozentrang)
|
||
doc = body_add_fpar(doc, fpar(ftext(zeile_txt, fp_mono)))
|
||
}
|
||
|
||
doc = body_add_par(doc, "")
|
||
doc = body_add_fpar(doc, fpar(ftext("Uebersichtsdiagramme", fp_abschn)))
|
||
for (i in seq_along(plot_dateien)) {
|
||
doc = body_add_img(doc, src = plot_dateien[[i]], width = 6.2, height = 2.8)
|
||
}
|
||
|
||
doc = body_add_par(doc, "")
|
||
doc = body_add_fpar(doc, fpar(ftext("Itemlisten nach Subskala", fp_abschn)))
|
||
|
||
for (sk in korder) {
|
||
if (sk == "GE") next
|
||
erg = daten$subsk_erg[[sk]]
|
||
doc = body_add_fpar(doc,
|
||
fpar(ftext(sprintf("%s – %s (MW: %.3f, PR: %.0f%%)",
|
||
sk, vds90_bezeichnungen[[sk]],
|
||
erg$mittelwert, erg$prozentrang),
|
||
fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 11)))
|
||
)
|
||
for (nm in erg$item_namen) {
|
||
stufe_val = erg$stufen[[nm]]
|
||
s_char = if (!is.na(stufe_val)) as.character(as.integer(stufe_val)) else "?"
|
||
bg_col = if (!is.na(stufe_val)) badge_bg[s_char] else "#aaaaaa"
|
||
fg_col = if (!is.na(stufe_val)) badge_fg[s_char] else "white"
|
||
item_txt = vds90_itemtexte[[nm]]
|
||
if (is.null(item_txt)) item_txt = nm
|
||
ist_suizid = nm %in% c("vds90_25", "vds90_26")
|
||
warn_aktiv = ist_suizid && !is.na(stufe_val) && stufe_val > 0
|
||
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext(sprintf("%-10s", nm), fp_text(bold = TRUE, font.size = 9,
|
||
font.family = "Courier New")),
|
||
ftext(paste0(" ", s_char, " "), fp_text(color = fg_col, bold = TRUE, font.size = 9,
|
||
shading.color = bg_col)),
|
||
if (warn_aktiv)
|
||
ftext(" SUIZID ", fp_text(color = "white", bold = TRUE, font.size = 9,
|
||
shading.color = "#7b0000")),
|
||
ftext(paste0(" ", substr(item_txt, 1, 120)), fp_normal)
|
||
))
|
||
}
|
||
doc = body_add_par(doc, "")
|
||
}
|
||
|
||
lapply(plot_dateien, function(f) if (file.exists(f)) unlink(f))
|
||
|
||
doc = body_add_par(doc, "")
|
||
doc = body_add_fpar(doc, fpar(ftext(VDS90_DISCLAIMER, fp_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)))
|
||
}
|
||
})
|
||
|
||
daten_reaktiv = eventReactive(input$btn_suchen, {
|
||
|
||
chiffre = toupper(trimws(input$chiffre))
|
||
|
||
if ((nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0)) {
|
||
return(list(fehler = "Bitte eine Chiffre eingeben."))
|
||
}
|
||
|
||
if (!(nchar(trimws(input$pseudonym)) > 0 || grepl("^[A-Z][0-9]{6}$", chiffre))) {
|
||
return(list(fehler = "Ungültige Chiffre. Erwartet: ein Großbuchstabe + 6 Ziffern, z.B. P000123."))
|
||
}
|
||
|
||
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
|
||
return(list(fehler = paste0("Download-Skript nicht gefunden:\n", PFAD_DOWNLOAD_SKRIPT)))
|
||
}
|
||
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
|
||
return(list(fehler = paste0("Pseudonym-Skript nicht gefunden:\n", PFAD_PSEUDONYM_SKRIPT)))
|
||
}
|
||
|
||
ok_dl = tryCatch({
|
||
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
|
||
list(ok = TRUE)
|
||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||
if (!ok_dl$ok)
|
||
return(list(fehler = paste0("Fehler beim Laden der Daten:\n", ok_dl$msg)))
|
||
|
||
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(fehler = paste0(
|
||
"pseudonyme.db nicht gefunden (bis 5 Ebenen oberhalb von ",
|
||
dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE)),
|
||
" gesucht)."
|
||
)))
|
||
}
|
||
|
||
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]))
|
||
}
|
||
list(ok = TRUE)
|
||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||
if (!ok_ps$ok)
|
||
return(list(fehler = paste0("Fehler beim Laden der Pseudonymdaten:\n", ok_ps$msg)))
|
||
|
||
if (!exists("daten_vds90", envir = .GlobalEnv))
|
||
return(list(fehler = "daten_vds90 fehlt nach dem Sourcen. Bitte Download-Skript pruefen."))
|
||
if (!exists("pseudo", envir = .GlobalEnv))
|
||
return(list(fehler = "pseudo fehlt nach dem Sourcen. Bitte Pseudonym-Skript pruefen."))
|
||
|
||
daten_vds90 = get("daten_vds90", envir = .GlobalEnv)
|
||
pseudo = get("pseudo", envir = .GlobalEnv)
|
||
|
||
treffer_pseudo = pseudo[tolower(trimws(as.character(pseudo$chiffre))) == tolower(chiffre), ]
|
||
|
||
if (nrow(treffer_pseudo) == 0)
|
||
return(list(fehler = "Chiffre nicht gefunden."))
|
||
|
||
alle_session_ids = unique(as.character(treffer_pseudo$pseudonym))
|
||
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
|
||
kandidaten = daten_vds90[as.character(daten_vds90$session) %in% alle_session_ids, , drop = FALSE]
|
||
|
||
if (nrow(kandidaten) == 0) {
|
||
return(list(fehler = paste0(
|
||
"Kein Fragebogen-Datensatz gefunden. (",
|
||
nrow(treffer_pseudo), " Pseudonyme zu dieser Chiffre, keines in daten_vds90)"
|
||
)))
|
||
}
|
||
|
||
warnung = NULL
|
||
if (nrow(kandidaten) > 1) {
|
||
n_ausfuell = nrow(kandidaten)
|
||
best_idx = which.max(as.POSIXct(kandidaten$created))
|
||
kandidaten = kandidaten[best_idx, , drop = FALSE]
|
||
best_time = format(as.POSIXct(kandidaten$created[1]), "%d.%m.%Y %H:%M")
|
||
warnung = paste0(
|
||
"Mehrere Durchlaeufe gefunden (", n_ausfuell, " Datensaetze). ",
|
||
"Es wird der neueste verwendet (", best_time, ")."
|
||
)
|
||
}
|
||
|
||
zeile = kandidaten
|
||
|
||
geschlecht_raw = zeile[["vds90_geschlecht"]]
|
||
geschlecht_labels_attr = attr(daten_vds90[["vds90_geschlecht"]], "labels")
|
||
if (!is.null(geschlecht_labels_attr)) {
|
||
g_text = names(geschlecht_labels_attr)[
|
||
as.integer(geschlecht_labels_attr) == as.integer(geschlecht_raw)
|
||
]
|
||
if (length(g_text) == 0) g_text = as.character(geschlecht_raw)
|
||
} else {
|
||
g_text = tryCatch(
|
||
as.character(haven::as_factor(geschlecht_raw)),
|
||
error = function(e) as.character(geschlecht_raw)
|
||
)
|
||
}
|
||
geschlecht = if (grepl("weiblich", g_text[1], ignore.case = TRUE)) "weiblich" else "maennlich"
|
||
geschlecht_label = g_text[1]
|
||
|
||
# labels-Attribut aus Original-Spalten lesen, nicht aus dem subgesetteten Datensatz
|
||
item_namen = sprintf("vds90_%02d", 1:90)
|
||
stufen = sapply(item_namen, function(nm) {
|
||
spalte_orig = daten_vds90[[nm]]
|
||
rohwert = as.numeric(zeile[[nm]])
|
||
stufe_aus_labels_fuer_wert(spalte_orig, rohwert)
|
||
})
|
||
names(stufen) = item_namen
|
||
|
||
alle_kuerzel = c(names(vds90_subskalen_items)[names(vds90_subskalen_items) != "GE"], "GE")
|
||
subsk_erg = lapply(setNames(alle_kuerzel, alle_kuerzel), function(sk) {
|
||
item_nms = sprintf("vds90_%02d", vds90_subskalen_items[[sk]])
|
||
sk_stufen = stufen[item_nms]
|
||
summe = sum(sk_stufen, na.rm = TRUE)
|
||
mittelwert = mean(sk_stufen, na.rm = TRUE)
|
||
pr = berechne_prozentrang(summe, mittelwert, sk, geschlecht)
|
||
list(
|
||
kuerzel = sk,
|
||
bezeichnung = vds90_bezeichnungen[[sk]],
|
||
item_namen = item_nms,
|
||
stufen = sk_stufen,
|
||
summe = summe,
|
||
mittelwert = mittelwert,
|
||
prozentrang = pr
|
||
)
|
||
})
|
||
|
||
datum_str = tryCatch(
|
||
format(as.Date(as.character(zeile$created[1])), "%d.%m.%Y"),
|
||
error = function(e) as.character(zeile$created[1])
|
||
)
|
||
|
||
list(
|
||
ok = TRUE,
|
||
chiffre = chiffre,
|
||
datum = datum_str,
|
||
geschlecht = geschlecht,
|
||
geschlecht_label = geschlecht_label,
|
||
stufen = stufen,
|
||
subsk_erg = subsk_erg,
|
||
warnung = warnung
|
||
)
|
||
})
|
||
|
||
|
||
output$ergebnis = renderUI({
|
||
|
||
if (input$btn_suchen == 0) {
|
||
return(div(class = "start-hinweis",
|
||
"Patientenchiffre eingeben und auf \"Auswerten\" klicken."
|
||
))
|
||
}
|
||
|
||
daten = daten_reaktiv()
|
||
|
||
if (!is.null(daten$fehler)) {
|
||
return(div(class = "alert-fehler", daten$fehler))
|
||
}
|
||
if (!isTRUE(daten$ok)) return(NULL)
|
||
|
||
korder_27 = vds90_kuerzel_reihenfolge[vds90_kuerzel_reihenfolge != "GE"]
|
||
|
||
tagList(
|
||
div(class = "abschnitt-karte",
|
||
div(class = "kopf-info",
|
||
tags$b("Chiffre: "), daten$chiffre, " ",
|
||
tags$b("Datum: "), daten$datum, " ",
|
||
tags$b("Geschlecht: "), daten$geschlecht_label
|
||
),
|
||
if (!is.null(daten$warnung)) div(class = "alert-warnung", daten$warnung)
|
||
),
|
||
|
||
{
|
||
s25 = daten$stufen[["vds90_25"]]
|
||
s26 = daten$stufen[["vds90_26"]]
|
||
aktiv_25 = !is.na(s25) && s25 > 0
|
||
aktiv_26 = !is.na(s26) && s26 > 0
|
||
if (aktiv_25 || aktiv_26) {
|
||
detail_txt = paste0(
|
||
if (aktiv_25) sprintf("Item 25 (Suizidgedanken): Antwort %d", as.integer(s25)),
|
||
if (aktiv_25 && aktiv_26) " | ",
|
||
if (aktiv_26) sprintf("Item 26 (Suizidabsicht): Antwort %d", as.integer(s26))
|
||
)
|
||
div(class = "suizid-warn-box",
|
||
tags$span("⚠️ Suizidalität: Bitte Items 25/26 beachten"),
|
||
div(class = "suizid-detail", detail_txt)
|
||
)
|
||
}
|
||
},
|
||
|
||
div(class = "uebersicht-box",
|
||
tags$details(open = NA,
|
||
tags$summary(strong("Übersichtsdiagramme (4 Diagramme einblenden/ausblenden)")),
|
||
br(),
|
||
fluidRow(
|
||
column(6, plotOutput("plot_schweregrad", height = "300px")),
|
||
column(6, plotOutput("plot_prozentrang", height = "300px"))
|
||
),
|
||
fluidRow(
|
||
column(6, plotOutput("plot_abweichung", height = "300px")),
|
||
column(6, plotOutput("plot_vergleich", height = "300px"))
|
||
)
|
||
)
|
||
),
|
||
|
||
div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel",
|
||
tags$span(class = "kuerzel", "GE"),
|
||
vds90_bezeichnungen[["GE"]]
|
||
),
|
||
plotOutput("gauge_GE", height = "70px")
|
||
),
|
||
|
||
lapply(korder_27, function(sk) {
|
||
n_items = length(vds90_subskalen_items[[sk]])
|
||
div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel",
|
||
tags$span(class = "kuerzel", sk),
|
||
vds90_bezeichnungen[[sk]]
|
||
),
|
||
plotOutput(paste0("gauge_", sk), height = "70px"),
|
||
tags$details(
|
||
tags$summary(sprintf("Items einblenden (%d Item%s)",
|
||
n_items, if (n_items > 1) "s" else "")),
|
||
div(class = "items-container", uiOutput(paste0("items_", sk)))
|
||
)
|
||
)
|
||
})
|
||
)
|
||
})
|
||
|
||
|
||
observe({
|
||
daten = daten_reaktiv()
|
||
if (!isTRUE(daten$ok)) return()
|
||
|
||
for (sk in vds90_kuerzel_reihenfolge) {
|
||
local({
|
||
sk_ = sk
|
||
erg = daten$subsk_erg[[sk_]]
|
||
|
||
output[[paste0("gauge_", sk_)]] = renderPlot({
|
||
gauge_ggplot(erg$mittelwert, erg$prozentrang)
|
||
}, height = 70, bg = "transparent")
|
||
|
||
if (sk_ != "GE") output[[paste0("items_", sk_)]] = renderUI({
|
||
item_tags = lapply(erg$item_namen, function(nm) {
|
||
stufe_val = erg$stufen[[nm]]
|
||
badge_cls = if (!is.na(stufe_val)) {
|
||
paste0("stufe-badge stufe-badge-", as.integer(stufe_val))
|
||
} else {
|
||
"stufe-badge"
|
||
}
|
||
badge_txt = if (!is.na(stufe_val)) as.character(as.integer(stufe_val)) else "?"
|
||
ist_suizid = nm %in% c("vds90_25", "vds90_26")
|
||
warn_aktiv = ist_suizid && !is.na(stufe_val) && stufe_val > 0
|
||
row_cls = if (warn_aktiv) "item-zeile item-row-suizid" else "item-zeile"
|
||
div(class = row_cls,
|
||
span(class = "item-nr", nm),
|
||
span(class = "item-text", vds90_itemtexte[[nm]]),
|
||
span(class = badge_cls, badge_txt),
|
||
if (warn_aktiv) span(class = "suizid-badge", "Suizid")
|
||
)
|
||
})
|
||
do.call(tagList, item_tags)
|
||
})
|
||
})
|
||
}
|
||
|
||
ueb_df = make_uebersicht_df(daten$subsk_erg, daten$geschlecht)
|
||
|
||
output$plot_schweregrad = renderPlot({ plot_schweregrad(ueb_df) })
|
||
output$plot_prozentrang = renderPlot({ plot_prozentrang(ueb_df) })
|
||
output$plot_abweichung = renderPlot({ plot_abweichung(ueb_df) })
|
||
output$plot_vergleich = renderPlot({ plot_vergleich(ueb_df) })
|
||
})
|
||
|
||
|
||
output$download_word = downloadHandler(
|
||
filename = function() {
|
||
daten = daten_reaktiv()
|
||
chiffre_safe = if (!is.null(daten$chiffre)) gsub("[^A-Za-z0-9_-]", "_", daten$chiffre) else "unbekannt"
|
||
datum_fn = if (!is.null(daten$datum)) {
|
||
tryCatch(format(as.Date(daten$datum, "%d.%m.%Y"), "%Y%m%d"),
|
||
error = function(e) format(Sys.Date(), "%Y%m%d"))
|
||
} else format(Sys.Date(), "%Y%m%d")
|
||
sprintf("VDS90_%s_%s.docx", chiffre_safe, datum_fn)
|
||
},
|
||
content = function(file) {
|
||
daten = daten_reaktiv()
|
||
if (is.null(daten$ok) || !isTRUE(daten$ok)) {
|
||
showNotification("Bitte zuerst eine Suche durchführen.", type = "error")
|
||
return(NULL)
|
||
}
|
||
doc = erstelle_vds90_docx(daten)
|
||
print(doc, target = file)
|
||
}
|
||
)
|
||
}
|
||
|
||
|
||
# Start ####
|
||
|
||
shinyApp(ui = ui, server = server)
|