746 lines
27 KiB
R
746 lines
27 KiB
R
# Präambel ####
|
||
|
||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_ufragebogen.R"
|
||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
|
||
AKZENT_FARBE = "#8B2635"
|
||
|
||
UFB_DISCLAIMER = paste0(
|
||
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
|
||
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ",
|
||
"Die verwendeten Grenzwerte sind ohne dokumentierte Normstichprobe oder Validierungsquelle uebernommen worden."
|
||
)
|
||
|
||
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 ####
|
||
|
||
# Spaltenname in daten_ufragebogen per Muster suchen (case-insensitive). Kein
|
||
# stiller Fallback: bei keinem Treffer wird ein klarer Fehler geworfen, da
|
||
# der tatsaechliche Spaltenname von daten_ufragebogen nicht verifiziert ist.
|
||
u_finde_spalte = function(daten, muster, beschreibung) {
|
||
namen = names(daten)
|
||
treffer = namen[grepl(muster, namen, ignore.case = TRUE)]
|
||
if (length(treffer) == 0) {
|
||
stop(paste0(
|
||
"In daten_ufragebogen wurde keine Spalte gefunden, die zu '", beschreibung,
|
||
"' passt (Suchmuster: '", muster, "'). Bitte Datenstruktur des ",
|
||
"Download-Skripts pruefen."
|
||
))
|
||
}
|
||
treffer[1]
|
||
}
|
||
|
||
# rating_button 1,6,1: formr exportiert 1-indizierte Rohwerte 1-6 als dbl+lbl,
|
||
# nur die Endpunkte tragen Labels. Inhaltlicher Wert = Rohwert - 1 (Range 0-5).
|
||
# Reine Subtraktion, kein Label-Text-Matching (Zwischenwerte 2-5 sind unlabeled).
|
||
u_item_rohwert = function(original_col, wert) {
|
||
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_real_)
|
||
if (haven::is.labelled(original_col)) {
|
||
as.numeric(haven::zap_labels(wert[1]))
|
||
} else {
|
||
suppressWarnings(as.numeric(wert[1]))
|
||
}
|
||
}
|
||
|
||
# formr-Itemlabels enthalten Markdown-Fettung (**...**) und eine vorangestellte,
|
||
# redundante Itemnummer (z.B. "**6\. Ich schlucke...**") - beides wird entfernt,
|
||
# da Nummer und Wortlaut in der UI ohnehin getrennt (item-nr / item-text) angezeigt werden.
|
||
u_strip_markdown = function(x) {
|
||
if (is.null(x) || length(x) == 0) return(x)
|
||
x = gsub("\\*\\*", "", as.character(x))
|
||
x = sub("^\\s*\\d+\\\\?\\.\\s*", "", x)
|
||
trimws(x)
|
||
}
|
||
|
||
u_item_text = function(original_col, nr) {
|
||
lbl = attr(original_col, "label")
|
||
if (!is.null(lbl) && length(lbl) > 0 && !is.na(lbl) && nchar(trimws(as.character(lbl))) > 0) {
|
||
u_strip_markdown(lbl)
|
||
} else {
|
||
paste0("Item ", nr)
|
||
}
|
||
}
|
||
|
||
# richtung "hoch" = hoeherer Summenscore ist auffaelliger, "niedrig" = niedrigerer
|
||
# Summenscore ist auffaelliger (nur "Fordern koennen"). abs_abweichung ist so
|
||
# vorzeichenkodiert, dass positiv immer "unauffaellig" und negativ immer
|
||
# "auffaellig nach hinterlegtem Grenzwert" bedeutet, unabhaengig von der
|
||
# Richtung der Skala.
|
||
u_klassifiziere = function(summe, cutoff, richtung) {
|
||
if (is.na(summe)) {
|
||
return(list(klasse = NA_character_, abs_abweichung = NA_real_, rel_abweichung = NA_real_))
|
||
}
|
||
if (richtung == "hoch") {
|
||
signifikant = summe > cutoff
|
||
abs_abweichung = cutoff - summe
|
||
} else {
|
||
signifikant = summe < cutoff
|
||
abs_abweichung = summe - cutoff
|
||
}
|
||
list(
|
||
klasse = if (signifikant) "signifikant" else "ok",
|
||
abs_abweichung = abs_abweichung,
|
||
rel_abweichung = abs_abweichung / cutoff
|
||
)
|
||
}
|
||
|
||
# Zeichnet die auffaellige Zone (rot) immer auf der tatsaechlich kritischen Seite
|
||
# des Cutoffs, damit "Fordern koennen" (richtung = "niedrig") nicht spiegelbildlich
|
||
# zu den anderen Skalen missverstanden wird.
|
||
make_gauge_u = function(range_max, cutoff, richtung, summe, klasse) {
|
||
if (richtung == "hoch") {
|
||
zone_ok = c(0, cutoff)
|
||
zone_auf = c(cutoff, range_max)
|
||
} else {
|
||
zone_auf = c(0, cutoff)
|
||
zone_ok = c(cutoff, range_max)
|
||
}
|
||
|
||
p = ggplot() +
|
||
geom_rect(aes(xmin = zone_ok[1], xmax = zone_ok[2], ymin = 0, ymax = 1),
|
||
fill = "#E8F5E9", color = NA) +
|
||
geom_rect(aes(xmin = zone_auf[1], xmax = zone_auf[2], ymin = 0, ymax = 1),
|
||
fill = "#FFEBEE", color = NA) +
|
||
geom_rect(aes(xmin = 0, xmax = range_max, ymin = 0, ymax = 1),
|
||
fill = NA, color = "#9E9E9E", linewidth = 0.5) +
|
||
geom_vline(xintercept = cutoff, color = "#E65100", linetype = "dashed", linewidth = 1) +
|
||
annotate("text", x = cutoff, y = -0.45, label = paste0("Cutoff: ", cutoff),
|
||
color = "#E65100", size = 3.1, hjust = 0.5) +
|
||
scale_x_continuous(limits = c(-0.03 * range_max, 1.03 * range_max),
|
||
breaks = c(0, cutoff, range_max)) +
|
||
scale_y_continuous(limits = c(-0.7, 1.7)) +
|
||
theme_minimal(base_size = 12) +
|
||
theme(
|
||
axis.text.y = element_blank(), axis.ticks.y = element_blank(),
|
||
panel.grid.major.y = element_blank(), panel.grid.minor = element_blank(),
|
||
axis.title.y = element_blank(),
|
||
plot.margin = margin(t = 5, r = 10, b = 5, l = 10)
|
||
) +
|
||
labs(x = paste0("Summenscore (0-", range_max, ")"), y = NULL)
|
||
|
||
if (!is.na(summe)) {
|
||
marker_farbe = if (identical(klasse, "signifikant")) "#B71C1C" else "#2E7D32"
|
||
p = p +
|
||
geom_segment(aes(x = summe, xend = summe, y = -0.25, yend = 1.25),
|
||
color = marker_farbe, linewidth = 2.5) +
|
||
geom_label(aes(x = summe, y = 1.5, label = paste0("Summe: ", summe)),
|
||
fill = marker_farbe, color = "white", fontface = "bold",
|
||
linewidth = 0, size = 3.8)
|
||
}
|
||
p
|
||
}
|
||
|
||
|
||
# Datenaufbereitung ####
|
||
|
||
# Statische Item-zu-Subskala-Zuordnung (65 Items, ueberschneidungsfrei, gegen
|
||
# die xlsx verifiziert). Wird beim App-Start einmal geladen.
|
||
U_SUBSKALEN = data.frame(
|
||
key = c("fe", "ko", "fo", "nn", "s", "a"),
|
||
label = c("Kritik- und Fehlschlagangst", "Kontaktangst", "Fordern können",
|
||
"Nein-Sagen", "Schuldgefühle", "Überhöflichkeit"),
|
||
n_items = c(15, 15, 15, 10, 5, 5),
|
||
range_max = c(75, 75, 75, 50, 25, 25),
|
||
cutoff = c(41, 37, 30, 27, 11, 15),
|
||
richtung = c("hoch", "hoch", "niedrig", "hoch", "hoch", "hoch"),
|
||
stringsAsFactors = FALSE
|
||
)
|
||
|
||
u_fe_items = c(7, 13, 16, 19, 21, 27, 30, 31, 37, 38, 40, 45, 49, 51, 54)
|
||
u_ko_items = c(2, 4, 8, 11, 14, 22, 28, 44, 48, 50, 53, 59, 60, 61, 65)
|
||
u_fo_items = c(1, 3, 5, 10, 12, 18, 24, 32, 34, 39, 42, 46, 52, 55, 58)
|
||
u_nn_items = c(6, 9, 15, 20, 26, 29, 33, 43, 62, 64)
|
||
u_s_items = c(36, 41, 47, 56, 63)
|
||
u_a_items = c(17, 23, 25, 35, 57)
|
||
u_fo_invertiert = c(32, 46)
|
||
|
||
U_ITEM_MAP = rbind(
|
||
data.frame(nr = u_fe_items, suffix = "fe", invertiert = FALSE),
|
||
data.frame(nr = u_ko_items, suffix = "ko", invertiert = FALSE),
|
||
data.frame(nr = u_fo_items, suffix = "fo", invertiert = u_fo_items %in% u_fo_invertiert),
|
||
data.frame(nr = u_nn_items, suffix = "nn", invertiert = FALSE),
|
||
data.frame(nr = u_s_items, suffix = "s", invertiert = FALSE),
|
||
data.frame(nr = u_a_items, suffix = "a", invertiert = FALSE)
|
||
)
|
||
U_ITEM_MAP = U_ITEM_MAP[order(U_ITEM_MAP$nr), ]
|
||
U_ITEM_MAP$spalte = paste0("u_", sprintf("%02d", U_ITEM_MAP$nr), "_", U_ITEM_MAP$suffix)
|
||
|
||
|
||
# UI ####
|
||
|
||
# Stufe-Badge-Farben (.stufe-badge-0..5): Verlauf gruen -> dunkelrot, extrapoliert
|
||
# aus den 5 PG13R-Ankerfarben (#4CAF50, #F48FB1, #EF5350, #B71C1C, #4A0000) auf die
|
||
# 6 Stufen 0-5 der U-Fragebogen-Items per Lab-Farbinterpolation.
|
||
app_css = "
|
||
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; }
|
||
.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; }
|
||
#download_word {
|
||
background: #8B2635; color: white; border: none;
|
||
font-weight: 600; padding: 8px 20px; border-radius: 4px;
|
||
}
|
||
#download_word:hover { background: #6d1e29; color: white; }
|
||
.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; }
|
||
.subskala-score { font-size: 2rem; font-weight: 800; color: #8B2635; }
|
||
.subskala-klasse-signifikant { font-weight: 700; color: #B71C1C; margin-left: 14px; }
|
||
.subskala-klasse-ok { font-weight: 700; color: #2E7D32; margin-left: 14px; }
|
||
.subskala-abweichung { color: #555; font-size: 0.9em; margin-top: 4px; }
|
||
.subskala-kopf { display: flex; align-items: baseline; flex-wrap: wrap; }
|
||
.item-liste-titel {
|
||
cursor: pointer; color: #555; font-size: 0.88em; margin-top: 10px; display: inline-block;
|
||
}
|
||
.item-zeile {
|
||
display: flex; align-items: flex-start; gap: 10px;
|
||
padding: 6px 0; border-bottom: 1px solid #F0F0F0;
|
||
}
|
||
.item-nr { font-weight: 600; color: #8B2635; min-width: 30px; flex-shrink: 0; }
|
||
.item-text { flex: 1; color: #333; font-size: 0.92em; }
|
||
.stufe-badge {
|
||
border-radius: 4px; padding: 2px 9px; font-weight: 700;
|
||
font-size: 0.82em; white-space: nowrap; display: inline-block; flex-shrink: 0;
|
||
min-width: 22px; text-align: center;
|
||
}
|
||
.stufe-badge-na { background: #E0E0E0; color: #757575; font-style: italic; font-weight: 500; }
|
||
.stufe-badge-0 { background: #4CAE50; color: white; }
|
||
.stufe-badge-1 { background: #D8999E; color: #333333; }
|
||
.stufe-badge-2 { background: #F36C76; color: white; }
|
||
.stufe-badge-3 { background: #D83E3A; color: white; }
|
||
.stufe-badge-4 { background: #9F1517; color: white; }
|
||
.stufe-badge-5 { background: #4A0000; color: white; }
|
||
"
|
||
|
||
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("U-Fragebogen – Unsicherheit im sozialen Kontakt"),
|
||
tags$p("Subskalen-Auswertung sozialer Ängste")
|
||
),
|
||
|
||
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_ufb_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_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
|
||
fp_warn = fp_text(font.size = 10, italic = TRUE, color = "#BF360C")
|
||
fp_hinweis = fp_text(font.size = 9, italic = TRUE, color = "#555555")
|
||
fp_wert = fp_text(bold = TRUE, font.size = 12, color = AKZENT_FARBE)
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("U-Fragebogen - Auswertung", fp_titel)))
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext("Chiffre: ", fp_label), ftext(erg$chiffre, fp_normal),
|
||
ftext(" Ausfülldatum: ", fp_label), ftext(erg$datum_str, fp_normal)
|
||
))
|
||
for (w in erg$warnungen) {
|
||
doc = body_add_fpar(doc, fpar(ftext(w, fp_warn)))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
for (i in seq_len(nrow(erg$subskalen))) {
|
||
sub = erg$subskalen[i, ]
|
||
doc = body_add_fpar(doc, fpar(ftext(sub$label, fp_abschnitt)))
|
||
|
||
if (is.na(sub$summe)) {
|
||
doc = body_add_fpar(doc, fpar(ftext(sub$meldung, fp_warn)))
|
||
} else {
|
||
klasse_text = if (identical(sub$klasse, "signifikant"))
|
||
"auffällig nach hinterlegtem Grenzwert" else "unauffällig"
|
||
klasse_farbe = if (identical(sub$klasse, "signifikant")) "#C62828" else "#2E7D32"
|
||
fp_klasse = fp_text(bold = TRUE, font.size = 11, color = klasse_farbe)
|
||
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext("Summenscore: ", fp_label),
|
||
ftext(paste0(sub$summe, " / ", sub$range_max, " (Cutoff: ", sub$cutoff, ")"), fp_wert)
|
||
))
|
||
doc = body_add_fpar(doc, fpar(ftext(klasse_text, fp_klasse)))
|
||
doc = body_add_fpar(doc, fpar(ftext(
|
||
paste0(
|
||
"Abweichung vom Cutoff: ", sprintf("%+.1f", sub$abs_abweichung),
|
||
" (", sprintf("%+.1f%%", sub$rel_abweichung * 100), ")"
|
||
), fp_normal
|
||
)))
|
||
if (identical(sub$key, "fo")) {
|
||
doc = body_add_fpar(doc, fpar(ftext(
|
||
paste0(
|
||
"Hinweis: Bei dieser Subskala zeigt ein NIEDRIGER Wert die Auffälligkeit an ",
|
||
"(umgekehrte Richtung im Vergleich zu den anderen Subskalen)."
|
||
), fp_hinweis
|
||
)))
|
||
}
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
}
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext(UFB_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", chiffre = chiffre))
|
||
}
|
||
|
||
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = paste0("Download-Skript nicht gefunden unter:\n", PFAD_DOWNLOAD_SKRIPT)))
|
||
}
|
||
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = paste0("Pseudonym-Skript nicht gefunden unter:\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. Gesucht ausgehend vom Pseudonym-Skript-Ordner ",
|
||
"bis zu 5 Ebenen nach oben."
|
||
)))
|
||
}
|
||
|
||
alter_wd = getwd()
|
||
on.exit(setwd(alter_wd), add = TRUE)
|
||
setwd(db_ordner)
|
||
|
||
ok_ps = tryCatch({
|
||
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
|
||
list(ok = TRUE)
|
||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||
if (!ok_ps$ok) return(list(typ = "skript_fehler", meldung = paste0("Fehler im Pseudonym-Skript: ", ok_ps$msg)))
|
||
|
||
if (!exists("daten_ufragebogen", envir = .GlobalEnv)) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = "Objekt 'daten_ufragebogen' wurde nach dem Sourcen des Download-Skripts nicht gefunden."))
|
||
}
|
||
if (!exists("pseudo", envir = .GlobalEnv)) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = "Objekt 'pseudo' wurde nach dem Sourcen des Pseudonym-Skripts nicht gefunden."))
|
||
}
|
||
|
||
daten = get("daten_ufragebogen", envir = .GlobalEnv)
|
||
pseudo_df = get("pseudo", envir = .GlobalEnv)
|
||
|
||
# Spaltennamen fuer Sitzungskennung und Ausfuelldatum sind in daten_ufragebogen
|
||
# nicht verifiziert - defensiv per Musterabgleich ermitteln.
|
||
spalten_ok = tryCatch({
|
||
list(
|
||
session_spalte = u_finde_spalte(daten, "session|pseudonym", "Sitzungskennung"),
|
||
datum_spalte = u_finde_spalte(daten, "created|ausfuell|datum|ended", "Ausfülldatum"),
|
||
ok = TRUE
|
||
)
|
||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||
if (!isTRUE(spalten_ok$ok)) {
|
||
return(list(typ = "skript_fehler", meldung = spalten_ok$msg))
|
||
}
|
||
session_spalte = spalten_ok$session_spalte
|
||
datum_spalte = spalten_ok$datum_spalte
|
||
|
||
warnungen = c()
|
||
pseudonym_wert = trimws(input$pseudonym)
|
||
|
||
# Wenn Pseudonym eingegeben wurde: Chiffre daraus zurueckerhalten, damit
|
||
# Kopfzeile/Dateiname auch bei reiner Pseudonym-Eingabe korrekt sind.
|
||
if (nchar(pseudonym_wert) > 0) {
|
||
pw_treffer = pseudo_df[pseudo_df$pseudonym == pseudonym_wert, ]
|
||
if (nrow(pw_treffer) == 0) {
|
||
return(list(typ = "pseudonym_unbekannt", meldung = paste0(
|
||
"Pseudonym '", pseudonym_wert, "' wurde in der Pseudonym-Datenbank nicht gefunden."
|
||
)))
|
||
}
|
||
chiffre = toupper(trimws(pw_treffer$chiffre[1]))
|
||
}
|
||
|
||
treffer_ps = pseudo_df[pseudo_df$chiffre == chiffre, ]
|
||
if (nrow(treffer_ps) == 0) {
|
||
return(list(typ = "chiffre_unbekannt", meldung = paste0(
|
||
"Chiffre '", chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden."
|
||
)))
|
||
}
|
||
alle_session_ids = unique(treffer_ps$pseudonym)
|
||
|
||
# Eindeutigkeits-Override: explizit eingegebenes Pseudonym hat immer Vorrang.
|
||
if (nchar(pseudonym_wert) > 0) {
|
||
alle_session_ids = pseudonym_wert
|
||
}
|
||
|
||
treffer_dat = daten[daten[[session_spalte]] %in% alle_session_ids, ]
|
||
if (nrow(treffer_dat) == 0) {
|
||
return(list(typ = "kein_datensatz", meldung = paste0(
|
||
"Kein U-Fragebogen-Datensatz für Chiffre '", chiffre, "' gefunden. ",
|
||
"(", length(alle_session_ids), " Sitzungskennung(en) geprüft)"
|
||
)))
|
||
}
|
||
|
||
if (nrow(treffer_dat) > 1) {
|
||
n = nrow(treffer_dat)
|
||
sortier_wert = tryCatch(as.POSIXct(treffer_dat[[datum_spalte]]),
|
||
error = function(e) treffer_dat[[datum_spalte]])
|
||
treffer_dat = treffer_dat[order(sortier_wert, decreasing = TRUE), ]
|
||
datum_neu = tryCatch(
|
||
format(as.POSIXct(treffer_dat[[datum_spalte]][1]), "%d.%m.%Y %H:%M"),
|
||
error = function(e) as.character(treffer_dat[[datum_spalte]][1])
|
||
)
|
||
warnungen = c(warnungen, paste0(
|
||
"Mehrere Ausfüllungen gefunden (", n, " Einträge). Angezeigt wird die neueste vom ", datum_neu, "."
|
||
))
|
||
treffer_dat = treffer_dat[1, , drop = FALSE]
|
||
}
|
||
|
||
zeile = treffer_dat[1, , drop = FALSE]
|
||
datum_str = tryCatch(
|
||
format(as.POSIXct(zeile[[datum_spalte]][1]), "%d.%m.%Y"),
|
||
error = function(e) as.character(zeile[[datum_spalte]][1])
|
||
)
|
||
|
||
rohwerte = sapply(U_ITEM_MAP$spalte, function(v) u_item_rohwert(daten[[v]], zeile[[v]]))
|
||
|
||
ausserhalb = which(!is.na(rohwerte) & (rohwerte < 1 | rohwerte > 6))
|
||
if (length(ausserhalb) > 0) {
|
||
warnungen = c(warnungen, paste0(
|
||
"Rohwert außerhalb des erwarteten Bereichs 1-6 bei Item(s): ",
|
||
paste(U_ITEM_MAP$nr[ausserhalb], collapse = ", "),
|
||
". Umrechnung (Rohwert - 1) wurde trotzdem angewendet, bitte Datengrundlage prüfen."
|
||
))
|
||
}
|
||
|
||
inhaltliche_werte = rohwerte - 1
|
||
wert_final = ifelse(U_ITEM_MAP$invertiert, 5 - inhaltliche_werte, inhaltliche_werte)
|
||
|
||
items = data.frame(
|
||
nr = U_ITEM_MAP$nr,
|
||
suffix = U_ITEM_MAP$suffix,
|
||
spalte = U_ITEM_MAP$spalte,
|
||
invertiert = U_ITEM_MAP$invertiert,
|
||
rohwert = as.numeric(rohwerte),
|
||
wert = as.numeric(wert_final),
|
||
stringsAsFactors = FALSE
|
||
)
|
||
items$text = sapply(seq_len(nrow(items)), function(i) {
|
||
u_item_text(daten[[items$spalte[i]]], items$nr[i])
|
||
})
|
||
items$wert_str = ifelse(is.na(items$wert), "k. A.", as.character(items$wert))
|
||
|
||
subskalen = U_SUBSKALEN
|
||
subskalen$summe = NA_real_
|
||
subskalen$n_fehlend = NA_integer_
|
||
subskalen$meldung = NA_character_
|
||
subskalen$klasse = NA_character_
|
||
subskalen$abs_abweichung = NA_real_
|
||
subskalen$rel_abweichung = NA_real_
|
||
|
||
for (i in seq_len(nrow(subskalen))) {
|
||
key = subskalen$key[i]
|
||
werte_sub = items$wert[items$suffix == key]
|
||
n_fehlend = sum(is.na(werte_sub))
|
||
subskalen$n_fehlend[i] = n_fehlend
|
||
if (n_fehlend > 0) {
|
||
subskalen$meldung[i] = paste0(
|
||
"Subskala „", subskalen$label[i], "“ unvollständig (", n_fehlend, " von ",
|
||
subskalen$n_items[i], " Items fehlen) - kein Summenscore berechnet."
|
||
)
|
||
next
|
||
}
|
||
summe = sum(werte_sub)
|
||
subskalen$summe[i] = summe
|
||
klass = u_klassifiziere(summe, subskalen$cutoff[i], subskalen$richtung[i])
|
||
subskalen$klasse[i] = klass$klasse
|
||
subskalen$abs_abweichung[i] = klass$abs_abweichung
|
||
subskalen$rel_abweichung[i] = klass$rel_abweichung
|
||
}
|
||
|
||
list(
|
||
typ = "ok",
|
||
chiffre = chiffre,
|
||
datum_str = datum_str,
|
||
warnungen = warnungen,
|
||
items = items,
|
||
subskalen = subskalen
|
||
)
|
||
})
|
||
|
||
lapply(U_SUBSKALEN$key, function(key) {
|
||
local({
|
||
k = key
|
||
output_id = paste0("gauge_", k)
|
||
output[[output_id]] = renderPlot({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
req(identical(d$typ, "ok"))
|
||
sub = d$subskalen[d$subskalen$key == k, ]
|
||
make_gauge_u(sub$range_max, sub$cutoff, sub$richtung, sub$summe, sub$klasse)
|
||
}, bg = "transparent")
|
||
})
|
||
})
|
||
|
||
output$fehler_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
if (identical(d$typ, "ok")) return(NULL)
|
||
txt = switch(d$typ,
|
||
"leere_eingabe" = d$meldung,
|
||
"format_fehler" = paste0(
|
||
"Ungültige Chiffre '", d$chiffre, "'. Erwartet: ein Großbuchstabe + 6 Ziffern (z.B. P000123)."
|
||
),
|
||
d$meldung
|
||
)
|
||
div(class = "alert-fehler", txt)
|
||
})
|
||
|
||
output$warnung_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
if (!identical(d$typ, "ok") || length(d$warnungen) == 0) return(NULL)
|
||
div(lapply(d$warnungen, function(w) div(class = "alert-warnung", w)))
|
||
})
|
||
|
||
output$ergebnis_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
if (!identical(d$typ, "ok")) return(NULL)
|
||
|
||
subskalen_ui = lapply(seq_len(nrow(d$subskalen)), function(i) {
|
||
sub = d$subskalen[i, ]
|
||
|
||
score_block = if (is.na(sub$summe)) {
|
||
div(class = "alert-warnung", sub$meldung)
|
||
} else {
|
||
klasse_text = if (identical(sub$klasse, "signifikant"))
|
||
"auffällig nach hinterlegtem Grenzwert" else "unauffällig"
|
||
klasse_class = if (identical(sub$klasse, "signifikant"))
|
||
"subskala-klasse-signifikant" else "subskala-klasse-ok"
|
||
tagList(
|
||
div(class = "subskala-kopf",
|
||
span(class = "subskala-score", paste0(sub$summe, " / ", sub$range_max)),
|
||
span(class = klasse_class, klasse_text)
|
||
),
|
||
div(class = "subskala-abweichung",
|
||
paste0(
|
||
"Abweichung vom Cutoff (", sub$cutoff, "): ",
|
||
sprintf("%+.1f", sub$abs_abweichung), " (",
|
||
sprintf("%+.1f%%", sub$rel_abweichung * 100), ")"
|
||
)
|
||
)
|
||
)
|
||
}
|
||
|
||
hinweis_block = if (identical(sub$key, "fo")) {
|
||
div(class = "alert-warnung",
|
||
"Achtung: Bei dieser Subskala zeigt ein NIEDRIGER Wert die Auffälligkeit an ",
|
||
"(umgekehrte Richtung im Vergleich zu den anderen Subskalen)."
|
||
)
|
||
} else NULL
|
||
|
||
items_sub = d$items[d$items$suffix == sub$key, ]
|
||
item_zeilen = lapply(seq_len(nrow(items_sub)), function(j) {
|
||
it = items_sub[j, ]
|
||
badge_key = if (is.na(it$wert)) "na" else as.character(it$wert)
|
||
div(class = "item-zeile",
|
||
div(class = "item-nr", paste0(it$nr, ".")),
|
||
div(class = "item-text", it$text),
|
||
span(class = paste0("stufe-badge stufe-badge-", badge_key), it$wert_str)
|
||
)
|
||
})
|
||
|
||
div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", sub$label),
|
||
score_block,
|
||
hinweis_block,
|
||
plotOutput(paste0("gauge_", sub$key), height = "130px"),
|
||
tags$details(
|
||
tags$summary(class = "item-liste-titel", paste0("Einzelitems (", sub$n_items, ")")),
|
||
div(style = "margin-top: 6px;", item_zeilen)
|
||
)
|
||
)
|
||
})
|
||
|
||
tagList(
|
||
div(class = "abschnitt-karte",
|
||
div(class = "meta-block",
|
||
tags$strong("Chiffre: "), d$chiffre,
|
||
tags$span(" | ", style = "color:#ccc;"),
|
||
tags$strong("Ausfülldatum: "), d$datum_str
|
||
)
|
||
),
|
||
subskalen_ui
|
||
)
|
||
})
|
||
|
||
output$download_word = downloadHandler(
|
||
filename = function() {
|
||
d = tryCatch(ergebnis_r(), error = function(e) NULL)
|
||
chiffre_esc = if (is.list(d) && identical(d$typ, "ok"))
|
||
gsub("[^A-Za-z0-9_-]", "_", d$chiffre) else "export"
|
||
datum = if (is.list(d) && identical(d$typ, "ok") && !is.null(d$datum_str))
|
||
tryCatch(
|
||
format(as.Date(d$datum_str, "%d.%m.%Y"), "%Y%m%d"),
|
||
error = function(e) format(Sys.Date(), "%Y%m%d")
|
||
)
|
||
else
|
||
format(Sys.Date(), "%Y%m%d")
|
||
paste0("UFragebogen_", chiffre_esc, "_", datum, ".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_ufb_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)
|