Initial commit
This commit is contained in:
commit
3cba772836
1341 changed files with 532924 additions and 0 deletions
904
FLZ/app.R
Normal file
904
FLZ/app.R
Normal file
|
|
@ -0,0 +1,904 @@
|
|||
# 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)
|
||||
Loading…
Add table
Add a link
Reference in a new issue