662 lines
25 KiB
R
662 lines
25 KiB
R
# Präambel ####
|
||
|
||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_vds30_11.R" # liefert: daten_vds30_11
|
||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo
|
||
AKZENT_FARBE = "#8B2635"
|
||
|
||
VDS30_11_DISCLAIMER = paste0(
|
||
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
|
||
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ",
|
||
"Cutoff-Markierungen weisen auf einen Verdacht hin, sie sind kein diagnostisches Urteil."
|
||
)
|
||
VDS30_11_DISCLAIMER = gsub("fuer", "für", VDS30_11_DISCLAIMER, fixed = TRUE)
|
||
|
||
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 ####
|
||
|
||
# Itemnamen einer Skala programmatisch bauen (vds11_su01 ... vds11_su10),
|
||
# statt 110 Namen auszuschreiben.
|
||
vds11_item_namen = function(praefix) sprintf("vds11_%s%02d", praefix, 1:10)
|
||
|
||
# OFFENER PUNKT FUER DEN ERSTEN TESTLAUF: Das genaue Exportformat von formr-Items
|
||
# vom Typ "mc" (im Unterschied zum an anderer Stelle in diesem Projekt etablierten
|
||
# mc_button) ist fuer dieses Instrument noch nicht gegen einen echten Testdurchlauf
|
||
# verifiziert. Die Funktion deckt defensiv beide plausiblen Faelle ab:
|
||
# - haven_labelled Spalte mit labels-Attribut: der Stufenwert (0-3) wird ueber
|
||
# die fuehrende Ziffer des Label-Texts ("0 = nicht", "1 = leicht", ...)
|
||
# aufgeloest, NIEMALS ueber den moeglicherweise abweichenden Rohcode.
|
||
# - bereits rein numerische Spalte (0-3): wird direkt uebernommen.
|
||
# Nach dem ersten echten Testdatensatz pruefen, ob die extrahierten Werte
|
||
# plausibel sind (Bereich 0-3, keine NA bei vollstaendig ausgefuelltem Bogen).
|
||
vds11_item_werte_spalte = function(daten, feldname) {
|
||
if (!(feldname %in% names(daten))) return(rep(NA_real_, nrow(daten)))
|
||
x = daten[[feldname]]
|
||
labels_attr = attr(x, "labels")
|
||
if (is.null(labels_attr)) return(as.numeric(x))
|
||
treffer = match(as.numeric(x), as.numeric(labels_attr))
|
||
as.numeric(sub("^(\\d+).*", "\\1", names(labels_attr)[treffer]))
|
||
}
|
||
|
||
# Skalen-Mittelwert ueber 10 Itemrohwerte. Fehlt auch nur eines der Items (NA),
|
||
# wird NICHT stillschweigend aus den uebrigen gemittelt, sondern NA
|
||
# zurueckgegeben (keine Scheinpraezision) - die Anzeige muss das explizit als
|
||
# "unvollstaendig ausgefuellt" kennzeichnen.
|
||
vds11_skala_mittelwert = function(werte) {
|
||
n_gesamt = length(werte)
|
||
n_vorhanden = sum(!is.na(werte))
|
||
mittelwert = if (n_vorhanden == n_gesamt) mean(werte) else NA_real_
|
||
list(mittelwert = mittelwert, n_vorhanden = n_vorhanden, n_gesamt = n_gesamt)
|
||
}
|
||
|
||
# Cutoff-Pruefung: Mittelwert >= CUTOFF_WERT. NA bleibt NA (nicht beurteilbar).
|
||
vds11_cutoff_erreicht = function(mittelwert) {
|
||
if (is.na(mittelwert)) return(NA)
|
||
mittelwert >= CUTOFF_WERT
|
||
}
|
||
|
||
# Einzelne horizontale Profil-Leiste (0-3-Skala) fuer eine Skalenzeile.
|
||
# Cutoff-Skalen erhalten eine gestrichelte Linie bei CUTOFF_WERT und wechseln
|
||
# bei Erreichen auf Akzentfarbe; SS/KO (hat_cutoff = FALSE) bleiben neutral
|
||
# grau und ohne Cutoff-Linie.
|
||
vds11_balken_plot = function(zeile) {
|
||
y_balken = if (is.na(zeile$mittelwert)) 0 else zeile$mittelwert
|
||
ist_cutoff_erreicht = isTRUE(zeile$hat_cutoff) && !is.na(zeile$cutoff_erreicht) && zeile$cutoff_erreicht
|
||
balkenfarbe = if (!zeile$hat_cutoff) {
|
||
"#9E9E9E"
|
||
} else if (ist_cutoff_erreicht) {
|
||
AKZENT_FARBE
|
||
} else {
|
||
"#C98A93"
|
||
}
|
||
df = data.frame(x = "", y = y_balken)
|
||
p = ggplot(df, aes(x = x, y = y)) +
|
||
geom_col(fill = balkenfarbe, width = 0.5) +
|
||
coord_flip() +
|
||
scale_y_continuous(limits = c(0, 3), breaks = 0:3, expand = c(0, 0)) +
|
||
labs(x = NULL, y = NULL) +
|
||
theme_minimal(base_size = 11) +
|
||
theme(
|
||
axis.text.y = element_blank(),
|
||
panel.grid.minor = element_blank(),
|
||
plot.margin = margin(t = 2, r = 8, b = 2, l = 2)
|
||
)
|
||
if (isTRUE(zeile$hat_cutoff)) {
|
||
p = p + geom_hline(yintercept = CUTOFF_WERT, linetype = "dashed", color = "#555555")
|
||
}
|
||
p
|
||
}
|
||
|
||
|
||
# Datenaufbereitung ####
|
||
|
||
VDS11_SKALEN = data.frame(
|
||
praefix = c("su","de","zw","pa","hi","sc","na","bo","pr","ss","ko"),
|
||
bezeichnung = c("Selbstunsicher-ängstlich","Dependent","Zwanghaft","Passiv-aggressiv",
|
||
"Histrionisch","Schizoid","Narzisstisch","Borderline / emotional instabil",
|
||
"paranoid","stark-selbständig","vorausschauend"),
|
||
hat_cutoff = c(TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,FALSE,FALSE),
|
||
stringsAsFactors = FALSE
|
||
)
|
||
CUTOFF_WERT = 2.1
|
||
|
||
# Praefixe der 9 Skalen, die in den NEU-Gesamtwert (Neurotizismus) eingehen.
|
||
VDS11_NEU_PRAEFIXE = VDS11_SKALEN$praefix[VDS11_SKALEN$hat_cutoff]
|
||
|
||
|
||
# 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: 18px 24px 14px;
|
||
margin-bottom: 20px; border-radius: 0 0 6px 6px;
|
||
}
|
||
.app-header h2 { margin: 0; font-size: 1.5rem; font-weight: 600; }
|
||
.app-header p { margin: 4px 0 0; opacity: 0.85; font-size: 0.9rem; }
|
||
.input-panel {
|
||
background: white; border-radius: 6px; padding: 16px 20px;
|
||
margin-bottom: 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
|
||
display: flex; align-items: flex-end; gap: 12px; flex-wrap: wrap;
|
||
}
|
||
.input-panel .form-group { margin-bottom: 0; }
|
||
.input-panel label { font-weight: 600; color: #333; }
|
||
.btn-laden {
|
||
background: #8B2635 !important; color: white !important;
|
||
border: none !important; border-radius: 4px !important;
|
||
padding: 8px 20px !important; font-weight: 600 !important; cursor: pointer;
|
||
}
|
||
.btn-laden:hover { background: #6d1e29 !important; }
|
||
.alert-fehler {
|
||
background: #FFEBEE; border-left: 5px solid #C62828;
|
||
padding: 12px 16px; border-radius: 4px; color: #B71C1C;
|
||
margin-bottom: 12px; font-weight: 500;
|
||
}
|
||
.alert-warnung {
|
||
background: #FFF3E0; border-left: 5px solid #E65100;
|
||
padding: 10px 16px; border-radius: 4px; color: #BF360C;
|
||
margin-bottom: 12px; font-size: 0.93em; font-weight: 500;
|
||
}
|
||
.abschnitt-karte {
|
||
background: white; border-radius: 6px; padding: 20px 24px;
|
||
margin-bottom: 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
|
||
}
|
||
.abschnitt-titel {
|
||
color: #8B2635; font-size: 1.15rem; font-weight: 700;
|
||
border-bottom: 2px solid #8B2635; padding-bottom: 8px; margin-bottom: 14px;
|
||
}
|
||
.meta-block { margin-bottom: 10px; color: #555; font-size: 0.95em; }
|
||
.meta-block strong { color: #222; }
|
||
.item-zeile {
|
||
display: flex; align-items: center; gap: 10px;
|
||
padding: 7px 0; border-bottom: 1px solid #F0F0F0;
|
||
}
|
||
.item-zeile:last-child { border-bottom: none; }
|
||
.item-nr { font-weight: 600; color: #8B2635; min-width: 30px; flex-shrink: 0; }
|
||
.item-text { flex: 1; color: #333; font-size: 0.92em; }
|
||
.skala-zeile {
|
||
display: flex; align-items: center; gap: 14px;
|
||
padding: 8px 0; border-bottom: 1px solid #F0F0F0;
|
||
}
|
||
.skala-zeile:last-child { border-bottom: none; }
|
||
.skala-zeile .skala-bezeichnung { min-width: 230px; color: #333; font-size: 0.95em; }
|
||
.skala-zeile .skala-balken { flex: 1; }
|
||
.skala-zeile .skala-wert { min-width: 190px; text-align: right; color: #333; font-size: 0.9em; }
|
||
.skala-cutoff .skala-bezeichnung,
|
||
.skala-cutoff .skala-wert { font-weight: 700; color: #8B2635; }
|
||
.skala-kein-cutoff-hinweis {
|
||
font-size: 0.78em; color: #999; font-style: italic; min-width: 170px; text-align: right;
|
||
}
|
||
.neu-zeile .skala-bezeichnung,
|
||
.neu-zeile .skala-wert { font-size: 1.05em; }
|
||
"
|
||
|
||
app_css = gsub("#8B2635", AKZENT_FARBE, app_css, fixed = TRUE)
|
||
|
||
ui = fluidPage(
|
||
tags$head(
|
||
tags$meta(charset = "UTF-8"),
|
||
tags$style(HTML(app_css))
|
||
),
|
||
|
||
div(class = "app-header",
|
||
tags$h2("VDS30-11 – Persönlichkeitsauswertung"),
|
||
tags$p("11 Subskalen (je 10 Items, 0–3), Cutoff ≥ 2,1 für 9 Skalen + Gesamtwert NEU")
|
||
),
|
||
|
||
div(class = "container-fluid",
|
||
|
||
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("fehler_ui"),
|
||
uiOutput("warnung_ui"),
|
||
uiOutput("ergebnis_ui")
|
||
)
|
||
)
|
||
|
||
|
||
# Word-Export ####
|
||
|
||
erstelle_vds30_11_docx = function(erg) {
|
||
doc = read_docx()
|
||
|
||
fp_titel = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18)
|
||
fp_abschnitt = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 13)
|
||
fp_label = fp_text(bold = TRUE, font.size = 11)
|
||
fp_normal = fp_text(font.size = 11)
|
||
fp_cutoff = fp_text(bold = TRUE, color = AKZENT_FARBE, font.size = 11)
|
||
fp_hinweis = fp_text(italic = TRUE, font.size = 9, color = "#777777")
|
||
fp_warnung = fp_text(font.size = 10, italic = TRUE, color = "#BF360C")
|
||
fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("VDS30-11 — Persönlichkeitsauswertung", fp_titel)))
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext("Chiffre: ", fp_label), ftext(erg$chiffre, fp_normal),
|
||
ftext(" Ausfülldatum: ", fp_label), ftext(erg$ausfuelldatum, fp_normal)
|
||
))
|
||
if (!is.null(erg$mehrfach_warnung)) {
|
||
doc = body_add_fpar(doc, fpar(ftext(erg$mehrfach_warnung, fp_warnung)))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Profil der 11 Subskalen", fp_abschnitt)))
|
||
|
||
for (r in seq_len(nrow(erg$profil_df))) {
|
||
zeile = erg$profil_df[r, ]
|
||
wert_text = if (is.na(zeile$mittelwert)) {
|
||
"unvollständig ausgefüllt, kein Mittelwert berechenbar"
|
||
} else {
|
||
format(round(zeile$mittelwert, 2), nsmall = 2)
|
||
}
|
||
ist_cutoff = isTRUE(zeile$hat_cutoff) && !is.na(zeile$cutoff_erreicht) && zeile$cutoff_erreicht
|
||
fp_wert = if (ist_cutoff) fp_cutoff else fp_normal
|
||
wert_anzeige = if (ist_cutoff) paste0("* ", wert_text) else wert_text
|
||
|
||
laeufe = list(
|
||
ftext(paste0(zeile$bezeichnung, " (", zeile$praefix, "): "), fp_label),
|
||
ftext(wert_anzeige, fp_wert)
|
||
)
|
||
if (ist_cutoff) {
|
||
laeufe = c(laeufe, list(ftext(" Verdacht auf Achse-II-Auffälligkeit", fp_cutoff)))
|
||
}
|
||
if (!zeile$hat_cutoff) {
|
||
laeufe = c(laeufe, list(ftext(" kein Cutoff dokumentiert, eigene Ergänzung ohne dokumentierten Cutoff", fp_hinweis)))
|
||
}
|
||
doc = body_add_fpar(doc, do.call(fpar, laeufe))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Gesamtwert Neurotizismus (NEU)", fp_abschnitt)))
|
||
neu_wert_text = if (is.na(erg$neu$mittelwert)) {
|
||
"unvollständig ausgefüllt, kein Mittelwert berechenbar"
|
||
} else {
|
||
format(round(erg$neu$mittelwert, 2), nsmall = 2)
|
||
}
|
||
neu_ist_cutoff = !is.na(erg$neu$cutoff_erreicht) && erg$neu$cutoff_erreicht
|
||
fp_neu_wert = if (neu_ist_cutoff) fp_cutoff else fp_label
|
||
neu_anzeige = if (neu_ist_cutoff) paste0("* ", neu_wert_text) else neu_wert_text
|
||
neu_laeufe = list(
|
||
ftext("Mittelwert über alle 90 Items der 9 Skalen SU–PR: ", fp_label),
|
||
ftext(neu_anzeige, fp_neu_wert)
|
||
)
|
||
if (neu_ist_cutoff) {
|
||
neu_laeufe = c(neu_laeufe, list(ftext(" Verdacht auf Achse-II-Auffälligkeit", fp_cutoff)))
|
||
}
|
||
doc = body_add_fpar(doc, do.call(fpar, neu_laeufe))
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
if (!is.null(erg$mehrfach_warnung)) {
|
||
doc = body_add_fpar(doc, fpar(ftext(erg$mehrfach_warnung, fp_warnung)))
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
}
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext(VDS30_11_DISCLAIMER, fp_disclaimer)))
|
||
|
||
doc
|
||
}
|
||
|
||
|
||
# Server ####
|
||
|
||
server = function(input, output, session) {
|
||
|
||
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)))
|
||
}
|
||
})
|
||
|
||
# Skripte werden NICHT beim App-Start gesourct, nur beim Klick auf "Auswerten".
|
||
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", meldung = "Bitte Chiffre oder Pseudonym eingeben."))
|
||
}
|
||
if (nchar(trimws(input$pseudonym)) == 0 && !grepl("^[A-Z][0-9]{6}$", chiffre)) {
|
||
return(list(typ = "format_fehler", meldung = paste0(
|
||
"Ungültige Chiffre '", chiffre, "'. Erwartet: ein Großbuchstabe + 6 Ziffern (z.B. P000123)."
|
||
)))
|
||
}
|
||
|
||
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
|
||
return(list(typ = "skript_fehler", meldung = paste0(
|
||
"Download-Skript nicht gefunden:\n", PFAD_DOWNLOAD_SKRIPT
|
||
)))
|
||
}
|
||
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
|
||
return(list(typ = "skript_fehler", meldung = paste0(
|
||
"Pseudonym-Skript nicht gefunden:\n", PFAD_PSEUDONYM_SKRIPT
|
||
)))
|
||
}
|
||
|
||
ok = tryCatch({
|
||
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
|
||
list(ok = TRUE)
|
||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||
if (!ok$ok) return(list(typ = "skript_fehler", meldung = paste0("Fehler im Download-Skript: ", ok$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(typ = "skript_fehler", meldung = paste0(
|
||
"pseudonyme.db nicht gefunden (bis 5 Ebenen oberhalb von ",
|
||
dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE)), " gesucht)."
|
||
)))
|
||
}
|
||
|
||
alter_wd = getwd()
|
||
on.exit(setwd(alter_wd), add = TRUE)
|
||
setwd(db_ordner)
|
||
|
||
ok = tryCatch({
|
||
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
|
||
list(ok = TRUE)
|
||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||
if (!ok$ok) return(list(typ = "skript_fehler", meldung = paste0("Fehler im Pseudonym-Skript: ", ok$msg)))
|
||
|
||
if (!exists("daten_vds30_11", envir = .GlobalEnv) ||
|
||
!is.data.frame(get("daten_vds30_11", envir = .GlobalEnv))) {
|
||
return(list(typ = "skript_fehler", meldung = paste0(
|
||
"Objekt 'daten_vds30_11' nach dem Sourcen nicht gefunden oder kein Dataframe. ",
|
||
"Bitte Download-Skript prüfen."
|
||
)))
|
||
}
|
||
if (!exists("pseudo", envir = .GlobalEnv) ||
|
||
!is.data.frame(get("pseudo", envir = .GlobalEnv))) {
|
||
return(list(typ = "skript_fehler", meldung = paste0(
|
||
"Objekt 'pseudo' nach dem Sourcen nicht gefunden oder kein Dataframe. ",
|
||
"Bitte Pseudonym-Skript prüfen."
|
||
)))
|
||
}
|
||
|
||
daten_vds30_11 = get("daten_vds30_11", envir = .GlobalEnv)
|
||
pseudo = get("pseudo", envir = .GlobalEnv)
|
||
|
||
if (nchar(trimws(input$pseudonym)) > 0) {
|
||
pw_treffer = pseudo[pseudo$pseudonym == trimws(input$pseudonym), ]
|
||
if (nrow(pw_treffer) > 0) chiffre = toupper(trimws(pw_treffer$chiffre[1]))
|
||
}
|
||
|
||
treffer_ps = pseudo[toupper(trimws(as.character(pseudo$chiffre))) == chiffre, ]
|
||
if (nrow(treffer_ps) == 0) {
|
||
return(list(typ = "kein_datensatz", meldung = paste0(
|
||
"Chiffre '", chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden."
|
||
)))
|
||
}
|
||
|
||
alle_session_ids = unique(treffer_ps$pseudonym)
|
||
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
|
||
|
||
# OFFENER PUNKT FUER DEN ERSTEN TESTLAUF: Der Spaltenname der Session-ID im
|
||
# Download-Objekt ist fuer diese formr-Instanz nicht verifiziert. formr-
|
||
# Rohexporte verwenden typischerweise "session", das ist hier aber nicht
|
||
# bestaetigt.
|
||
if (!("session" %in% names(daten_vds30_11))) {
|
||
return(list(typ = "skript_fehler", meldung = paste0(
|
||
"Erwartete Spalte 'session' in 'daten_vds30_11' nicht gefunden. ",
|
||
"Bitte Spaltennamen im Download-Skript pruefen."
|
||
)))
|
||
}
|
||
zeilen_index = which(daten_vds30_11$session %in% alle_session_ids)
|
||
if (length(zeilen_index) == 0) {
|
||
return(list(typ = "kein_datensatz", meldung = paste0(
|
||
"Kein VDS30-11-Datensatz für Chiffre '", chiffre, "' gefunden. ",
|
||
"(", length(alle_session_ids), " Pseudonym(e) geprüft)"
|
||
)))
|
||
}
|
||
|
||
# OFFENER PUNKT FUER DEN ERSTEN TESTLAUF: Der Spaltenname des Erstellungs-
|
||
# zeitstempels ist ebenfalls nicht verifiziert, ueblicherweise "created".
|
||
sortier_spalte = intersect(c("created", "ended", "expired"), names(daten_vds30_11))
|
||
sortier_spalte = if (length(sortier_spalte) > 0) sortier_spalte[1] else NA_character_
|
||
|
||
mehrfach_warnung = NULL
|
||
if (length(zeilen_index) > 1) {
|
||
n = length(zeilen_index)
|
||
if (!is.na(sortier_spalte)) {
|
||
reihenfolge = order(daten_vds30_11[[sortier_spalte]][zeilen_index], decreasing = TRUE)
|
||
zeilen_index = zeilen_index[reihenfolge]
|
||
datum_neu = tryCatch(
|
||
format(as.POSIXct(daten_vds30_11[[sortier_spalte]][zeilen_index[1]]), "%d.%m.%Y %H:%M"),
|
||
error = function(e) "unbekanntes Datum"
|
||
)
|
||
} else {
|
||
datum_neu = "unbekanntes Datum (keine Datumsspalte gefunden)"
|
||
}
|
||
mehrfach_warnung = paste0(
|
||
"Mehrere Ausfüllungen gefunden (", n, " Einträge). ",
|
||
"Angezeigt wird die neueste vom ", datum_neu, "."
|
||
)
|
||
}
|
||
zeile_idx = zeilen_index[1]
|
||
|
||
ausfuelldatum = NA_character_
|
||
if (!is.na(sortier_spalte)) {
|
||
ausfuelldatum = tryCatch({
|
||
d = format(as.POSIXct(daten_vds30_11[[sortier_spalte]][zeile_idx]), "%d.%m.%Y")
|
||
if (is.na(d)) stop("NA")
|
||
d
|
||
}, error = function(e) NA_character_)
|
||
}
|
||
if (is.na(ausfuelldatum)) ausfuelldatum = format(Sys.Date(), "%d.%m.%Y")
|
||
|
||
# Skalen-Mittelwerte fuer alle 11 Skalen berechnen.
|
||
profil_df = do.call(rbind, lapply(seq_len(nrow(VDS11_SKALEN)), function(i) {
|
||
praefix = VDS11_SKALEN$praefix[i]
|
||
felder = vds11_item_namen(praefix)
|
||
werte = sapply(felder, function(f) vds11_item_werte_spalte(daten_vds30_11, f)[zeile_idx])
|
||
erg_sk = vds11_skala_mittelwert(werte)
|
||
cutoff = if (VDS11_SKALEN$hat_cutoff[i]) vds11_cutoff_erreicht(erg_sk$mittelwert) else NA
|
||
data.frame(
|
||
praefix = praefix,
|
||
bezeichnung = VDS11_SKALEN$bezeichnung[i],
|
||
hat_cutoff = VDS11_SKALEN$hat_cutoff[i],
|
||
mittelwert = erg_sk$mittelwert,
|
||
n_vorhanden = erg_sk$n_vorhanden,
|
||
n_gesamt = erg_sk$n_gesamt,
|
||
cutoff_erreicht = cutoff,
|
||
stringsAsFactors = FALSE
|
||
)
|
||
}))
|
||
|
||
# NEU (Gesamtwert Neurotizismus): Mittelwert ueber alle 90 Items der 9
|
||
# Skalen SU-PR. Gleiches NA-Handling: fehlt eines der 90 Items, ist NEU NA.
|
||
neu_felder = unlist(lapply(VDS11_NEU_PRAEFIXE, vds11_item_namen))
|
||
neu_werte = sapply(neu_felder, function(f) vds11_item_werte_spalte(daten_vds30_11, f)[zeile_idx])
|
||
neu_erg = vds11_skala_mittelwert(neu_werte)
|
||
neu = list(
|
||
mittelwert = neu_erg$mittelwert,
|
||
n_vorhanden = neu_erg$n_vorhanden,
|
||
n_gesamt = neu_erg$n_gesamt,
|
||
cutoff_erreicht = vds11_cutoff_erreicht(neu_erg$mittelwert)
|
||
)
|
||
|
||
list(
|
||
typ = "ok",
|
||
chiffre = chiffre,
|
||
ausfuelldatum = ausfuelldatum,
|
||
mehrfach_warnung = mehrfach_warnung,
|
||
profil_df = profil_df,
|
||
neu = neu
|
||
)
|
||
})
|
||
|
||
# Statische Plot-Outputs fuer alle 11 Skalen + NEU. Praefixe sind zur Laufzeit
|
||
# fest (aus VDS11_SKALEN bekannt), daher hier einmalig ausserhalb der
|
||
# eventReactive-Kette registriert; local() friert praefix_lokal je
|
||
# Schleifendurchlauf ein (verhindert das uebliche Spaetauswertungs-Problem
|
||
# in R-Schleifen).
|
||
for (praefix_iter in c(VDS11_SKALEN$praefix, "neu")) {
|
||
local({
|
||
praefix_lokal = praefix_iter
|
||
output[[paste0("plot_skala_", praefix_lokal)]] = renderPlot({
|
||
d = ergebnis_r()
|
||
req(identical(d$typ, "ok"))
|
||
if (praefix_lokal == "neu") {
|
||
zeile = data.frame(
|
||
mittelwert = d$neu$mittelwert, hat_cutoff = TRUE,
|
||
cutoff_erreicht = d$neu$cutoff_erreicht
|
||
)
|
||
} else {
|
||
zeile = d$profil_df[d$profil_df$praefix == praefix_lokal, ]
|
||
}
|
||
vds11_balken_plot(zeile)
|
||
}, bg = "transparent")
|
||
})
|
||
}
|
||
|
||
output$fehler_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
if (!identical(d$typ, "ok")) div(class = "alert-fehler", d$meldung)
|
||
})
|
||
|
||
output$warnung_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
if (!identical(d$typ, "ok")) return(NULL)
|
||
if (is.null(d$mehrfach_warnung)) return(NULL)
|
||
div(class = "alert-warnung", d$mehrfach_warnung)
|
||
})
|
||
|
||
output$ergebnis_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
if (!identical(d$typ, "ok")) return(NULL)
|
||
|
||
skala_zeile_ui = function(praefix, bezeichnung, mittelwert, hat_cutoff, cutoff_erreicht) {
|
||
ist_cutoff = isTRUE(hat_cutoff) && !is.na(cutoff_erreicht) && cutoff_erreicht
|
||
wert_text = if (is.na(mittelwert)) {
|
||
"unvollständig ausgefüllt, kein Mittelwert berechenbar"
|
||
} else {
|
||
paste0(if (ist_cutoff) "* " else "", format(round(mittelwert, 2), nsmall = 2),
|
||
if (ist_cutoff) " Verdacht auf Achse-II-Auffälligkeit" else "")
|
||
}
|
||
div(class = paste("skala-zeile", if (ist_cutoff) "skala-cutoff" else ""),
|
||
div(class = "skala-bezeichnung", bezeichnung),
|
||
div(class = "skala-balken", plotOutput(paste0("plot_skala_", praefix), height = "42px")),
|
||
div(class = "skala-wert", wert_text),
|
||
if (!hat_cutoff) div(class = "skala-kein-cutoff-hinweis", "kein Cutoff dokumentiert")
|
||
)
|
||
}
|
||
|
||
skalen_ui = lapply(seq_len(nrow(d$profil_df)), function(i) {
|
||
z = d$profil_df[i, ]
|
||
skala_zeile_ui(z$praefix, z$bezeichnung, z$mittelwert, z$hat_cutoff, z$cutoff_erreicht)
|
||
})
|
||
|
||
neu_ist_cutoff = !is.na(d$neu$cutoff_erreicht) && d$neu$cutoff_erreicht
|
||
neu_wert_text = if (is.na(d$neu$mittelwert)) {
|
||
"unvollständig ausgefüllt, kein Mittelwert berechenbar"
|
||
} else {
|
||
paste0(if (neu_ist_cutoff) "* " else "", format(round(d$neu$mittelwert, 2), nsmall = 2),
|
||
if (neu_ist_cutoff) " Verdacht auf Achse-II-Auffälligkeit" else "")
|
||
}
|
||
neu_ui = div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Gesamtwert Neurotizismus (NEU)"),
|
||
div(class = paste("skala-zeile neu-zeile", if (neu_ist_cutoff) "skala-cutoff" else ""),
|
||
div(class = "skala-bezeichnung", "NEU (Mittelwert über alle 90 Items der 9 Skalen SU–PR)"),
|
||
div(class = "skala-balken", plotOutput("plot_skala_neu", height = "48px")),
|
||
div(class = "skala-wert", neu_wert_text)
|
||
)
|
||
)
|
||
|
||
tagList(
|
||
div(class = "abschnitt-karte",
|
||
div(class = "meta-block",
|
||
tags$strong("Chiffre: "), d$chiffre,
|
||
tags$span(" | ", style = "color:#ccc;"),
|
||
tags$strong("Ausfülldatum: "), d$ausfuelldatum
|
||
)
|
||
),
|
||
neu_ui,
|
||
div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Profil der 11 Subskalen"),
|
||
skalen_ui
|
||
),
|
||
div(class = "disclaimer-zeile", VDS30_11_DISCLAIMER)
|
||
)
|
||
})
|
||
|
||
output$download_word = downloadHandler(
|
||
filename = function() {
|
||
d = tryCatch(ergebnis_r(), error = function(e) NULL)
|
||
chiffre_esc = if (is.list(d) && identical(d$typ, "ok") && nchar(d$chiffre) > 0) {
|
||
gsub("[^A-Za-z0-9_-]", "_", d$chiffre)
|
||
} else {
|
||
"export"
|
||
}
|
||
datum_fn = tryCatch(
|
||
format(as.Date(d$ausfuelldatum, "%d.%m.%Y"), "%Y%m%d"),
|
||
error = function(e) format(Sys.Date(), "%Y%m%d")
|
||
)
|
||
if (is.na(datum_fn) || length(datum_fn) == 0) datum_fn = format(Sys.Date(), "%Y%m%d")
|
||
paste0("VDS30-11_", chiffre_esc, "_", datum_fn, ".docx")
|
||
},
|
||
content = function(file) {
|
||
d = tryCatch(ergebnis_r(), error = function(e) NULL)
|
||
daten_ok = is.list(d) && identical(d$typ, "ok")
|
||
if (!daten_ok) {
|
||
doc = read_docx()
|
||
doc = body_add_par(doc,
|
||
"Kein Datensatz geladen. Bitte zuerst Chiffre oder Pseudonym eingeben und 'Auswerten' klicken.",
|
||
style = "Normal")
|
||
print(doc, target = file)
|
||
return()
|
||
}
|
||
doc = tryCatch(
|
||
erstelle_vds30_11_docx(d),
|
||
error = function(e) {
|
||
err_doc = read_docx()
|
||
body_add_par(err_doc,
|
||
paste0("Fehler beim Erstellen des Word-Dokuments: ", e$message),
|
||
style = "Normal")
|
||
}
|
||
)
|
||
print(doc, target = file)
|
||
}
|
||
)
|
||
}
|
||
|
||
|
||
# Start ####
|
||
|
||
shinyApp(ui, server)
|