# Präambel #### library(shiny) library(dplyr) library(ggplot2) library(haven) library(officer) library(DBI) library(RSQLite) PFAD_DOWNLOAD_SKRIPT = "../API/get_data_flz.R" # liefert: daten_flz PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo PFAD_NORMTABELLE = "normtabellen_flz.csv" # liegt im App-Verzeichnis, liefert die Normdaten AKZENT_FARBE = "#8B2635" 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) FLZ_DISCLAIMER = paste0( "Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ", "keine fachliche Interpretation. Das Rohprofil ist fuer die Unterlagen der ", "behandelnden Person gedacht und nicht zur unkommentierten Weitergabe an die ", "betroffene Person bestimmt." ) # Infrastruktur #### app_css = " .input-panel { display: flex; align-items: flex-end; gap: 12px; flex-wrap: wrap; padding: 16px 20px; margin-bottom: 16px; background: #f5f5f5; border-radius: 6px; } .btn-laden { background-color: #8B2635; border-color: #8B2635; color: #fff; } .btn-laden:hover, .btn-laden:focus { background-color: #6f1e2a; border-color: #6f1e2a; color: #fff; } .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: flex-start; gap: 10px; padding: 4px 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; } .profil-zeile { display: flex; align-items: center; gap: 10px; padding: 6px 0; border-bottom: 1px solid #f0f0f0; } .stanine-badge { display: inline-block; border-radius: 12px; padding: 2px 10px; font-size: 0.85em; font-weight: 600; white-space: nowrap; } .stanine-badge-unauffaellig { background: #E8F5E9; color: #2E7D32; border: 1px solid #A5D6A7; } .stanine-badge-auffaellig { background: #f0f0f0; color: #555555; border: 1px solid #cccccc; } " app_css = gsub("#8B2635", AKZENT_FARBE, app_css, fixed = TRUE) # Helper #### FLZ_DOMAENEN = c("GES", "ARB", "FIN", "FRE", "EHE", "KIN", "PER", "SEX", "BEK", "WOH") FLZ_SUM_DOMAENEN = c("GES", "FIN", "FRE", "PER", "SEX", "BEK", "WOH") FLZ_OPTIONALE_DOMAENEN = c("ARB", "EHE", "KIN") FLZ_DOMAENEN_NAMEN = c( GES = "Gesundheit", ARB = "Arbeit und Beruf", FIN = "Finanzielle Lage", FRE = "Freizeit", EHE = "Ehe/Partnerschaft", KIN = "Beziehung zu eigenen Kindern", PER = "Eigene Person", SEX = "Sexualität", BEK = "Freunde, Bekannte, Verwandte", WOH = "Wohnung" ) FLZ_GRUPPEN = c( "Gesamtstichprobe N=2870", "Männer 14-25", "Männer 26-35", "Männer 36-45", "Männer 46-55", "Männer 56-65", "Männer 66-75", "Männer über 75", "Frauen 14-25", "Frauen 26-35", "Frauen 36-45", "Frauen 46-55", "Frauen 56-65", "Frauen 66-75", "Frauen über 75" ) extrahiere_stufe = function(x) { # x kann character (Text der Choice) oder haven_labelled (dbl+lbl) sein if (inherits(x, "haven_labelled")) { x_chr = as.character(haven::as_factor(x)) } else { x_chr = as.character(x) } as.numeric(sub("^\\s*([0-9]+).*$", "\\1", x_chr)) } extrahiere_klartext = function(x) { if (is.null(x) || length(x) == 0) return(NA_character_) if (inherits(x, "haven_labelled")) { return(trimws(as.character(haven::as_factor(x)))) } trimws(as.character(x)) } berechne_flz_scores = function(item_werte) { domaenen_werte = list() gesamt_fehlend = 0 for (dom in FLZ_DOMAENEN) { item_namen = paste0("flz_", tolower(dom), "_", 1:7) werte = as.numeric(item_werte[item_namen]) n_fehlend = sum(is.na(werte)) gesamt_fehlend = gesamt_fehlend + n_fehlend if (n_fehlend == 0) { domaenen_werte[[dom]] = sum(werte) } else if (n_fehlend == 1) { domaenen_werte[[dom]] = round(mean(werte, na.rm = TRUE) * 7) } else { domaenen_werte[[dom]] = NA_real_ } } ueberschreitung = gesamt_fehlend > 7 if (ueberschreitung) { for (dom in FLZ_DOMAENEN) domaenen_werte[[dom]] = NA_real_ sum_wert = NA_real_ } else { sum_domaenen_werte = unlist(domaenen_werte[FLZ_SUM_DOMAENEN]) if (any(is.na(sum_domaenen_werte))) { sum_wert = NA_real_ } else { sum_wert = sum(sum_domaenen_werte) } } list( domaenen = domaenen_werte, sum = sum_wert, n_fehlend_gesamt = gesamt_fehlend, ueberschreitung = ueberschreitung ) } bestimme_gruppe = function(geschlecht, alter) { geschlecht = trimws(geschlecht) if (identical(geschlecht, "männlich")) { praefix = "Männer" } else if (identical(geschlecht, "weiblich")) { praefix = "Frauen" } else { return(list(ok = FALSE, gruppe = NA_character_, warnung = sprintf( "Geschlecht ('%s') konnte nicht eindeutig 'männlich' oder 'weiblich' zugeordnet werden. Keine geschlechtsspezifische Normgruppe verfügbar.", ifelse(is.na(geschlecht) || geschlecht == "", "k. A.", geschlecht) ))) } alter_num = suppressWarnings(as.numeric(alter)) if (is.na(alter_num) || alter_num < 14) { return(list(ok = FALSE, gruppe = NA_character_, warnung = "Alter außerhalb der Normstichprobe / nicht auswertbar. Es wird nur die Gesamtstichprobe als Referenz angeboten." )) } alter_label = if (alter_num <= 25) "14-25" else if (alter_num <= 35) "26-35" else if (alter_num <= 45) "36-45" else if (alter_num <= 55) "46-55" else if (alter_num <= 65) "56-65" else if (alter_num <= 75) "66-75" else "über 75" list(ok = TRUE, gruppe = paste(praefix, alter_label), warnung = NULL) } bestimme_stanine = function(rohwert, normtabelle, gruppe, spalte) { if (is.na(rohwert)) { return(list(stanine = NA_integer_, status = "nicht_berechenbar")) } zeilen = normtabelle[normtabelle$gruppe == gruppe, ] zeilen = zeilen[order(zeilen$stanine), ] for (i in seq_len(nrow(zeilen))) { zellwert = trimws(zeilen[[spalte]][i]) if (identical(zellwert, "-") || nchar(zellwert) == 0) next grenzen = suppressWarnings(as.numeric(strsplit(zellwert, "-")[[1]])) if (length(grenzen) != 2 || any(is.na(grenzen))) next if (rohwert >= grenzen[1] && rohwert <= grenzen[2]) { return(list(stanine = as.integer(sub("ST", "", zeilen$stanine[i])), status = "ok")) } } list(stanine = NA_integer_, status = "ausserhalb_normstichprobe") } stanine_badge_klasse = function(stanine) { if (is.na(stanine)) return("") if (stanine >= 4 && stanine <= 6) "stanine-badge-unauffaellig" else "stanine-badge-auffaellig" } FLZ_STUFEN_TEXT = c( "1" = "sehr unzufrieden", "2" = "unzufrieden", "3" = "eher unzufrieden", "4" = "weder/noch", "5" = "eher zufrieden", "6" = "zufrieden", "7" = "sehr zufrieden" ) bereinige_item_label = function(text) { if (is.null(text) || length(text) == 0 || is.na(text[1])) return(NA_character_) trimws(as.character(text[1])) } ermittle_item_text = function(daten, spalte) { # Itemwortlaut wird zur Laufzeit aus dem label-Attribut der formr-Exportspalte gelesen # (nicht hartkodiert, da urheberrechtlich geschuetzter Testinhalt). if (!(spalte %in% colnames(daten))) return(NA_character_) bereinige_item_label(attr(daten[[spalte]], "label", exact = TRUE)) } # Datenaufbereitung #### normtabelle_pfad = file.path(APP_VERZEICHNIS, PFAD_NORMTABELLE) if (!file.exists(normtabelle_pfad)) { stop(sprintf("Normtabelle nicht gefunden: '%s'.", normtabelle_pfad)) } normtabelle_flz = read.csv( normtabelle_pfad, colClasses = "character", stringsAsFactors = FALSE, fileEncoding = "UTF-8" ) fehlende_gruppen_check = setdiff(FLZ_GRUPPEN, unique(normtabelle_flz$gruppe)) if (length(fehlende_gruppen_check) > 0) { stop(sprintf( "Normtabelle unvollständig, folgende Gruppen fehlen: %s", paste(fehlende_gruppen_check, collapse = ", ") )) } # UI #### ui = fluidPage( tags$head( tags$meta(charset = "UTF-8"), tags$style(HTML(app_css)) ), titlePanel("FLZ – Fragebogen zur Lebenszufriedenheit"), 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)") ) ), div(style = "margin: 0 0 16px 4px;", checkboxInput("zeige_gesamtstichprobe", "Zusätzlich gegen Gesamtstichprobe (N=2870) vergleichen", value = FALSE) ), uiOutput("fehler_ui"), uiOutput("warnung_ui"), uiOutput("ergebnis_ui") ) # Word-Export #### erstelle_flz_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("FLZ - Fragebogen zur Lebenszufriedenheit - 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$ausfuelldatum_anzeige, 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("Kopfdaten", fp_abschnitt))) doc = body_add_fpar(doc, fpar(ftext("Geschlecht: ", fp_label), ftext(erg$geschlecht_text, fp_normal))) doc = body_add_fpar(doc, fpar(ftext("Alter: ", fp_label), ftext(erg$alter_text, fp_normal))) doc = body_add_fpar(doc, fpar(ftext("Normgruppe: ", fp_label), ftext(erg$gruppe_text, fp_normal))) doc = body_add_fpar(doc, fpar(ftext("Schulabschluss: ", fp_label), ftext(erg$schulabschluss, fp_normal))) doc = body_add_fpar(doc, fpar(ftext("Familienstand: ", fp_label), ftext(erg$familienstand, fp_normal))) doc = body_add_fpar(doc, fpar(ftext("Haushalt: ", fp_label), ftext(erg$haushalt, fp_normal))) doc = body_add_fpar(doc, fpar(ftext("Beruflich tätig: ", fp_label), ftext(erg$berufstaetig, fp_normal))) doc = body_add_fpar(doc, fpar(ftext("Berufsgruppe: ", fp_label), ftext(erg$berufsgruppe, fp_normal))) doc = body_add_par(doc, "", style = "Normal") doc = body_add_fpar(doc, fpar(ftext("Profil: Rohwerte und Stanine-Stufen", fp_abschnitt))) for (code in c(FLZ_DOMAENEN, "SUM")) { z = erg$profil_zeilen[[code]] rohwert_text = if (is.na(z$rohwert)) { if (isTRUE(z$ist_optionale_domaene)) "nicht ausgefüllt (nicht zutreffend)" else "nicht berechenbar" } else { as.character(z$rohwert) } stanine_text = if (is.na(z$rohwert)) { "-" } else if (is.na(z$stanine)) { if (identical(z$status, "ausserhalb_normstichprobe")) { "außerhalb der digitalisierten Normstichprobe" } else { "keine Normgruppe" } } else { paste0("Stanine ", z$stanine, if (z$stanine >= 4 && z$stanine <= 6) " (unauffällig)" else "") } unauffaellig = !is.na(z$rohwert) && !is.na(z$stanine) && z$stanine >= 4 && z$stanine <= 6 fp_zeile = if (unauffaellig) { fp_text(font.size = 11, shading.color = "#E8F5E9") } else { fp_text(font.size = 11) } doc = body_add_fpar(doc, fpar(ftext( sprintf("%s: Rohwert %s | %s", z$label, rohwert_text, stanine_text), fp_zeile ))) } 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(FLZ_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_flz", envir = .GlobalEnv)) { return(list(ok = FALSE, meldung = "Objekt 'daten_flz' 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_flz = get("daten_flz", envir = .GlobalEnv) pseudo = get("pseudo", envir = .GlobalEnv) 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_flz[daten_flz$session %in% alle_session_ids, ] if (nrow(treffer_dat) == 0) { return(list(ok = FALSE, meldung = sprintf( "Kein FLZ-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] ausfuelldatum = NA ausfuelldatum_hinweis = NULL if ("ausfuelldatum" %in% colnames(zeile)) { ausfuelldatum = tryCatch(as.Date(zeile[["ausfuelldatum"]][1], "%d.%m.%Y"), error = function(e) NA) } if (is.na(ausfuelldatum) && "created" %in% colnames(zeile)) { ausfuelldatum = tryCatch(as.Date(as.POSIXct(zeile[["created"]][1])), error = function(e) NA) } if (is.na(ausfuelldatum)) { ausfuelldatum = Sys.Date() ausfuelldatum_hinweis = "Ausfülldatum nicht in Exportdaten gefunden, Downloaddatum verwendet." } item_namen = unlist(lapply(FLZ_DOMAENEN, function(d) paste0("flz_", tolower(d), "_", 1:7))) item_werte = setNames(vapply(item_namen, function(n) { if (!(n %in% colnames(zeile))) return(NA_real_) extrahiere_stufe(zeile[[n]]) }, numeric(1)), item_namen) scores = berechne_flz_scores(item_werte) item_info = lapply(FLZ_DOMAENEN, function(dom) { lapply(1:7, function(i) { spalte = paste0("flz_", tolower(dom), "_", i) list( nr = i, spalte = spalte, stufe = item_werte[[spalte]], text = ermittle_item_text(daten_flz, spalte) ) }) }) names(item_info) = FLZ_DOMAENEN geschlecht_text = if ("flz_geschlecht" %in% colnames(zeile)) { extrahiere_klartext(zeile[["flz_geschlecht"]][1]) } else { NA_character_ } alter_roh = if ("flz_alter" %in% colnames(zeile)) zeile[["flz_alter"]][1] else NA alter_num = suppressWarnings(as.numeric(as.character(alter_roh))) gruppe_info = bestimme_gruppe(geschlecht_text, alter_num) zeige_gesamt = isTRUE(input$zeige_gesamtstichprobe) warnungen = c() if (!is.null(gruppe_info$warnung)) warnungen = c(warnungen, gruppe_info$warnung) if (!is.null(ausfuelldatum_hinweis)) warnungen = c(warnungen, ausfuelldatum_hinweis) if (isTRUE(scores$ueberschreitung)) { warnungen = c(warnungen, sprintf( "Mehr als 7 der 70 Items fehlen (%d fehlend). Alle Testwerte (10 Domänen + FLZ-SUM) sind nicht berechenbar.", scores$n_fehlend_gesamt )) } else if (scores$n_fehlend_gesamt > 0) { warnungen = c(warnungen, sprintf("%d von 70 Items wurden nicht beantwortet.", scores$n_fehlend_gesamt)) } profil_zeilen = list() for (dom in FLZ_DOMAENEN) { rohwert = scores$domaenen[[dom]] st_haupt = if (gruppe_info$ok) { bestimme_stanine(rohwert, normtabelle_flz, gruppe_info$gruppe, dom) } else { list(stanine = NA_integer_, status = "keine_gruppe") } st_gesamt = if (zeige_gesamt) { bestimme_stanine(rohwert, normtabelle_flz, "Gesamtstichprobe N=2870", dom) } else { NULL } profil_zeilen[[dom]] = list( code = dom, label = FLZ_DOMAENEN_NAMEN[[dom]], rohwert = rohwert, stanine = st_haupt$stanine, status = st_haupt$status, stanine_gesamt = if (!is.null(st_gesamt)) st_gesamt$stanine else NA_integer_, ist_optionale_domaene = dom %in% FLZ_OPTIONALE_DOMAENEN ) } rohwert_sum = scores$sum st_sum_haupt = if (gruppe_info$ok) { bestimme_stanine(rohwert_sum, normtabelle_flz, gruppe_info$gruppe, "SUM") } else { list(stanine = NA_integer_, status = "keine_gruppe") } st_sum_gesamt = if (zeige_gesamt) { bestimme_stanine(rohwert_sum, normtabelle_flz, "Gesamtstichprobe N=2870", "SUM") } else { NULL } profil_zeilen[["SUM"]] = list( code = "SUM", label = "FLZ-SUM", rohwert = rohwert_sum, stanine = st_sum_haupt$stanine, status = st_sum_haupt$status, stanine_gesamt = if (!is.null(st_sum_gesamt)) st_sum_gesamt$stanine else NA_integer_, ist_optionale_domaene = FALSE ) list( ok = TRUE, chiffre = chiffre, ausfuelldatum = ausfuelldatum, ausfuelldatum_anzeige = format(ausfuelldatum, "%d.%m.%Y"), mehrfach_hinweis = mehrfach_hinweis, geschlecht_text = ifelse(is.na(geschlecht_text) || geschlecht_text == "", "k. A.", geschlecht_text), alter_text = ifelse(is.na(alter_num), "k. A.", as.character(alter_num)), gruppe_info = gruppe_info, gruppe_text = ifelse(gruppe_info$ok, gruppe_info$gruppe, "keine Zuordnung möglich"), schulabschluss = if ("flz_schulabschluss" %in% colnames(zeile)) extrahiere_klartext(zeile[["flz_schulabschluss"]][1]) else "k. A.", familienstand = if ("flz_familienstand" %in% colnames(zeile)) extrahiere_klartext(zeile[["flz_familienstand"]][1]) else "k. A.", haushalt = if ("flz_haushalt" %in% colnames(zeile)) extrahiere_klartext(zeile[["flz_haushalt"]][1]) else "k. A.", berufstaetig = if ("flz_berufstaetig" %in% colnames(zeile)) extrahiere_klartext(zeile[["flz_berufstaetig"]][1]) else "k. A.", berufsgruppe = if ("flz_berufsgruppe" %in% colnames(zeile)) extrahiere_klartext(zeile[["flz_berufsgruppe"]][1]) else "k. A.", scores = scores, profil_zeilen = profil_zeilen, item_info = item_info, zeige_gesamt = zeige_gesamt, warnungen = warnungen, meldung = NULL ) }) baue_profil_plot = function(erg) { profil_reihenfolge = c(FLZ_DOMAENEN, "SUM") daten = do.call(rbind, lapply(profil_reihenfolge, function(code) { z = erg$profil_zeilen[[code]] data.frame( label = z$label, code = code, stanine = if (is.na(z$rohwert)) NA_real_ else as.numeric(z$stanine), stringsAsFactors = FALSE ) })) daten$label = factor(daten$label, levels = rev(unique(daten$label))) daten_plot = daten[!is.na(daten$stanine), ] ggplot() + annotate("rect", xmin = 3.5, xmax = 6.5, ymin = -Inf, ymax = Inf, fill = "#E8F5E9", alpha = 0.6) + geom_point(data = daten_plot, aes(x = stanine, y = label), color = AKZENT_FARBE, size = 3, na.rm = TRUE) + scale_x_continuous(limits = c(1, 9), breaks = 1:9) + labs(x = "Stanine", y = NULL, title = "FLZ-Profil (Stanine 4-6 = unauffälliger Bereich)") + theme_minimal(base_size = 12) } 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)) return(NULL) blocks = list() if (!is.null(erg$mehrfach_hinweis)) blocks = c(blocks, list(div(class = "alert-warnung", erg$mehrfach_hinweis))) if (length(erg$warnungen) > 0) { for (w in erg$warnungen) blocks = c(blocks, list(div(class = "alert-warnung", w))) } if (length(blocks) == 0) return(NULL) div(blocks) }) output$ergebnis_ui = renderUI({ req(input$btn_suchen) erg = ergebnis_r() if (!isTRUE(erg$ok)) return(NULL) profil_reihenfolge = c(FLZ_DOMAENEN, "SUM") zeilen_ui = lapply(profil_reihenfolge, function(code) { z = erg$profil_zeilen[[code]] rohwert_anzeige = if (is.na(z$rohwert)) { if (isTRUE(z$ist_optionale_domaene)) "nicht ausgefüllt (nicht zutreffend)" else "nicht berechenbar" } else { as.character(z$rohwert) } stanine_ui = if (is.na(z$rohwert)) { span("-") } else if (is.na(z$stanine)) { span(if (identical(z$status, "ausserhalb_normstichprobe")) "außerhalb der digitalisierten Normstichprobe" else if (identical(z$status, "keine_gruppe")) "keine Normgruppe" else "-") } else { span(class = paste("stanine-badge", stanine_badge_klasse(z$stanine)), paste0("Stanine ", z$stanine, if (z$stanine >= 4 && z$stanine <= 6) " (unauffällig)" else "")) } gesamt_ui = NULL if (isTRUE(erg$zeige_gesamt)) { gesamt_text = if (is.na(z$rohwert)) { "-" } else if (is.na(z$stanine_gesamt)) { "n. v." } else { paste0("Gesamtstichprobe: Stanine ", z$stanine_gesamt) } gesamt_ui = span(style = "margin-left: 10px; color: #777; font-size: 0.85em;", gesamt_text) } div(class = "profil-zeile", div(style = "min-width: 220px; font-weight: 600;", z$label), div(style = "min-width: 90px;", rohwert_anzeige), div(stanine_ui, gesamt_ui) ) }) div( div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Kopfdaten"), div(style = "margin-bottom: 6px;", tags$strong("Chiffre: "), erg$chiffre, tags$span(style = "color: #ccc; margin: 0 8px;", "|"), tags$strong("Ausfülldatum: "), erg$ausfuelldatum_anzeige ), div(style = "margin-bottom: 4px;", tags$strong("Geschlecht: "), erg$geschlecht_text, tags$span(style = "color: #ccc; margin: 0 8px;", "|"), tags$strong("Alter: "), erg$alter_text, tags$span(style = "color: #ccc; margin: 0 8px;", "|"), tags$strong("Normgruppe: "), erg$gruppe_text ), div(style = "margin-bottom: 4px;", tags$strong("Schulabschluss: "), erg$schulabschluss), div(style = "margin-bottom: 4px;", tags$strong("Familienstand: "), erg$familienstand), div(style = "margin-bottom: 4px;", tags$strong("Haushalt: "), erg$haushalt), div(style = "margin-bottom: 4px;", tags$strong("Beruflich tätig: "), erg$berufstaetig), div(style = "margin-bottom: 4px;", tags$strong("Berufsgruppe: "), erg$berufsgruppe) ), div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Profil: Rohwerte und Stanine"), div(class = "profil-zeile", style = "font-weight: 700; color: #555; border-bottom: 2px solid #ddd;", div(style = "min-width: 220px;", "Domäne"), div(style = "min-width: 90px;", "Rohwert"), div("Stanine") ), zeilen_ui ), div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Profildarstellung"), plotOutput("profil_plot", height = "420px") ), div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Items pro Skala"), lapply(FLZ_DOMAENEN, function(dom) { items_dom = erg$item_info[[dom]] rohwert_dom = erg$profil_zeilen[[dom]]$rohwert rohwert_anzeige = if (is.na(rohwert_dom)) { if (isTRUE(erg$profil_zeilen[[dom]]$ist_optionale_domaene)) "nicht ausgefüllt (nicht zutreffend)" else "nicht berechenbar" } else { as.character(rohwert_dom) } tags$details( tags$summary(sprintf("%s (Rohwert: %s)", FLZ_DOMAENEN_NAMEN[[dom]], rohwert_anzeige)), lapply(items_dom, function(it) { stufe_anzeige = if (is.na(it$stufe)) { "fehlend" } else { paste0(it$stufe, " = ", FLZ_STUFEN_TEXT[[as.character(it$stufe)]]) } item_text_anzeige = if (is.na(it$text)) sprintf("Item %s.%d", dom, it$nr) else it$text div(class = "item-zeile", span(class = "item-nr", it$nr), span(class = "item-text", item_text_anzeige), span(style = paste0("font-weight: 600; color: ", AKZENT_FARBE, "; white-space: nowrap;"), stufe_anzeige) ) }) ) }) ), div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Hinweis zur Interpretation"), p(style = "font-size: 0.85em; color: #555; line-height: 1.5;", FLZ_DISCLAIMER) ) ) }) output$profil_plot = renderPlot({ erg = ergebnis_r() req(isTRUE(erg$ok)) baue_profil_plot(erg) }) output$download_word = downloadHandler( filename = function() { erg = tryCatch(ergebnis_r(), error = function(e) NULL) if (is.null(erg) || !isTRUE(erg$ok)) return("FLZ_Auswertung.docx") chiffre_esc = gsub("[^A-Za-z0-9]", "", erg$chiffre) ausfuelldatum_fn = tryCatch( format(as.Date(erg$ausfuelldatum, "%d.%m.%Y"), "%Y%m%d"), error = function(e) format(Sys.Date(), "%Y%m%d") ) paste0("FLZ_", chiffre_esc, "_", ausfuelldatum_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_flz_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)