# 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)