699 lines
24 KiB
R
699 lines
24 KiB
R
# Präambel ####
|
||
|
||
library(shiny)
|
||
library(dplyr)
|
||
library(ggplot2)
|
||
library(haven)
|
||
library(officer)
|
||
library(DBI)
|
||
library(RSQLite)
|
||
|
||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_spwb.R" # liefert beim Sourcen: daten_spwb
|
||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert beim Sourcen: pseudo
|
||
AKZENT_FARBE = "#8B2635"
|
||
|
||
# 18 Item-Feldnamen in Reihenfolge, Suffix kodiert die Subskalenzugehoerigkeit.
|
||
SPWB_ITEMS = c(
|
||
"spwb_01_au", "spwb_02_au", "spwb_03_au",
|
||
"spwb_04_um", "spwb_05_um", "spwb_06_um",
|
||
"spwb_07_pw", "spwb_08_pw", "spwb_09_pw",
|
||
"spwb_10_pb", "spwb_11_pb", "spwb_12_pb",
|
||
"spwb_13_sl", "spwb_14_sl", "spwb_15_sl",
|
||
"spwb_16_sa", "spwb_17_sa", "spwb_18_sa"
|
||
)
|
||
|
||
# 8 von 18 Items sind invertiert kodiert (r = 7 - Rohwert vor Mittelwertbildung).
|
||
SPWB_INVERTIERT = c(
|
||
"spwb_01_au", "spwb_05_um", "spwb_09_pw", "spwb_10_pb",
|
||
"spwb_12_pb", "spwb_13_sl", "spwb_15_sl", "spwb_17_sa"
|
||
)
|
||
|
||
# Itemwortlaut exakt wie in spwb.xlsx, indiziert nach Item-Nr. 1-18.
|
||
SPWB_ITEMTEXTE = setNames(c(
|
||
"Ich lasse mich leicht beeinflussen von Leuten, die von ihrer Meinung fest überzeugt sind.",
|
||
"Ich bin von meiner Meinung überzeugt, auch wenn sie im Widerspruch steht zu dem, was die Allgemeinheit denkt.",
|
||
"Bei der Einschätzung meiner eigenen Person zählt nicht der Wertmaßstab anderer, sondern allein das, was in meinen Augen wichtig ist.",
|
||
"Im Großen und Ganzen habe ich das Gefühl, dass ich mein Leben recht gut im Griff habe.",
|
||
"Oft erdrückt mich der Alltag mit seinen Anforderungen.",
|
||
"Ich erledige meine vielen alltäglichen Aufgaben und Pflichten ganz gut.",
|
||
"Ich denke, es ist wichtig, immer wieder neue Erfahrungen zu machen, die in Frage stellen, wie man über sich und die Welt nachdenkt.",
|
||
"Für mich ist das Leben ein ständiger Lern- und Entwicklungsprozess.",
|
||
"Ich habe es schon lange aufgegeben, mein Leben wesentlich verändern oder verbessern zu wollen.",
|
||
"Es ist schwierig und anstrengend für mich, enge Beziehungen zu anderen aufrechtzuerhalten.",
|
||
"Man könnte mich wohl als einen großzügigen Menschen bezeichnen, der sich Zeit für andere nimmt.",
|
||
"Ich habe bisher nur wenige vertrauensvolle und enge Beziehungen erlebt.",
|
||
"Ich hake jeden Tag einzeln ab und mache mir über die Zukunft weiter keine Gedanken.",
|
||
"Manche Leute gehen plan- und ziellos durchs Leben, aber zu denen gehöre ich nicht.",
|
||
"Manchmal fühle ich mich, als ob ich schon alles getan hätte, was es im Leben zu tun gibt.",
|
||
"Eigentlich mag ich mich so, wie ich bin.",
|
||
"Irgendwie bin ich mit dem, was ich im Leben erreicht habe, nicht zufrieden.",
|
||
"Im Großen und Ganzen bin ich auf mich und mein Leben recht stolz."
|
||
), SPWB_ITEMS)
|
||
|
||
# Stichprobenmittelwerte aus der Validierungsstichprobe (Tibubos et al., 2025, N=3.374).
|
||
# Explizit KEINE Normwerte - das SPWB ist ein rein dimensionales Instrument ohne Cutoffs.
|
||
SPWB_REFERENZ_BESCHRIFTUNG = "Stichprobenmittelwert Tibubos et al. (2025), keine Norm"
|
||
SPWB_GESAMT_REFERENZ = 3.58
|
||
|
||
SPWB_SUBSKALEN = list(
|
||
list(key = "au", name = "Autonomie",
|
||
items = c("spwb_01_au", "spwb_02_au", "spwb_03_au"), referenz = 3.27),
|
||
list(key = "um", name = "Umweltbeherrschung",
|
||
items = c("spwb_04_um", "spwb_05_um", "spwb_06_um"), referenz = 3.82),
|
||
list(key = "pw", name = "Persönliches Wachstum",
|
||
items = c("spwb_07_pw", "spwb_08_pw", "spwb_09_pw"), referenz = 3.77),
|
||
list(key = "pb", name = "Positive Beziehungen zu anderen",
|
||
items = c("spwb_10_pb", "spwb_11_pb", "spwb_12_pb"), referenz = 3.36),
|
||
list(key = "sl", name = "Sinnhaftigkeit/Lebensziele",
|
||
items = c("spwb_13_sl", "spwb_14_sl", "spwb_15_sl"), referenz = 3.47),
|
||
list(key = "sa", name = "Selbstakzeptanz",
|
||
items = c("spwb_16_sa", "spwb_17_sa", "spwb_18_sa"), referenz = 3.80)
|
||
)
|
||
|
||
SPWB_DISCLAIMER = paste0(
|
||
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
|
||
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ",
|
||
"Das SPWB ist ein dimensionales Instrument ohne klinische Cutoffs; die angegebenen ",
|
||
"Vergleichswerte sind Stichprobenmittelwerte einer Validierungsstudie, keine Normwerte."
|
||
)
|
||
|
||
|
||
# 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)
|
||
|
||
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; }
|
||
.abschnitt-karte {
|
||
background: #fff;
|
||
padding: 16px 20px;
|
||
margin-bottom: 18px;
|
||
border: 1px solid #ddd;
|
||
border-radius: 6px;
|
||
}
|
||
.abschnitt-titel {
|
||
font-size: 1.15em;
|
||
font-weight: 700;
|
||
color: #8B2635;
|
||
border-bottom: 2px solid #8B2635;
|
||
padding-bottom: 8px;
|
||
margin-bottom: 14px;
|
||
}
|
||
.alert-fehler {
|
||
padding: 12px 16px;
|
||
margin-bottom: 14px;
|
||
background: #f8d7da;
|
||
border-left: 5px solid #C62828;
|
||
border-radius: 4px;
|
||
color: #58151c;
|
||
font-weight: 500;
|
||
}
|
||
.alert-warnung {
|
||
padding: 10px 16px;
|
||
margin-bottom: 12px;
|
||
background: #fff3cd;
|
||
border-left: 5px solid #E65100;
|
||
border-radius: 4px;
|
||
color: #6b5100;
|
||
font-size: 0.93em;
|
||
font-weight: 500;
|
||
}
|
||
.item-zeile {
|
||
display: flex;
|
||
align-items: center;
|
||
gap: 10px;
|
||
padding: 5px 0;
|
||
border-bottom: 1px solid #eee;
|
||
}
|
||
.item-nr {
|
||
font-weight: 600;
|
||
color: #8B2635;
|
||
min-width: 26px;
|
||
flex-shrink: 0;
|
||
}
|
||
.item-text {
|
||
flex: 1;
|
||
color: #333;
|
||
font-size: 0.92em;
|
||
}
|
||
.subskala-zeile {
|
||
margin-bottom: 22px;
|
||
}
|
||
.subskala-kopf {
|
||
display: flex;
|
||
align-items: baseline;
|
||
gap: 10px;
|
||
margin-bottom: 4px;
|
||
}
|
||
.subskala-name {
|
||
font-weight: 700;
|
||
color: #333;
|
||
min-width: 260px;
|
||
}
|
||
.wert-zahl {
|
||
font-size: 1.6rem;
|
||
font-weight: 800;
|
||
color: #8B2635;
|
||
}
|
||
.wert-zahl-gross {
|
||
font-size: 2.4rem;
|
||
font-weight: 800;
|
||
color: #8B2635;
|
||
}
|
||
.wert-label {
|
||
color: #666;
|
||
font-size: 0.85em;
|
||
}
|
||
.item-wert-badge {
|
||
min-width: 190px;
|
||
text-align: right;
|
||
white-space: nowrap;
|
||
font-size: 0.85em;
|
||
font-weight: 600;
|
||
color: #8B2635;
|
||
}
|
||
"
|
||
app_css = gsub("#8B2635", AKZENT_FARBE, app_css, fixed = TRUE)
|
||
|
||
|
||
# Helper ####
|
||
|
||
# Extrahiert den numerischen Itemwert defensiv, da das Exportformat von
|
||
# range_ticks 1,6,1 in dieser formr-Instanz nicht verifiziert ist: entweder
|
||
# ein dbl+lbl-Objekt mit labels-Attribut (analog mc_button/rating_button)
|
||
# oder ein direkter numerischer Rohwert 1-6.
|
||
spwb_extrahiere_wert = function(original_spalte, wert) {
|
||
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) {
|
||
return(list(wert = NA_real_, ok = TRUE))
|
||
}
|
||
roh = suppressWarnings(as.numeric(wert[1]))
|
||
lbl_attr = attr(original_spalte, "labels")
|
||
if (!is.null(lbl_attr) && length(lbl_attr) > 0) {
|
||
pos = which(as.vector(lbl_attr) == roh)
|
||
wert_num = if (length(pos) > 0) as.numeric(lbl_attr[pos[1]]) else roh
|
||
} else {
|
||
wert_num = roh
|
||
}
|
||
ok = !is.na(wert_num) && wert_num >= 1 && wert_num <= 6
|
||
list(wert = wert_num, ok = ok)
|
||
}
|
||
|
||
make_gauge_spwb = function(wert, referenz, achsentitel) {
|
||
p = ggplot() +
|
||
geom_rect(aes(xmin = 1, xmax = 6, ymin = 0, ymax = 1),
|
||
fill = "#F5F5F5", color = "#9E9E9E", linewidth = 0.6) +
|
||
geom_vline(xintercept = referenz, color = "#555555",
|
||
linetype = "dashed", linewidth = 0.9) +
|
||
annotate("text", x = referenz, y = -0.5, label = SPWB_REFERENZ_BESCHRIFTUNG,
|
||
color = "#555555", size = 2.5) +
|
||
scale_x_continuous(limits = c(1, 6), breaks = 1:6) +
|
||
scale_y_continuous(limits = c(-0.75, 1.5)) +
|
||
labs(x = achsentitel, y = NULL) +
|
||
theme_minimal(base_size = 11) +
|
||
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 = 15, b = 20, l = 15)
|
||
)
|
||
if (!is.na(wert)) {
|
||
p = p +
|
||
geom_segment(aes(x = wert, xend = wert, y = -0.15, yend = 1.15),
|
||
color = AKZENT_FARBE, linewidth = 2.5, lineend = "round") +
|
||
annotate("text", x = wert, y = 1.3, label = sprintf("%.2f", wert),
|
||
color = AKZENT_FARBE, fontface = "bold", size = 4)
|
||
}
|
||
p
|
||
}
|
||
|
||
|
||
# UI ####
|
||
|
||
ui = fluidPage(
|
||
tags$head(
|
||
tags$meta(charset = "UTF-8"),
|
||
tags$style(HTML(app_css))
|
||
),
|
||
|
||
div(class = "app-header",
|
||
tags$h2("SPWB – Scales of Psychological Well-Being (Kurzform)"),
|
||
tags$p("Staudinger, Lopez & Baltes (1997) | dt. Kurzform, validiert: Tibubos et al. (2025)")
|
||
),
|
||
|
||
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_spwb_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_warnung = fp_text(font.size = 10, color = "#B8860B")
|
||
fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
|
||
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext("SPWB - Scales of Psychological Well-Being - Einzelauswertung", 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)
|
||
))
|
||
if (!is.null(erg$mehrfach_hinweis)) {
|
||
doc = body_add_fpar(doc, fpar(ftext(erg$mehrfach_hinweis, fp_warnung)))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Gesamtwert und Subskalen (Skala 1-6)", fp_abschnitt)))
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext("Gesamtwert: ", fp_label),
|
||
ftext(sprintf("%.2f", erg$gesamtwert), fp_normal),
|
||
ftext(sprintf(" (Stichprobenmittelwert: %.2f, keine Norm)", SPWB_GESAMT_REFERENZ),
|
||
fp_text(font.size = 9, italic = TRUE, color = "#777777"))
|
||
))
|
||
for (sk in erg$subskalen_werte) {
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext(paste0(sk$name, ": "), fp_label),
|
||
ftext(sprintf("%.2f", sk$mittelwert), fp_normal),
|
||
ftext(sprintf(" (Stichprobenmittelwert: %.2f, keine Norm)", sk$referenz),
|
||
fp_text(font.size = 9, italic = TRUE, color = "#777777"))
|
||
))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
if (length(erg$warnungen) > 0) {
|
||
doc = body_add_fpar(doc, fpar(ftext("Hinweise", fp_abschnitt)))
|
||
for (w in erg$warnungen) {
|
||
doc = body_add_fpar(doc, fpar(ftext(w, fp_warnung)))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
}
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Einzelitems", fp_abschnitt)))
|
||
for (i in seq_along(SPWB_ITEMS)) {
|
||
feldname = SPWB_ITEMS[i]
|
||
roh_text = if (is.na(erg$item_rohwerte[i])) "k. A." else sprintf("%.0f", erg$item_rohwerte[i])
|
||
umgep_text = if (is.na(erg$item_umgepolt[i])) "k. A." else sprintf("%.0f", erg$item_umgepolt[i])
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext(paste0(i, ". ", SPWB_ITEMTEXTE[[feldname]], " "), fp_normal),
|
||
ftext(sprintf(" Antwort: %s | nach Umpolung: %s ", roh_text, umgep_text),
|
||
fp_text(font.size = 10, bold = TRUE, color = AKZENT_FARBE))
|
||
))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext(SPWB_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)))
|
||
}
|
||
})
|
||
|
||
ergebnis_r = eventReactive(input$btn_suchen, {
|
||
|
||
chiffre = toupper(trimws(input$chiffre))
|
||
|
||
if (nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0) {
|
||
return(list(ok = FALSE, meldung = "Bitte Chiffre oder Pseudonym eingeben."))
|
||
}
|
||
if (nchar(trimws(input$pseudonym)) == 0 && !grepl("^[A-Z][0-9]{6}$", chiffre)) {
|
||
return(list(ok = FALSE, meldung = sprintf(
|
||
"Chiffre '%s' hat kein gültiges Format (erwartet: ein Großbuchstabe + 6 Ziffern, z.B. P000123).",
|
||
chiffre
|
||
)))
|
||
}
|
||
|
||
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
|
||
return(list(ok = FALSE, meldung = sprintf("Download-Skript nicht gefunden:\n%s", PFAD_DOWNLOAD_SKRIPT)))
|
||
}
|
||
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
|
||
return(list(ok = FALSE, meldung = sprintf("Pseudonym-Skript nicht gefunden:\n%s", 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(ok = FALSE, meldung = paste0("Fehler im Download-Skript: ", 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
|
||
})
|
||
|
||
alter_wd = getwd()
|
||
wd_ziel = if (!is.null(db_ordner)) db_ordner else dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE))
|
||
setwd(wd_ziel)
|
||
on.exit(setwd(alter_wd), add = TRUE)
|
||
|
||
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(ok = FALSE, meldung = paste0("Fehler im Pseudonym-Skript: ", ok_ps$msg)))
|
||
}
|
||
|
||
if (!exists("daten_spwb", envir = .GlobalEnv)) {
|
||
return(list(ok = FALSE, meldung = "Objekt 'daten_spwb' nach dem Sourcen nicht gefunden. Bitte Download-Skript prüfen."))
|
||
}
|
||
if (!exists("pseudo", envir = .GlobalEnv)) {
|
||
return(list(ok = FALSE, meldung = "Objekt 'pseudo' nach dem Sourcen nicht gefunden. Bitte Pseudonym-Skript prüfen."))
|
||
}
|
||
|
||
daten_spwb = get("daten_spwb", envir = .GlobalEnv)
|
||
pseudo = get("pseudo", envir = .GlobalEnv)
|
||
|
||
# Spaltennamen fuer Session-ID und Zeitstempel sind gegen den echten
|
||
# daten_spwb-Header nicht verifizierbar (externes Download-Skript liegt
|
||
# nicht vor) - Annahme 'session'/'created' analog zu den Schwester-Apps
|
||
# (pg13r, flz), defensiv geprueft statt blind vorausgesetzt.
|
||
if (!("session" %in% colnames(daten_spwb))) {
|
||
return(list(ok = FALSE, meldung = "Spalte 'session' wurde in daten_spwb nicht gefunden. Spaltenname im Download-Skript prüfen."))
|
||
}
|
||
if (!("created" %in% colnames(daten_spwb))) {
|
||
return(list(ok = FALSE, meldung = "Spalte 'created' wurde in daten_spwb nicht gefunden. Spaltenname im Download-Skript prüfen."))
|
||
}
|
||
|
||
treffer_ps = pseudo[pseudo$chiffre == chiffre, ]
|
||
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[pseudo$chiffre == chiffre, ]
|
||
}
|
||
|
||
if (nrow(treffer_ps) == 0) {
|
||
return(list(ok = FALSE, meldung = sprintf(
|
||
"Chiffre '%s' wurde in der Pseudonym-Datenbank nicht gefunden.", chiffre
|
||
)))
|
||
}
|
||
|
||
alle_session_ids = unique(treffer_ps$pseudonym)
|
||
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
|
||
|
||
treffer_dat = daten_spwb[daten_spwb$session %in% alle_session_ids, ]
|
||
if (nrow(treffer_dat) == 0) {
|
||
return(list(ok = FALSE, meldung = sprintf(
|
||
"Kein SPWB-Datensatz für Chiffre '%s' gefunden. (%d Pseudonym(e) geprüft)",
|
||
chiffre, length(alle_session_ids)
|
||
)))
|
||
}
|
||
|
||
mehrfach_hinweis = NULL
|
||
if (nrow(treffer_dat) > 1) {
|
||
n = nrow(treffer_dat)
|
||
treffer_dat = treffer_dat[order(treffer_dat$created, decreasing = TRUE), ]
|
||
datum_neu = tryCatch(
|
||
format(as.POSIXct(treffer_dat$created[1]), "%d.%m.%Y %H:%M"),
|
||
error = function(e) "unbekanntes Datum"
|
||
)
|
||
mehrfach_hinweis = sprintf(
|
||
"Mehrere Ausfüllungen gefunden (%d Einträge). Angezeigt wird die neueste vom %s.",
|
||
n, datum_neu
|
||
)
|
||
treffer_dat = treffer_dat[1, , drop = FALSE]
|
||
}
|
||
|
||
zeile = treffer_dat[1, , drop = FALSE]
|
||
datum_str = tryCatch(
|
||
format(as.POSIXct(zeile[["created"]][1]), "%d.%m.%Y"),
|
||
error = function(e) format(Sys.Date(), "%d.%m.%Y")
|
||
)
|
||
|
||
warnungen = c()
|
||
if (!is.null(mehrfach_hinweis)) warnungen = c(warnungen, mehrfach_hinweis)
|
||
|
||
item_rohwerte = rep(NA_real_, length(SPWB_ITEMS))
|
||
for (i in seq_along(SPWB_ITEMS)) {
|
||
feldname = SPWB_ITEMS[i]
|
||
if (!(feldname %in% colnames(daten_spwb))) {
|
||
warnungen = c(warnungen, sprintf("Item-Spalte '%s' nicht in daten_spwb gefunden.", feldname))
|
||
next
|
||
}
|
||
ext = spwb_extrahiere_wert(daten_spwb[[feldname]], zeile[[feldname]])
|
||
item_rohwerte[i] = ext$wert
|
||
if (!is.na(ext$wert) && !ext$ok) {
|
||
warnungen = c(warnungen, sprintf(
|
||
"Item %d (%s): Wert %.2f liegt außerhalb des gültigen Bereichs 1-6 - Datenfehler, wird unverändert weiterverarbeitet.",
|
||
i, feldname, ext$wert
|
||
))
|
||
}
|
||
}
|
||
|
||
n_fehlend = sum(is.na(item_rohwerte))
|
||
if (n_fehlend > 0) {
|
||
warnungen = c(warnungen, sprintf(
|
||
"%d von 18 Items wurden nicht beantwortet - Mittelwerte werden ohne diese Items berechnet.",
|
||
n_fehlend
|
||
))
|
||
}
|
||
|
||
item_umgepolt = ifelse(SPWB_ITEMS %in% SPWB_INVERTIERT, 7 - item_rohwerte, item_rohwerte)
|
||
|
||
subskalen_werte = lapply(SPWB_SUBSKALEN, function(sk) {
|
||
idx = match(sk$items, SPWB_ITEMS)
|
||
werte = item_umgepolt[idx]
|
||
list(
|
||
key = sk$key,
|
||
name = sk$name,
|
||
referenz = sk$referenz,
|
||
mittelwert = mean(werte, na.rm = TRUE)
|
||
)
|
||
})
|
||
|
||
gesamtwert = mean(item_umgepolt, na.rm = TRUE)
|
||
|
||
list(
|
||
ok = TRUE,
|
||
chiffre = chiffre,
|
||
datum_str = datum_str,
|
||
mehrfach_hinweis = mehrfach_hinweis,
|
||
item_texte = SPWB_ITEMTEXTE,
|
||
item_rohwerte = item_rohwerte,
|
||
item_umgepolt = item_umgepolt,
|
||
subskalen_werte = subskalen_werte,
|
||
gesamtwert = gesamtwert,
|
||
warnungen = warnungen,
|
||
meldung = NULL
|
||
)
|
||
})
|
||
|
||
output$fehler_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
erg = ergebnis_r()
|
||
if (!isTRUE(erg$ok)) div(class = "alert-fehler", erg$meldung)
|
||
})
|
||
|
||
output$warnung_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
erg = ergebnis_r()
|
||
if (!isTRUE(erg$ok) || length(erg$warnungen) == 0) return(NULL)
|
||
div(lapply(erg$warnungen, function(w) div(class = "alert-warnung", w)))
|
||
})
|
||
|
||
observe({
|
||
req(input$btn_suchen)
|
||
erg = ergebnis_r()
|
||
req(isTRUE(erg$ok))
|
||
|
||
output$gauge_gesamt = renderPlot({
|
||
make_gauge_spwb(erg$gesamtwert, SPWB_GESAMT_REFERENZ, "Gesamtwert (1-6)")
|
||
}, bg = "transparent")
|
||
|
||
lapply(erg$subskalen_werte, function(sk) {
|
||
local({
|
||
sk_lok = sk
|
||
output_id = paste0("gauge_", sk_lok$key)
|
||
output[[output_id]] = renderPlot({
|
||
make_gauge_spwb(sk_lok$mittelwert, sk_lok$referenz, paste0(sk_lok$name, " (1-6)"))
|
||
}, bg = "transparent")
|
||
})
|
||
})
|
||
})
|
||
|
||
output$ergebnis_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
erg = ergebnis_r()
|
||
if (!isTRUE(erg$ok)) return(NULL)
|
||
|
||
subskalen_ui = lapply(erg$subskalen_werte, function(sk) {
|
||
div(class = "subskala-zeile",
|
||
div(class = "subskala-kopf",
|
||
div(class = "subskala-name", sk$name),
|
||
div(class = "wert-zahl", sprintf("%.2f", sk$mittelwert)),
|
||
div(class = "wert-label", "(Skala 1-6)")
|
||
),
|
||
plotOutput(paste0("gauge_", sk$key), height = "100px")
|
||
)
|
||
})
|
||
|
||
items_ui = lapply(seq_along(SPWB_ITEMS), function(i) {
|
||
feldname = SPWB_ITEMS[i]
|
||
roh = erg$item_rohwerte[i]
|
||
umgep = erg$item_umgepolt[i]
|
||
roh_text = if (is.na(roh)) "k. A." else sprintf("%.0f", roh)
|
||
umgep_text = if (is.na(umgep)) "k. A." else sprintf("%.0f", umgep)
|
||
div(class = "item-zeile",
|
||
div(class = "item-nr", paste0(i, ".")),
|
||
div(class = "item-text", erg$item_texte[[feldname]]),
|
||
div(class = "item-wert-badge",
|
||
sprintf("Antwort: %s | nach Umpolung: %s", roh_text, umgep_text))
|
||
)
|
||
})
|
||
|
||
div(
|
||
div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "SPWB – Ergebnisübersicht"),
|
||
div(style = "margin-bottom: 6px;",
|
||
tags$strong("Chiffre: "), erg$chiffre,
|
||
tags$span(style = "color: #ccc; margin: 0 8px;", "|"),
|
||
tags$strong("Ausfülldatum: "), erg$datum_str
|
||
)
|
||
),
|
||
div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Gesamtwert"),
|
||
div(class = "subskala-kopf",
|
||
div(class = "wert-zahl-gross", sprintf("%.2f", erg$gesamtwert)),
|
||
div(class = "wert-label", "(Skala 1-6, Mittelwert aller 18 umgepolten Items)")
|
||
),
|
||
plotOutput("gauge_gesamt", height = "110px")
|
||
),
|
||
div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Subskalen"),
|
||
subskalen_ui
|
||
),
|
||
div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Einzelitems"),
|
||
div(items_ui)
|
||
),
|
||
div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Hinweis zur Interpretation"),
|
||
p(style = "font-size: 0.85em; color: #555; line-height: 1.5;", SPWB_DISCLAIMER)
|
||
)
|
||
)
|
||
})
|
||
|
||
output$download_word = downloadHandler(
|
||
filename = function() {
|
||
erg = tryCatch(ergebnis_r(), error = function(e) NULL)
|
||
if (is.null(erg) || !isTRUE(erg$ok)) return("SPWB_Auswertung.docx")
|
||
chiffre_esc = gsub("[^A-Za-z0-9]", "", erg$chiffre)
|
||
datum_fn = tryCatch(
|
||
format(as.Date(erg$datum_str, "%d.%m.%Y"), "%Y%m%d"),
|
||
error = function(e) format(Sys.Date(), "%Y%m%d")
|
||
)
|
||
paste0("SPWB_", chiffre_esc, "_", datum_fn, ".docx")
|
||
},
|
||
content = function(file) {
|
||
erg = tryCatch(ergebnis_r(), error = function(e) NULL)
|
||
if (is.null(erg) || !isTRUE(erg$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_spwb_docx(erg),
|
||
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 = ui, server = server)
|