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

855
VDS90/app.R Normal file
View file

@ -0,0 +1,855 @@
# 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)