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

840
EQ/app.R Normal file
View file

@ -0,0 +1,840 @@
# Präambel ####
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_eq60.R" # liefert: daten_eq60
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo
AKZENT_FARBE = "#8B2635"
library(shiny)
library(dplyr)
library(ggplot2)
library(officer)
# DBI und RSQLite werden nicht hier geladen: sie werden ausschliesslich vom
# gesourcten ../get_pseudo.R gebraucht und landen ueber
# renv::snapshot(type = "all") in der renv.lock (siehe setup_renv.R).
# Empathy Quotient (Baron-Cohen & Wheelwright 2004) — Scoring
eq_z_items = c(1,6,19,22,25,26,35,36,37,38,41,42,43,44,52,54,55,57,58,59,60) # Zustimmung empathisch, 21 Items
eq_a_items = c(4,8,10,11,12,14,15,18,21,27,28,29,32,34,39,46,48,49,50) # Ablehnung empathisch, 19 Items
eq_filler = c(2,3,5,7,9,13,16,17,20,23,24,30,31,33,40,45,47,51,53,56) # nicht gewertet, 20 Items
eq_referenz = list(
frauen_allgemein = c(m = 47.2, sd = 10.2),
maenner_allgemein = c(m = 41.8, sd = 11.2),
kontrollen = c(m = 42.1, sd = 10.6),
as_hfa = c(m = 20.4, sd = 11.6)
)
eq_cutoff_ashfa = 30 # <= 30: "AS/HFA-Bereich"
eq_cutoff_super = 62 # >= 62: "super-empathisch"
# Die vier Antwortstufen in fester Reihenfolge (absteigend kodiert:
# 1 = volle Zustimmung ... 4 = volle Ablehnung).
EQ_ANTWORT_TEXTE = c(
"stimme voll und ganz zu",
"stimme eher zu",
"stimme eher nicht zu",
"stimme überhaupt nicht zu"
)
# Farben der drei Klassifikationszonen — bewusst KEINE Ampel-Logik,
# da ein Wert <= 30 keine Pathologie, sondern statistische Seltenheit bedeutet.
ZONE_FARBE_ASHFA = "#C77A30"
ZONE_FARBE_MITTEL = "#6C7A89"
ZONE_FARBE_SUPER = "#2E7D8A"
ZONE_BG_ASHFA = "#FBEEE0"
ZONE_BG_MITTEL = "#EEF1F3"
ZONE_BG_SUPER = "#E3F0F2"
# Word-Export-Disclaimer (ASCII-Wortlaut aus Abschnitt 8)
EQ_DISCLAIMER = paste0(
"Der EQ ist kein diagnostisches Instrument. Von einem Screening in der ",
"Allgemeinbevoelkerung wird von den Autoren ausdruecklich abgeraten. Die ",
"genannten Prozent- und Mittelwertangaben stammen aus der englischsprachigen ",
"Originalstudie, nicht aus einer deutschen Normierung."
)
# Anzeige-Disclaimer, dauerhaft sichtbar (Wortlaut aus Abschnitt 6.5)
EQ_DISCLAIMER_ANZEIGE = paste0(
"Der EQ ist kein diagnostisches Instrument. Von einem Screening in der ",
"Allgemeinbevölkerung wird von den Autoren ausdrücklich abgeraten. Die ",
"genannten Prozent- und Mittelwertangaben stammen aus der englischsprachigen ",
"Originalstudie, nicht aus einer deutschen Normierung."
)
# 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 ####
item_art = function(nr) {
if (nr %in% eq_filler) return("filler")
if (nr %in% eq_z_items) return("z")
"a"
}
# Rohwert eines Items -> Choice-Index 1..4 oder NA (Unsicherheit A, Abschnitt 3).
# Deckt drei Faelle ab: haven_labelled (numerischer Code + labels-Attribut),
# reiner Index (numerisch oder "1".."4") und Antworttext.
interpret_choice = function(roh, original_col = NULL) {
if (length(roh) == 0 || all(is.na(roh))) return(NA_integer_)
labels_attr = if (!is.null(original_col)) attr(original_col, "labels") else attr(roh, "labels")
if (!is.null(labels_attr) && length(labels_attr) > 0) {
val = suppressWarnings(as.numeric(unclass(roh))[1])
if (!is.na(val)) {
nm = names(labels_attr)[match(val, as.numeric(labels_attr))]
if (!is.na(nm)) {
m = match(trimws(nm), EQ_ANTWORT_TEXTE)
if (!is.na(m)) return(as.integer(m))
}
pos = match(val, sort(as.numeric(labels_attr)))
if (!is.na(pos) && pos %in% 1:4) return(as.integer(pos))
if (val %in% 1:4) return(as.integer(val))
}
return(NA_integer_)
}
s = trimws(as.character(roh))
if (!nzchar(s) || tolower(s) %in% c("na", "null")) return(NA_integer_)
if (grepl("^[1-4]$", s)) return(as.integer(s))
if (grepl("^[1-4]\\.0+$", s)) return(as.integer(round(as.numeric(s))))
m = match(s, EQ_ANTWORT_TEXTE)
if (!is.na(m)) return(as.integer(m))
NA_integer_
}
# Rohwert geschlecht -> "weiblich" / "männlich" oder NA (Abschnitt 3).
# 1 = weiblich, 2 = männlich (xlsx-Reihenfolge choice1/choice2).
interpret_geschlecht = function(roh, original_col = NULL) {
if (length(roh) == 0 || all(is.na(roh))) return(NA_character_)
kandidat = trimws(as.character(roh))
labels_attr = if (!is.null(original_col)) attr(original_col, "labels") else attr(roh, "labels")
if (!is.null(labels_attr) && length(labels_attr) > 0) {
val = suppressWarnings(as.numeric(unclass(roh))[1])
if (!is.na(val)) {
nm = names(labels_attr)[match(val, as.numeric(labels_attr))]
if (!is.na(nm)) kandidat = trimws(nm) else kandidat = as.character(val)
}
}
s = tolower(kandidat)
if (s %in% c("1", "weiblich", "w", "f", "female")) return("weiblich")
if (s %in% c("2", "männlich", "maennlich", "m", "male")) return("männlich")
NA_character_
}
# Punktevergabe je Item (Abschnitt 5). idx = Choice-Index 1..4.
# Z-Item: 1 -> 2, 2 -> 1, 3/4 -> 0. A-Item: 4 -> 2, 3 -> 1, 1/2 -> 0. Filler -> NA.
item_punkte = function(nr, idx) {
if (is.na(idx)) return(NA_integer_)
if (nr %in% eq_z_items) return(c(2L, 1L, 0L, 0L)[idx])
if (nr %in% eq_a_items) return(c(0L, 0L, 1L, 2L)[idx])
NA_integer_
}
# Klassifikation (Abschnitt 5 / 6.3)
klassifiziere = function(score) {
if (score <= eq_cutoff_ashfa) {
return(list(
zone = "AS/HFA-Bereich",
farbe = ZONE_FARBE_ASHFA,
bg = ZONE_BG_ASHFA,
text = paste0(
"Der Gesamtwert liegt in dem Bereich (≤ 30), der in der Originalstudie von ",
"Baron-Cohen & Wheelwright (2004) im Mittel bei Personen mit Autismus-Spektrum-Störung / ",
"High-Functioning-Autismus beobachtet wurde (Gruppenmittelwert 20,4). Ein niedriger EQ-Wert ",
"ist für sich genommen keine Diagnose, sondern zunächst nur statistisch selten. Die ",
"Originalautoren empfehlen ausdrücklich den kombinierten Einsatz mit dem AQ ",
"(Autism Spectrum Quotient) sowie eine klinische Einordnung."
)
))
}
if (score >= eq_cutoff_super) {
return(list(
zone = "super-empathischer Bereich",
farbe = ZONE_FARBE_SUPER,
bg = ZONE_BG_SUPER,
text = paste0(
"Der Gesamtwert liegt im oberen Randbereich (≥ 62), der in der Originalstudie als ",
"„super-empathisch“ bezeichnet wird. Auch dies ist keine klinische Kategorie, ",
"sondern eine statistische Beschreibung eines seltenen, sehr hohen Wertes."
)
))
}
list(
zone = "Bereich der Allgemeinbevölkerung / unauffällig",
farbe = ZONE_FARBE_MITTEL,
bg = ZONE_BG_MITTEL,
text = paste0(
"Der Gesamtwert liegt im Bereich der Allgemeinbevölkerung (31–61) und ist damit ",
"unauffällig. Die geschlechtsspezifischen Mittelwerte der Originalstudie liegen bei ",
"47,2 (Frauen) bzw. 41,8 (Männer)."
)
)
}
# Entfernt formr-Artefakte (fuehrende Nummerierung "1\. ", Markdown-Escapes,
# Zeilenumbrueche, Fett-Markdown) aus dem Itemwortlaut (Abschnitt 6.6).
bereinige_itemtext = function(label) {
if (is.null(label) || length(label) == 0 || is.na(label[1]) || !nzchar(trimws(label[1]))) {
return(NA_character_)
}
roh = as.character(label[1])
roh = gsub("[\r\n]+", " ", roh)
roh = gsub("\\*\\*", "", roh)
roh = trimws(roh)
roh = sub("^\\s*\\d+\\s*\\\\?\\.\\s*", "", roh) # "1\. " oder "1. "
roh = sub("^\\s*\\d+\\s*[.)]\\s*", "", roh) # "1) "
roh = gsub("\\\\", "", roh)
roh = gsub("[[:space:]]+", " ", roh)
trimws(roh)
}
# label-Attribut (Itemwortlaut) einer Spalte aus daten_eq60
hole_label = function(df, sp) {
if (!sp %in% names(df)) return(NA_character_)
lb = attr(df[[sp]], "label")
if (is.null(lb) || length(lb) == 0) return(NA_character_)
as.character(lb)[1]
}
# Datums-Vektor eines Dataframes fuer die Sortierung (Unsicherheit B, Abschnitt 4):
# Praeferenz created > modified > ended > expired.
parse_zeit = function(x) {
roh = trimws(as.character(x))
roh[!nzchar(roh) | tolower(roh) %in% c("na", "null")] = NA
out = suppressWarnings(tryCatch(as.POSIXct(roh, tz = "UTC"),
error = function(e) as.POSIXct(rep(NA_character_, length(roh)), tz = "UTC")))
if (all(is.na(out)) && any(!is.na(roh))) {
out = suppressWarnings(as.POSIXct(strptime(roh, "%Y-%m-%d", tz = "UTC")))
}
out
}
hole_datum_vec = function(df) {
for (ds in c("created", "modified", "ended", "expired")) {
if (!ds %in% names(df)) next
v = parse_zeit(df[[ds]])
if (any(!is.na(v))) return(v)
}
NULL
}
# Einzeldatum aus einer Zeile + Quellspalte. Kein Sys.Date()-Fallback (Abschnitt 4).
hole_datum_einzeln = function(row1) {
for (ds in c("created", "modified", "ended", "expired")) {
if (!ds %in% names(row1)) next
kand = parse_zeit(row1[[ds]][1])
if (length(kand) == 1 && !is.na(kand)) return(list(datum = as.Date(kand), quelle = ds))
}
list(datum = as.Date(NA), quelle = NA_character_)
}
komma1 = function(x) format(round(as.numeric(x), 1), decimal.mark = ",", nsmall = 1, trim = TRUE)
# Referenzwert-Zeilen als Text (Abschnitt 6.4)
referenz_zeilen = function(geschlecht) {
z = character(0)
if (!is.null(geschlecht) && !is.na(geschlecht)) {
ref = if (geschlecht == "weiblich") eq_referenz$frauen_allgemein else eq_referenz$maenner_allgemein
lbl = if (geschlecht == "weiblich") "Frauen" else "Männer"
z = c(z, sprintf("Allgemeinbevölkerung, %s (Originalstudie): M = %s, SD = %s",
lbl, komma1(ref[["m"]]), komma1(ref[["sd"]])))
} else {
z = c(z, "Geschlecht nicht eindeutig, geschlechtsspezifischer Vergleichswert entfällt.")
}
z = c(z, sprintf("Kontrollgruppe (Originalstudie): M = %s, SD = %s",
komma1(eq_referenz$kontrollen[["m"]]), komma1(eq_referenz$kontrollen[["sd"]])))
z = c(z, sprintf("AS/HFA-Gruppe (Originalstudie): M = %s, SD = %s",
komma1(eq_referenz$as_hfa[["m"]]), komma1(eq_referenz$as_hfa[["sd"]])))
z
}
# Horizontaler Gauge-Balken 0-80 mit farbigen Zonen und Wertmarker (Abschnitt 6, Punkt 2)
mach_gauge = function(score) {
zonen = data.frame(
xmin = c(0, 30.5, 61.5),
xmax = c(30.5, 61.5, 80),
farbe = c(ZONE_FARBE_ASHFA, ZONE_FARBE_MITTEL, ZONE_FARBE_SUPER),
lab = c("AS/HFA-Bereich\n(≤ 30)",
"Allgemeinbevölkerung\n(31–61)",
"super-empathisch\n(≥ 62)"),
stringsAsFactors = FALSE
)
ggplot(zonen) +
geom_rect(aes(xmin = xmin, xmax = xmax, ymin = 0, ymax = 1), fill = zonen$farbe, color = NA) +
geom_text(aes(x = (xmin + xmax) / 2, y = 0.5, label = lab),
color = "white", size = 3.0, lineheight = 0.95) +
annotate("segment", x = score, xend = score, y = -0.18, yend = 1.2,
color = "#1A1A1A", linewidth = 1.6) +
annotate("point", x = score, y = 1.2, size = 3, color = "#1A1A1A") +
annotate("text", x = min(max(score, 6), 74), y = 1.55,
label = paste0("EQ = ", score),
hjust = if (score > 74) 1 else if (score < 6) 0 else 0.5,
fontface = "bold", size = 4.4, color = "#1A1A1A") +
scale_x_continuous(limits = c(0, 80), breaks = seq(0, 80, by = 10), expand = c(0.02, 0)) +
scale_y_continuous(limits = c(-0.4, 1.9), expand = c(0, 0)) +
labs(x = "EQ-Gesamtscore (0–80)", y = NULL) +
theme_minimal(base_size = 12) +
theme(
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
panel.grid = element_blank(),
axis.title.y = element_blank(),
axis.text.x = element_text(size = 9, color = "#444444"),
plot.margin = margin(t = 4, r = 12, b = 4, l = 12)
)
}
# UI ####
app_css = "
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; color: #222; }
.container-fluid { max-width: 1080px; }
.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: #fff; 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: #fff !important; border: none !important;
border-radius: 4px !important; padding: 8px 20px !important; font-weight: 600 !important;
}
.btn-laden:hover { background: #6d1e29 !important; color: #fff !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-weight: 500;
}
.abschnitt-karte {
background: #fff; 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;
}
.disclaimer { font-size: 0.9em; color: #555; line-height: 1.6; }
.item-zeile {
display: flex; align-items: baseline; gap: 12px; padding: 7px 0;
border-bottom: 1px solid #F0F0F0;
}
.item-zeile:last-child { border-bottom: none; }
.item-nr {
font-weight: 700; color: #8B2635; min-width: 34px; flex-shrink: 0;
text-align: right; font-variant-numeric: tabular-nums;
}
.item-text { flex: 1; color: #333; font-size: 0.92em; }
.item-antwort {
flex: 0 0 190px; color: #444; font-style: italic; font-size: 0.85em;
text-align: right;
}
.stufe-badge-0, .stufe-badge-1, .stufe-badge-2, .filler-badge {
flex-shrink: 0; border-radius: 4px; padding: 2px 9px; font-size: 0.78em;
font-weight: 700; white-space: nowrap; display: inline-block; text-align: center;
min-width: 74px;
}
.stufe-badge-0 { background: #ECEFF1; color: #47525c; }
.stufe-badge-1 { background: #DCEBD4; color: #3c6b2c; }
.stufe-badge-2 { background: #C3E2CA; color: #226b39; }
.filler-badge { background: #F0ECE8; color: #8a8079; font-weight: 600; font-style: italic; min-width: 150px; }
"
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("EQ-60 – Empathy Quotient (Cambridge Behaviour Scale)"),
tags$p("Baron-Cohen & Wheelwright 2004 | dt. Uebersetzung J. de Haen | lokale Auswertung")
),
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_eq60_docx = function(erg) {
doc = read_docx()
fp_titel = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18)
fp_meta = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 11)
fp_label = fp_text(bold = TRUE, font.size = 11)
fp_norm = fp_text(font.size = 11)
fp_klein = fp_text(color = "#777777", font.size = 9, italic = TRUE)
fp_zone = fp_text(color = erg$klass$farbe, bold = TRUE, font.size = 14)
doc = body_add_fpar(doc, fpar(ftext("EQ-60 – Empathy Quotient / Auswertung", fp_titel)))
doc = body_add_fpar(doc, fpar(ftext("Chiffre: ", fp_label), ftext(as.character(erg$chiffre), fp_meta)))
datum_txt = if (erg$datum_fehlt) {
"Ausfülldatum: nicht gefunden (undatiert)"
} else {
paste0("Ausfülldatum: ", format(erg$datum, "%d.%m.%Y"))
}
doc = body_add_fpar(doc, fpar(ftext(datum_txt, fp_norm)))
doc = body_add_fpar(doc, fpar(ftext(
paste0("Bericht erstellt am ", format(Sys.time(), "%d.%m.%Y %H:%M")), fp_klein)))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(paste0("EQ-Gesamtscore: ", erg$score, " von 80"),
fp_text(bold = TRUE, font.size = 13))))
doc = body_add_fpar(doc, fpar(ftext(paste0("Einordnung: ", erg$klass$zone), fp_zone)))
doc = body_add_par(doc, erg$klass$text, style = "Normal")
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Referenzwerte (Originalstudie)",
fp_text(bold = TRUE, font.size = 12))))
for (z in referenz_zeilen(erg$geschlecht)) doc = body_add_par(doc, z, style = "Normal")
if (is.na(erg$geschlecht)) {
doc = body_add_par(doc, paste0(
"Hinweis: Das Geschlecht war im Datensatz nicht eindeutig interpretierbar; der ",
"geschlechtsspezifische Vergleichswert entfällt. Der Gesamtscore ist davon nicht betroffen."),
style = "Normal")
}
if (erg$datum_fehlt) {
doc = body_add_par(doc, paste0(
"Hinweis: In den Daten wurde keine verwertbare Datumsspalte (created/modified/ended/expired) ",
"gefunden. Der Dateiname trägt den Zusatz „undatiert“."), style = "Normal")
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Einzelitems (1–60)", fp_text(bold = TRUE, font.size = 12))))
badge_shade = c("0" = "#ECEFF1", "1" = "#DCEBD4", "2" = "#C3E2CA")
for (i in seq_len(nrow(erg$items))) {
it = erg$items[i, ]
antwort = if (!is.na(it$antwort)) it$antwort else paste0("unklar (roh: \"", it$roh, "\")")
if (it$art == "filler") {
badge_txt = " [Filler — nicht gewertet]"
fp_badge = fp_text(italic = TRUE, color = "#8a8079", font.size = 9)
} else {
badge_txt = paste0(" [", it$punkte, if (it$punkte == 1) " Punkt]" else " Punkte]")
fp_badge = fp_text(bold = TRUE, font.size = 9,
shading.color = badge_shade[[as.character(it$punkte)]])
}
itemtext = if (is.na(it$text)) paste0("Item ", it$nr, " (Wortlaut nicht im Datensatz)") else it$text
doc = body_add_fpar(doc, fpar(
ftext(sprintf("%2d. ", it$nr), fp_text(bold = TRUE, color = AKZENT_FARBE, font.size = 10)),
ftext(paste0(itemtext, " — "), fp_text(font.size = 10)),
ftext(antwort, fp_text(italic = TRUE, font.size = 10)),
ftext(badge_txt, fp_badge)
))
}
doc = body_add_par(doc, "", style = "Normal")
# Disclaimer als letzter Absatz
doc = body_add_fpar(doc, fpar(ftext(EQ_DISCLAIMER,
fp_text(italic = TRUE, font.size = 9, color = "#555555"))))
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 = eventReactive(input$btn_suchen, {
chiffre = toupper(trimws(input$chiffre))
pseudonym_in = trimws(input$pseudonym)
# 1. Leere Eingabe / Formatpruefung
if (nchar(pseudonym_in) == 0 && nchar(chiffre) == 0) {
return(list(typ = "leere_eingabe", meldung = "Bitte Chiffre oder Pseudonym eingeben."))
}
if (nchar(pseudonym_in) == 0 && !grepl("^[A-Z][0-9]{6}$", chiffre)) {
return(list(typ = "format_fehler", chiffre = chiffre))
}
# 2. Skriptpfade pruefen
if (!file.exists(PFAD_DOWNLOAD_SKRIPT) || !file.exists(PFAD_PSEUDONYM_SKRIPT)) {
return(list(typ = "pfad_fehler", meldung = paste0(
"Benötigtes Skript nicht gefunden:\n",
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) paste0(" ", PFAD_DOWNLOAD_SKRIPT, "\n") else "",
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) paste0(" ", PFAD_PSEUDONYM_SKRIPT, "\n") else "")))
}
# 3. Download-Skript sourcen
ok = tryCatch({
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
list(ok = TRUE)
}, error = function(e) list(ok = FALSE, msg = conditionMessage(e)))
if (!ok$ok) {
return(list(typ = "skript_fehler",
meldung = paste0("Fehler beim Ausführen des Download-Skripts:\n", ok$msg)))
}
# 4. pseudonyme.db suchen (Ordner des Pseudonym-Skripts + bis zu 5 Elternebenen)
such_ordner = dirname(PFAD_PSEUDONYM_SKRIPT)
db_ordner = NULL
for (i in 0:5) {
if (file.exists(file.path(such_ordner, "pseudonyme.db"))) { db_ordner = such_ordner; break }
elternteil = dirname(such_ordner)
if (identical(elternteil, such_ordner)) break
such_ordner = elternteil
}
# 5. setwd auf DB-Ordner (mit on.exit davor), dann Pseudonym-Skript sourcen
alter_wd = getwd()
on.exit(setwd(alter_wd), add = TRUE)
if (!is.null(db_ordner)) setwd(db_ordner)
ok2 = tryCatch({
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
list(ok = TRUE)
}, error = function(e) list(ok = FALSE, msg = conditionMessage(e)))
setwd(alter_wd)
if (!ok2$ok) {
return(list(typ = "skript_fehler",
meldung = paste0("Fehler beim Ausführen des Pseudonym-Skripts:\n", ok2$msg)))
}
# 6. Objekte pruefen
if (!exists("daten_eq60", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = "Das Download-Skript hat kein Objekt 'daten_eq60' erzeugt."))
}
if (!exists("pseudo", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = "Das Pseudonym-Skript hat kein Objekt 'pseudo' erzeugt."))
}
daten_eq60 = get("daten_eq60", envir = .GlobalEnv)
pseudo = get("pseudo", envir = .GlobalEnv)
if (!"session" %in% names(daten_eq60)) {
return(list(typ = "skript_fehler",
meldung = "Im Datensatz 'daten_eq60' fehlt die Spalte 'session'."))
}
# 7. Pseudonym -> Chiffre zurueckaufloesen (fuer Kopfzeile / Dateiname)
if (nchar(pseudonym_in) > 0 && all(c("pseudonym", "chiffre") %in% names(pseudo))) {
pw_treffer = pseudo[!is.na(pseudo$pseudonym) &
as.character(pseudo$pseudonym) == pseudonym_in, , drop = FALSE]
if (nrow(pw_treffer) > 0) chiffre = toupper(trimws(as.character(pw_treffer$chiffre[1])))
}
# 8. Chiffre -> Pseudonym(e)
treffer_ps = pseudo[0, , drop = FALSE]
if ("chiffre" %in% names(pseudo)) {
treffer_ps = pseudo[!is.na(pseudo$chiffre) &
toupper(trimws(as.character(pseudo$chiffre))) == chiffre, , drop = FALSE]
}
if (nchar(pseudonym_in) == 0 && nrow(treffer_ps) == 0) {
return(list(typ = "nicht_gefunden",
meldung = "Chiffre/Pseudonym nicht in der Pseudonymliste gefunden."))
}
# 9. Eindeutigkeits-Override bei explizitem Pseudonym
alle_session_ids = unique(as.character(treffer_ps$pseudonym))
if (nchar(pseudonym_in) > 0) alle_session_ids = pseudonym_in
alle_session_ids = alle_session_ids[!is.na(alle_session_ids) & nzchar(alle_session_ids)]
if (length(alle_session_ids) == 0) {
return(list(typ = "nicht_gefunden",
meldung = "Chiffre/Pseudonym nicht in der Pseudonymliste gefunden."))
}
# 10. daten_eq60 nach Session(s) filtern
zeile = daten_eq60[as.character(daten_eq60$session) %in% alle_session_ids, , drop = FALSE]
if (nrow(zeile) == 0) {
return(list(typ = "nicht_gefunden",
meldung = "Kein EQ-60-Datensatz zu diesem Pseudonym gefunden."))
}
warnungen = character(0)
# Neuesten Datensatz zuerst: primaer nach Zeitstempel in daten_eq60,
# ersatzweise nach dem 'datum'-Eintrag aus pseudo (Abschnitt 6, Schritt 8).
dv = hole_datum_vec(zeile)
if (!is.null(dv)) {
zeile = zeile[order(dv, decreasing = TRUE), , drop = FALSE]
} else if ("datum" %in% names(pseudo) && "pseudonym" %in% names(pseudo)) {
pd = parse_zeit(pseudo$datum[match(as.character(zeile$session), as.character(pseudo$pseudonym))])
if (any(!is.na(pd))) zeile = zeile[order(pd, decreasing = TRUE), , drop = FALSE]
}
if (nrow(zeile) > 1) {
warnungen = c(warnungen, sprintf(paste0(
"Zu dieser Chiffre wurden %d EQ-60-Datensätze gefunden (Bogen mehrfach ausgefüllt). ",
"Angezeigt wird der neueste Datensatz. Für einen bestimmten Durchgang bitte das ",
"zugehörige Pseudonym oben eingeben."), nrow(zeile)))
}
row1 = zeile[1, , drop = FALSE]
# Datum fuer Dateiname (Unsicherheit B)
dat = hole_datum_einzeln(row1)
datum_fehlt = is.na(dat$datum)
datum_suffix = if (datum_fehlt) "undatiert" else format(dat$datum, "%Y%m%d")
# 12. Choice-Interpretation + Items aufbauen
items = do.call(rbind, lapply(1:60, function(nr) {
sp = sprintf("eq_%02d", nr)
hat = sp %in% names(row1)
roh = if (hat) row1[[sp]][1] else NA
oc = if (sp %in% names(daten_eq60)) daten_eq60[[sp]] else NULL
idx = interpret_choice(roh, oc)
data.frame(
nr = nr,
art = item_art(nr),
text = bereinige_itemtext(hole_label(daten_eq60, sp)),
roh = if (length(roh) == 0 || all(is.na(roh))) "NA" else as.character(roh)[1],
idx = idx,
antwort = if (!is.na(idx)) EQ_ANTWORT_TEXTE[idx] else NA_character_,
punkte = item_punkte(nr, idx),
stringsAsFactors = FALSE
)
}))
# Score nur bei vollstaendig interpretierbaren 40 gewerteten Items (Abschnitt 3 / 5)
scored = items[items$art %in% c("z", "a"), , drop = FALSE]
schlecht = scored[is.na(scored$idx), , drop = FALSE]
if (nrow(schlecht) > 0) {
f = schlecht[1, ]
return(list(typ = "wert_fehler", meldung = sprintf(paste0(
"Auswertung nicht möglich — unerwarteter Wert bei Item %s.\n",
"Roher Wert: \"%s\"\n",
"Zulässig sind der Choice-Index 1–4 oder exakt einer der vier Antworttexte ",
"(„stimme voll und ganz zu“ / „stimme eher zu“ / „stimme eher nicht zu“ / ",
"„stimme überhaupt nicht zu“). Der EQ-Gesamtscore wird nur berechnet, wenn alle ",
"40 gewerteten Items eindeutig interpretierbar sind (betroffen: %d Item(s))."),
sprintf("eq_%02d", f$nr), f$roh, nrow(schlecht))))
}
score = sum(scored$punkte)
# geschlecht (nur fuer Referenzvergleich, nicht fuer den Score)
g_oc = if ("geschlecht" %in% names(daten_eq60)) daten_eq60[["geschlecht"]] else NULL
g_roh = if ("geschlecht" %in% names(row1)) row1[["geschlecht"]][1] else NA
geschlecht = interpret_geschlecht(g_roh, g_oc)
chiffre_esc = gsub("[^A-Za-z0-9_.-]", "", if (nzchar(chiffre)) chiffre else pseudonym_in)
if (!nzchar(chiffre_esc)) chiffre_esc = "unbekannt"
list(
typ = "ok",
chiffre = if (nzchar(chiffre)) chiffre else paste0("(ohne Chiffre; Pseudonym ", substr(pseudonym_in, 1, 20), ")"),
chiffre_esc = chiffre_esc,
score = score,
klass = klassifiziere(score),
items = items,
geschlecht = geschlecht,
datum = dat$datum,
datum_quelle = dat$quelle,
datum_fehlt = datum_fehlt,
datum_suffix = datum_suffix,
warnungen = warnungen
)
})
fehler_praefix = function(typ) {
switch(typ,
leere_eingabe = "Eingabe unvollständig: ",
format_fehler = "Ungültige Eingabe: ",
pfad_fehler = "Datenzugriff nicht möglich: ",
skript_fehler = "Datenzugriff nicht möglich: ",
nicht_gefunden = "Kein Datensatz: ",
wert_fehler = "Datenproblem: ",
"Fehler: "
)
}
output$fehler_ui = renderUI({
req(input$btn_suchen)
d = ergebnis()
if (identical(d$typ, "ok")) return(NULL)
if (identical(d$typ, "format_fehler")) {
return(div(class = "alert-fehler", paste0(
"Die Chiffre „", d$chiffre, "“ hat nicht das erwartete Format ",
"(ein Großbuchstabe gefolgt von 6 Ziffern, z. B. P000123). ",
"Alternativ ein Pseudonym eingeben.")))
}
div(class = "alert-fehler",
tags$strong(fehler_praefix(d$typ)),
tags$pre(style = "white-space:pre-wrap; margin:6px 0 0; font-family:inherit; font-weight:400;",
d$meldung))
})
output$warnung_ui = renderUI({
req(input$btn_suchen)
d = ergebnis()
if (!identical(d$typ, "ok") || length(d$warnungen) == 0) return(NULL)
tagList(lapply(d$warnungen, function(w) div(class = "alert-warnung", w)))
})
output$ergebnis_ui = renderUI({
req(input$btn_suchen)
d = ergebnis()
req(identical(d$typ, "ok"))
datum_str = if (d$datum_fehlt) "nicht gefunden (undatiert)" else format(d$datum, "%d.%m.%Y")
items_ui = lapply(seq_len(nrow(d$items)), function(i) {
it = d$items[i, ]
itemtext = if (is.na(it$text)) paste0("Item ", it$nr, " (Wortlaut nicht im Datensatz hinterlegt)") else it$text
antwort = if (!is.na(it$antwort)) it$antwort else paste0("unklar (roh: \"", it$roh, "\")")
badge = if (it$art == "filler") {
span(class = "filler-badge", "Filler — nicht gewertet")
} else {
span(class = paste0("stufe-badge-", it$punkte),
paste0(it$punkte, if (it$punkte == 1) " Punkt" else " Punkte"))
}
div(class = "item-zeile",
span(class = "item-nr", it$nr),
span(class = "item-text", itemtext),
span(class = "item-antwort", antwort),
badge
)
})
tagList(
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "EQ-60 Auswertung"),
div(style = "color:#555; margin-bottom:14px;",
tags$strong("Chiffre: "), d$chiffre,
tags$span(" | ", style = "color:#ccc;"),
tags$strong("Ausfülldatum: "), datum_str
),
div(style = "display:flex; align-items:center; gap:20px; flex-wrap:wrap;",
div(
div(style = "font-size:2.7rem; font-weight:800; line-height:1;", d$score,
tags$span(" / 80", style = "font-size:1.2rem; color:#888; font-weight:600;")),
div(style = paste0("margin-top:4px; font-size:1.05rem; font-weight:700; color:", d$klass$farbe, ";"),
d$klass$zone)
),
div(style = "flex:1; min-width:300px;", plotOutput("gauge", height = "165px"))
),
div(style = paste0("margin-top:12px; padding:12px 16px; border-radius:6px; border-left:5px solid ",
d$klass$farbe, "; background:", d$klass$bg, "; font-size:0.95em; line-height:1.55;"),
d$klass$text)
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Referenzwerte"),
tags$ul(style = "margin:0; padding-left:20px; line-height:1.7;",
lapply(referenz_zeilen(d$geschlecht), function(z) tags$li(z))),
if (is.na(d$geschlecht)) {
div(class = "alert-warnung", style = "margin-top:12px;",
"Geschlecht nicht eindeutig, geschlechtsspezifischer Vergleichswert entfällt. ",
"Der Gesamtscore selbst ist davon nicht betroffen.")
},
if (isTRUE(d$datum_fehlt)) {
div(class = "alert-warnung", style = "margin-top:12px;",
"In den Daten wurde keine verwertbare Datumsspalte (created / modified / ended / expired) ",
"gefunden. Der Word-Dateiname trägt den Zusatz „undatiert“.")
}
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Hinweis zur Interpretation"),
div(class = "disclaimer", EQ_DISCLAIMER_ANZEIGE)
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Einzelitems (1–60)"),
div(style = "font-size:0.82em; color:#777; margin-bottom:10px; line-height:1.5;",
"Alle 60 nummerierten Items in Reihenfolge. 40 gewertete Items mit vergebenen ",
"Punkten (0/1/2), 20 Filler-Items ohne Punktvergabe. Beispielitems (E1–E4) sind nicht Teil dieser Liste."),
div(items_ui)
)
)
})
output$gauge = renderPlot({
req(input$btn_suchen)
d = ergebnis()
req(identical(d$typ, "ok"))
mach_gauge(d$score)
}, bg = "transparent")
output$download_word = downloadHandler(
filename = function() {
d = tryCatch(ergebnis(), error = function(e) NULL)
if (!is.list(d) || !identical(d$typ, "ok")) return("EQ60_keine_auswertung.docx")
paste0("EQ60_", d$chiffre_esc, "_", d$datum_suffix, ".docx")
},
content = function(file) {
d = tryCatch(ergebnis(), error = function(e) NULL)
if (!is.list(d) || !identical(d$typ, "ok")) {
doc = read_docx()
doc = body_add_par(doc, paste0(
"Es liegt keine gültige EQ-60-Auswertung vor. Bitte zuerst im Fenster ",
"eine Auswertung erzeugen (Chiffre oder Pseudonym eingeben, „Auswerten“)."),
style = "Normal")
print(doc, target = file)
return(invisible(NULL))
}
doc = tryCatch(erstelle_eq60_docx(d), error = function(e) {
ed = read_docx()
body_add_par(ed, paste0("Fehler beim Erstellen des Word-Dokuments: ", conditionMessage(e)),
style = "Normal")
})
print(doc, target = file)
}
)
}
# Start ####
shinyApp(ui = ui, server = server)