Initial commit

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

BIN
BIFL/.RData Normal file

Binary file not shown.

1
BIFL/.Rprofile Normal file
View file

@ -0,0 +1 @@
source("renv/activate.R")

13
BIFL/BIFL.Rproj Normal file
View file

@ -0,0 +1,13 @@
Version: 1.0
RestoreWorkspace: Default
SaveWorkspace: Default
AlwaysSaveHistory: Default
EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: UTF-8
RnwWeave: Sweave
LaTeX: pdfLaTeX

763
BIFL/app.R Normal file
View file

@ -0,0 +1,763 @@
# Präambel ####
AKZENT_FARBE = "#8B2635"
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_bifl.R"
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
PFAD_NORMTABELLE_NICHTKLINISCH = "normtabellen/bifl_tabelle3_nichtklinisch.csv"
PFAD_NORMTABELLE_KLINISCH = "normtabellen/bifl_tabelle4_klinisch.csv"
BIFL_DISCLAIMER = paste0(
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ",
"Die Altersgruppengrenzen der Normtabellen sind datengetrieben und nicht klinisch ",
"begruendet (Zotschew et al., 2024)."
)
# Bezeichnungen der 18 Lebensbereiche stehen im formr-Bogen NICHT im Label der
# _zuf/_bed-Items selbst (dort steht nur "Zufriedenheit"/"Bedeutsamkeit"), sondern
# in separaten note-Items (bifl_XX_intro, z.B. "#### 1\\. koerperliche Gesundheit"),
# die formr nicht als Datenspalte exportiert. Deshalb hier statisch aus der
# Instrumenten-xlsx uebernommen (Markdown-Ueberschrift und Nummerierung entfernt),
# analog zu AUDIT_ITEM_TEXTE in audit/app.R.
BIFL_LEBENSBEREICHE = c(
"körperliche Gesundheit",
"seelische Gesundheit",
"Aussehen",
"Sexualleben",
"Leistungsfähigkeit",
"Fähigkeiten und Fertigkeiten",
"berufliche Situation (auch falls in Rente, Elternzeit, bei Arbeitslosigkeit etc.)",
"finanzielle Situation",
"Wohnsituation",
"Freizeitgestaltung",
"Balance zwischen Arbeit und Freizeit",
"Charakter-/ Persönlichkeitseigenschaften",
"Umgang mit anderen Menschen",
"Freundes- und Bekanntenkreis",
"soziale Unterstützung durch Freunde und Familie",
"Beziehungen zu Familienangehörigen",
"partnerschaftliche Situation (auch falls in keiner Partnerschaft)",
"Beziehung zu meinen Kindern bzw. Kinderlosigkeit"
)
library(shiny)
library(dplyr)
library(ggplot2)
library(haven)
library(officer)
# 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)
PFAD_NORMTABELLE_NICHTKLINISCH = normalizePath(absPath(PFAD_NORMTABELLE_NICHTKLINISCH), mustWork = FALSE)
PFAD_NORMTABELLE_KLINISCH = normalizePath(absPath(PFAD_NORMTABELLE_KLINISCH), mustWork = FALSE)
# Helper ####
# formr liefert dbl+lbl/haven-Objekte, deshalb robust ueber as.numeric() extrahieren.
extrahiere_wert = function(x) {
if (is.null(x) || length(x) == 0) return(NA_real_)
as.numeric(x)[1]
}
# Nie hartkodiert - immer aus dem labels-Attribut der Original-Spalte.
bifl_get_label_text = function(original_col, wert) {
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_character_)
lbl_attr = attr(original_col, "labels")
if (!is.null(lbl_attr) && length(lbl_attr) > 0) {
pos = which(as.vector(lbl_attr) == as.numeric(wert[1]))
if (length(pos) > 0) return(names(lbl_attr)[pos[1]])
}
NA_character_
}
finde_altersgruppe = function(alter) {
if (is.na(alter)) return(NA_character_)
if (alter >= 18 && alter <= 23) return("18-23")
if (alter >= 24 && alter <= 27) return("24-27")
if (alter >= 28 && alter <= 33) return("28-33")
if (alter >= 34 && alter <= 42) return("34-42")
if (alter >= 43 && alter <= 73) return("43-73")
return(NA_character_)
}
finde_prozentrang = function(normtabelle, altersgruppe, wert) {
teiltabelle = normtabelle[normtabelle$altersgruppe == altersgruppe, ]
teiltabelle$von_num = suppressWarnings(as.numeric(teiltabelle$intervall_von))
teiltabelle$bis_num = suppressWarnings(as.numeric(teiltabelle$intervall_bis))
teiltabelle = teiltabelle[!is.na(teiltabelle$von_num) & !is.na(teiltabelle$bis_num), ]
treffer = teiltabelle[wert > teiltabelle$von_num & wert <= teiltabelle$bis_num, ]
if (nrow(treffer) == 0) return(NA)
treffer$prozentrang[1]
}
# Kapselt finde_prozentrang() und faengt den Randfall ab, dass der Wert
# unterhalb des kleinsten intervall_von der Gruppe liegt (linksoffenes
# unterstes Intervall schliesst den exakten Rand nicht ein).
perzentilrang_status = function(normtabelle, altersgruppe, wert) {
teiltabelle = normtabelle[normtabelle$altersgruppe == altersgruppe, ]
teiltabelle$von_num = suppressWarnings(as.numeric(teiltabelle$intervall_von))
teiltabelle$bis_num = suppressWarnings(as.numeric(teiltabelle$intervall_bis))
teiltabelle = teiltabelle[!is.na(teiltabelle$von_num) & !is.na(teiltabelle$bis_num), ]
if (nrow(teiltabelle) == 0) return(list(prozentrang = NA_real_, status = "keine_daten"))
prozentrang = finde_prozentrang(normtabelle, altersgruppe, wert)
if (!is.na(prozentrang)) return(list(prozentrang = prozentrang, status = "normal"))
min_von = min(teiltabelle$von_num)
if (wert <= min_von) {
unterste_zeile = teiltabelle[teiltabelle$von_num == min_von, ]
return(list(prozentrang = unterste_zeile$prozentrang[1], status = "unterhalb"))
}
list(prozentrang = NA_real_, status = "unbestimmt")
}
# M/SD-Markerzeilen: intervall_von == "M", intervall_bis == "SD".
# In den vorliegenden CSVs steht der Mittelwert in der Spalte 'prozentrang'
# und die Standardabweichung in der Spalte 'n' (verifiziert an den realen Dateien).
finde_mw_sd = function(normtabelle, altersgruppe) {
zeile = normtabelle[normtabelle$altersgruppe == altersgruppe &
normtabelle$intervall_von == "M" &
normtabelle$intervall_bis == "SD", ]
if (nrow(zeile) == 0) return(list(m = NA_real_, sd = NA_real_))
list(
m = suppressWarnings(as.numeric(zeile$prozentrang[1])),
sd = suppressWarnings(as.numeric(zeile$n[1]))
)
}
make_gauge_bifl = function(prozentrang) {
ggplot() +
geom_rect(aes(xmin = 0, xmax = 100, ymin = 0, ymax = 1),
fill = "#F5F5F5", color = "#9E9E9E", linewidth = 0.6) +
geom_vline(xintercept = 50, color = "#9E9E9E", linetype = "dashed", linewidth = 1) +
geom_segment(aes(x = prozentrang, xend = prozentrang, y = -0.25, yend = 1.25),
color = AKZENT_FARBE, linewidth = 2.5) +
geom_label(aes(x = prozentrang, y = 1.6, label = paste0("PR: ", round(prozentrang))),
fill = AKZENT_FARBE, color = "white", fontface = "bold",
linewidth = 0, size = 4) +
annotate("text", x = 50, y = -0.55, label = "Median (PR 50)",
color = "#9E9E9E", size = 3.2, hjust = 0.5) +
scale_x_continuous(limits = c(0, 100), breaks = c(0, 25, 50, 75, 100)) +
scale_y_continuous(limits = c(-0.8, 2.0)) +
theme_minimal(base_size = 12) +
theme(
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor = element_blank(),
axis.title.y = element_blank(),
plot.margin = margin(t = 5, r = 10, b = 5, l = 10)
) +
labs(x = "Prozentrang (0-100)", y = NULL)
}
# Datenaufbereitung ####
normtabelle_nichtklinisch = read.csv(PFAD_NORMTABELLE_NICHTKLINISCH, stringsAsFactors = FALSE)
normtabelle_klinisch = read.csv(PFAD_NORMTABELLE_KLINISCH, stringsAsFactors = FALSE)
# UI ####
app_css = "
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; }
.app-header {
background: #8B2635; color: white; padding: 18px 24px 14px;
margin-bottom: 20px; border-radius: 0 0 6px 6px;
}
.app-header h2 { margin: 0; font-size: 1.5rem; font-weight: 600; }
.app-header p { margin: 4px 0 0; opacity: 0.85; font-size: 0.9rem; }
.input-panel {
background: white; border-radius: 6px; padding: 16px 20px;
margin-bottom: 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
display: flex; align-items: flex-end; gap: 12px; flex-wrap: wrap;
}
.input-panel .form-group { margin-bottom: 0; }
.input-panel label { font-weight: 600; color: #333; }
.btn-laden {
background: #8B2635 !important; color: white !important;
border: none !important; border-radius: 4px !important;
padding: 8px 20px !important; font-weight: 600 !important; cursor: pointer;
}
.btn-laden:hover { background: #6d1e29 !important; }
.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-size: 0.93em; font-weight: 500;
}
.abschnitt-karte {
background: white; 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;
}
.meta-block { margin-bottom: 10px; color: #555; font-size: 0.95em; }
.meta-block strong { color: #222; }
.kontext-zeile {
display: flex; gap: 8px; align-items: baseline;
padding: 4px 0; color: #444; font-size: 0.93em;
}
.kontext-label { font-weight: 600; color: #333; min-width: 220px; }
.item-zeile {
display: flex; align-items: flex-start; gap: 10px;
padding: 7px 0; border-bottom: 1px solid #F0F0F0;
}
.item-nr { font-weight: 600; color: #8B2635; min-width: 26px; flex-shrink: 0; }
.item-text { flex: 1; color: #333; font-size: 0.92em; }
.wert-badge {
border-radius: 4px; padding: 2px 9px; font-weight: 700;
font-size: 0.82em; white-space: nowrap; display: inline-block; flex-shrink: 0;
background: #ECEFF1; color: #333; margin-left: 6px;
}
.score-zahl { font-size: 2.2rem; font-weight: 800; color: #8B2635; }
.perzentil-info { font-size: 0.88em; color: #555; margin-top: 4px; }
.mwsd-info { font-size: 0.85em; color: #777; margin-top: 2px; }
.personinterner-hinweis {
font-size: 0.85em; color: #777; font-style: italic; margin-bottom: 10px;
}
"
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("BIFL Bielefelder Fragebogen zur Lebenszufriedenheit"),
tags$p("Zotschew, Kley, Möllmann, Schlechter & Heinrichs (2024)")
),
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%")
),
div(style = "min-width: 220px;",
selectInput("klinischer_status", label = "Klinischer Status",
choices = c("- bitte auswaehlen -" = "", "nichtklinisch" = "nichtklinisch", "klinisch (Psychotherapie-Inanspruchnahme)" = "klinisch"),
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_bifl_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_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
doc = body_add_fpar(doc, fpar(ftext("BIFL - Einzelauswertung", fp_titel)))
doc = body_add_fpar(doc, fpar(
ftext("Chiffre: ", fp_label),
ftext(erg$chiffre, fp_normal),
ftext(" Datum: ", fp_label),
ftext(erg$datum_str, fp_normal),
ftext(" Klin. Status: ", fp_label),
ftext(erg$klinischer_status, fp_normal)
))
if (!is.null(erg$info_mehrere)) {
doc = body_add_fpar(doc, fpar(
ftext(erg$info_mehrere, fp_text(font.size = 10, italic = TRUE, color = "#555555"))
))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Composite-Score", fp_abschnitt)))
if (is.na(erg$bifl_composite)) {
doc = body_add_fpar(doc, fpar(ftext(erg$composite_warnung, fp_text(bold = TRUE, font.size = 11, color = "#C62828"))))
} else {
doc = body_add_fpar(doc, fpar(
ftext("Composite (gewichtete Zufriedenheit): ", fp_label),
ftext(sprintf("%.2f", erg$bifl_composite), fp_normal)
))
if (!is.null(erg$altersgruppen_warnung)) {
doc = body_add_fpar(doc, fpar(ftext(erg$altersgruppen_warnung, fp_text(font.size = 9, italic = TRUE, color = "#BF360C"))))
}
if (!is.null(erg$perzentil_altersgruppe)) {
pz = erg$perzentil_altersgruppe
zusatz = if (pz$status == "unterhalb") " (unterhalb des untersten erfassten Bereichs, niedrigster berichteter Prozentrang)" else ""
doc = body_add_fpar(doc, fpar(
ftext(paste0("Prozentrang (Altersgruppe ", erg$altersgruppe, "): "), fp_label),
ftext(paste0(pz$prozentrang, zusatz), fp_normal)
))
if (!is.null(erg$mw_sd_altersgruppe) && !is.na(erg$mw_sd_altersgruppe$m)) {
doc = body_add_fpar(doc, fpar(
ftext(paste0("M = ", erg$mw_sd_altersgruppe$m, ", SD = ", erg$mw_sd_altersgruppe$sd, " (Altersgruppe, deskriptiv)"),
fp_text(font.size = 9, color = "#777777"))
))
}
}
if (!is.null(erg$perzentil_gesamt)) {
pz = erg$perzentil_gesamt
zusatz = if (pz$status == "unterhalb") " (unterhalb des untersten erfassten Bereichs, niedrigster berichteter Prozentrang)" else ""
doc = body_add_fpar(doc, fpar(
ftext("Prozentrang (Gesamtstichprobe): ", fp_label),
ftext(paste0(pz$prozentrang, zusatz), fp_normal)
))
if (!is.null(erg$mw_sd_gesamt) && !is.na(erg$mw_sd_gesamt$m)) {
doc = body_add_fpar(doc, fpar(
ftext(paste0("M = ", erg$mw_sd_gesamt$m, ", SD = ", erg$mw_sd_gesamt$sd, " (Gesamtstichprobe, deskriptiv)"),
fp_text(font.size = 9, color = "#777777"))
))
}
}
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Item 19 (nicht normiert)", fp_abschnitt)))
doc = body_add_fpar(doc, fpar(
ftext("Rohwert: ", fp_label),
ftext(paste0(erg$i19_wert, if (!is.na(erg$i19_text)) paste0(" (", erg$i19_text, ")") else ""), fp_normal)
))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Detailauswertung der 18 Lebensbereiche", fp_abschnitt)))
doc = body_add_fpar(doc, fpar(
ftext("Innerhalb dieser Person, kein Vergleich mit einer Normstichprobe moeglich (aufsteigend nach gewichtetem Wert).",
fp_text(font.size = 9, italic = TRUE, color = "#777777"))
))
tab_df = data.frame(
Nr = sapply(erg$bereiche_sortiert, function(b) b$nr),
Lebensbereich = sapply(erg$bereiche_sortiert, function(b) b$bezeichnung),
Zufriedenheit = sapply(erg$bereiche_sortiert, function(b) b$zuf),
Bedeutsamkeit = sapply(erg$bereiche_sortiert, function(b) b$bed),
Gewichtet = sapply(erg$bereiche_sortiert, function(b) round(b$gewichtet, 2)),
stringsAsFactors = FALSE
)
doc = body_add_table(doc, tab_df, style = "table_template")
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(BIFL_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(error = "Bitte Chiffre oder Pseudonym eingeben."))
}
if (nchar(trimws(input$pseudonym)) == 0 && !grepl("^[A-Z][0-9]{6}$", chiffre)) {
return(list(error = "Ungueltige Chiffre. Erwartet: ein Grossbuchstabe + 6 Ziffern (z.B. P000123)."))
}
if (nchar(trimws(input$klinischer_status)) == 0) {
return(list(error = "Bitte klinischen Status auswaehlen (nichtklinisch oder klinisch)."))
}
if (!file.exists(PFAD_DOWNLOAD_SKRIPT))
return(list(error = paste0("Download-Skript nicht gefunden:\n", PFAD_DOWNLOAD_SKRIPT)))
if (!file.exists(PFAD_PSEUDONYM_SKRIPT))
return(list(error = paste0("Pseudonym-Skript nicht gefunden:\n", PFAD_PSEUDONYM_SKRIPT)))
if (!file.exists(PFAD_NORMTABELLE_NICHTKLINISCH))
return(list(error = paste0("Normtabelle (nichtklinisch) nicht gefunden:\n", PFAD_NORMTABELLE_NICHTKLINISCH)))
if (!file.exists(PFAD_NORMTABELLE_KLINISCH))
return(list(error = paste0("Normtabelle (klinisch) nicht gefunden:\n", PFAD_NORMTABELLE_KLINISCH)))
res_dl = tryCatch(
{ source(PFAD_DOWNLOAD_SKRIPT, local = FALSE); list(ok = TRUE) },
error = function(e) list(ok = FALSE, msg = e$message)
)
if (!res_dl$ok)
return(list(error = paste0("Fehler im Download-Skript: ", res_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)
res_ps = tryCatch(
{ source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
if (nchar(trimws(input$pseudonym)) > 0) {
.pw_wert = trimws(input$pseudonym)
.pw_tab = get("pseudo", envir = .GlobalEnv)
.pw_treffer = .pw_tab[.pw_tab$pseudonym == .pw_wert, ]
if (nrow(.pw_treffer) > 0) chiffre = toupper(trimws(.pw_treffer$chiffre[1]))
}; list(ok = TRUE) },
error = function(e) list(ok = FALSE, msg = e$message)
)
if (!res_ps$ok)
return(list(error = paste0("Fehler im Pseudonym-Skript: ", res_ps$msg)))
if (!exists("daten_bifl", envir = .GlobalEnv))
return(list(error = "Objekt 'daten_bifl' nach dem Sourcen nicht gefunden. Bitte Download-Skript pruefen."))
if (!exists("pseudo", envir = .GlobalEnv))
return(list(error = "Objekt 'pseudo' nach dem Sourcen nicht gefunden. Bitte Pseudonym-Skript pruefen."))
daten = get("daten_bifl", envir = .GlobalEnv)
pseudo_df = get("pseudo", envir = .GlobalEnv)
treffer_ps = pseudo_df[pseudo_df$chiffre == chiffre, ]
if (nrow(treffer_ps) == 0)
return(list(error = paste0("Chiffre '", chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden.")))
alle_session_ids = unique(treffer_ps$pseudonym)
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
treffer_dat = daten[daten$session %in% alle_session_ids, ]
if (nrow(treffer_dat) == 0)
return(list(error = paste0(
"Kein BIFL-Datensatz fuer Chiffre '", chiffre, "' gefunden. ",
"(", length(alle_session_ids), " Pseudonym(e) geprueft)")))
info_mehrere = 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"
)
info_mehrere = paste0(
"Mehrere Ausfuellungen gefunden (", n, " Eintraege). ",
"Angezeigt wird die neueste vom ", datum_neu, "."
)
treffer_dat = treffer_dat[1, , drop = FALSE]
}
zeile = treffer_dat[1, , drop = FALSE]
datum_str = tryCatch(
format(as.POSIXct(zeile[["created"]][1]), "%d.%m.%Y"),
error = function(e) format(Sys.Date(), "%d.%m.%Y")
)
klinischer_status = input$klinischer_status
bereiche = lapply(seq_len(18), function(i) {
zuf_var = paste0("bifl_", sprintf("%02d", i), "_zuf")
bed_var = paste0("bifl_", sprintf("%02d", i), "_bed")
zuf_wert = extrahiere_wert(zeile[[zuf_var]])
bed_wert = extrahiere_wert(zeile[[bed_var]])
gewichtet = if (is.na(zuf_wert) || is.na(bed_wert)) NA_real_ else (zuf_wert - 3.5) * bed_wert
bezeichnung = BIFL_LEBENSBEREICHE[i]
list(nr = i, bezeichnung = bezeichnung, zuf = zuf_wert, bed = bed_wert, gewichtet = gewichtet)
})
gewichtete_werte = sapply(bereiche, function(b) b$gewichtet)
composite_warnung = NULL
if (any(is.na(gewichtete_werte))) {
bifl_composite = NA_real_
composite_warnung = "Unvollstaendige Angaben, Composite-Score kann nicht berechnet werden."
} else {
bifl_composite = mean(gewichtete_werte)
}
bereiche_sortiert = bereiche[order(gewichtete_werte, na.last = TRUE)]
i19_wert = extrahiere_wert(zeile[["bifl_19"]])
i19_text = bifl_get_label_text(daten[["bifl_19"]], zeile[["bifl_19"]])
alter = extrahiere_wert(zeile[["bifl_alter"]])
altersgruppe = finde_altersgruppe(alter)
altersgruppen_warnung = NULL
if (!is.na(alter) && is.na(altersgruppe)) {
if (isTRUE(alter == 17) && klinischer_status == "klinisch") {
altersgruppen_warnung = paste0(
"Alter (17 Jahre) liegt ausserhalb der definierten Altersgruppen. Zusaetzlicher Hinweis: ",
"Fuer 17-jaehrige Personen mit klinischem Status ist in der Quelle nicht eindeutig dokumentiert, ",
"ob sie in der Normierungsstichprobe der Altersgruppe 18-23 enthalten waren oder ganz herausfielen ",
"(Zotschew et al., 2024). Als Alternative steht die altersunabhaengige Gesamtstichprobe zur Verfuegung."
)
} else {
altersgruppen_warnung = paste0(
"Alter (", alter, " Jahre) liegt ausserhalb der normierten Altersspanne (18-73 Jahre) fuer den ",
"Prozentrang-Vergleich nach Altersgruppe. Als Alternative steht die altersunabhaengige ",
"Gesamtstichprobe zur Verfuegung (siehe unten)."
)
}
} else if (is.na(alter)) {
altersgruppen_warnung = "Alter nicht angegeben oder nicht auswertbar; Einordnung nur gegen die Gesamtstichprobe moeglich."
}
normtabelle = if (klinischer_status == "klinisch") normtabelle_klinisch else normtabelle_nichtklinisch
perzentil_altersgruppe = NULL
mw_sd_altersgruppe = NULL
if (!is.na(bifl_composite) && !is.na(altersgruppe)) {
perzentil_altersgruppe = perzentilrang_status(normtabelle, altersgruppe, bifl_composite)
mw_sd_altersgruppe = finde_mw_sd(normtabelle, altersgruppe)
}
perzentil_gesamt = NULL
mw_sd_gesamt = NULL
if (!is.na(bifl_composite)) {
perzentil_gesamt = perzentilrang_status(normtabelle, "gesamt", bifl_composite)
mw_sd_gesamt = finde_mw_sd(normtabelle, "gesamt")
}
list(
chiffre = chiffre,
datum_str = datum_str,
info_mehrere = info_mehrere,
klinischer_status = klinischer_status,
bereiche = bereiche,
bereiche_sortiert = bereiche_sortiert,
bifl_composite = bifl_composite,
composite_warnung = composite_warnung,
i19_wert = i19_wert,
i19_text = i19_text,
alter = alter,
altersgruppe = altersgruppe,
altersgruppen_warnung = altersgruppen_warnung,
perzentil_altersgruppe = perzentil_altersgruppe,
perzentil_gesamt = perzentil_gesamt,
mw_sd_altersgruppe = mw_sd_altersgruppe,
mw_sd_gesamt = mw_sd_gesamt,
error = NULL
)
})
output$fehler_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (!is.null(d$error)) div(class = "alert-fehler", d$error)
})
output$warnung_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (!is.null(d$error)) return(NULL)
warnungen = Filter(Negate(is.null), list(d$info_mehrere, d$altersgruppen_warnung, d$composite_warnung))
if (length(warnungen) == 0) return(NULL)
tagList(lapply(warnungen, function(w) div(class = "alert-warnung", w)))
})
output$ergebnis_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (!is.null(d$error)) return(NULL)
items_ui = lapply(d$bereiche, function(b) {
div(class = "item-zeile",
div(class = "item-nr", paste0(b$nr, ".")),
div(class = "item-text", b$bezeichnung),
span(class = "wert-badge", paste0("Zuf: ", b$zuf)),
span(class = "wert-badge", paste0("Bed: ", b$bed)),
span(class = "wert-badge", paste0("Gew: ", if (is.na(b$gewichtet)) "k. A." else round(b$gewichtet, 2)))
)
})
items_sortiert_ui = lapply(d$bereiche_sortiert, function(b) {
div(class = "item-zeile",
div(class = "item-nr", paste0(b$nr, ".")),
div(class = "item-text", b$bezeichnung),
span(class = "wert-badge", paste0("Gew: ", if (is.na(b$gewichtet)) "k. A." else round(b$gewichtet, 2)))
)
})
tagList(
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "BIFL - Composite-Score"),
div(class = "meta-block",
tags$strong("Chiffre: "), d$chiffre,
tags$span(" | ", style = "color:#ccc;"),
tags$strong("Ausfuelldatum: "), d$datum_str,
tags$span(" | ", style = "color:#ccc;"),
tags$strong("Klinischer Status: "), d$klinischer_status
),
tags$hr(),
if (is.na(d$bifl_composite)) {
div(class = "alert-fehler", d$composite_warnung)
} else {
tagList(
fluidRow(
column(3,
div(
div(class = "score-zahl", sprintf("%.2f", d$bifl_composite)),
div("Composite (gewichtete Zufriedenheit, -15 bis +15)", style = "color:#555;")
)
),
column(9, plotOutput("gauge_plot", height = "160px"))
),
tags$hr(),
if (!is.null(d$perzentil_altersgruppe)) {
pz = d$perzentil_altersgruppe
mwsd = d$mw_sd_altersgruppe
zusatz = if (pz$status == "unterhalb") " (unterhalb des untersten erfassten Bereichs, niedrigster berichteter Prozentrang)" else ""
div(
div(class = "perzentil-info",
tags$strong(paste0("Prozentrang (Altersgruppe ", d$altersgruppe, "): ")),
paste0(pz$prozentrang, zusatz)
),
if (!is.na(mwsd$m)) div(class = "mwsd-info", paste0("M = ", mwsd$m, ", SD = ", mwsd$sd, " (Altersgruppe, deskriptiv)"))
)
},
if (!is.null(d$perzentil_gesamt)) {
pz = d$perzentil_gesamt
mwsd = d$mw_sd_gesamt
zusatz = if (pz$status == "unterhalb") " (unterhalb des untersten erfassten Bereichs, niedrigster berichteter Prozentrang)" else ""
div(
div(class = "perzentil-info",
tags$strong("Prozentrang (Gesamtstichprobe): "),
paste0(pz$prozentrang, zusatz)
),
if (!is.na(mwsd$m)) div(class = "mwsd-info", paste0("M = ", mwsd$m, ", SD = ", mwsd$sd, " (Gesamtstichprobe, deskriptiv)"))
)
}
)
}
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Item 19 (nicht normiert)"),
div(class = "kontext-zeile",
div(class = "kontext-label", "Rohwert (1-6):"),
div(paste0(d$i19_wert, if (!is.na(d$i19_text)) paste0(" (", d$i19_text, ")") else ""))
)
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Detailauswertung der 18 Lebensbereiche"),
div(class = "personinterner-hinweis",
"Innerhalb dieser Person, kein Vergleich mit einer Normstichprobe moeglich. Sortiert aufsteigend nach gewichtetem Wert."),
div(items_sortiert_ui)
)
)
})
output$gauge_plot = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(is.null(d$error), !is.na(d$bifl_composite))
pz_anzeige = if (!is.null(d$perzentil_altersgruppe)) d$perzentil_altersgruppe else d$perzentil_gesamt
req(!is.null(pz_anzeige), !is.na(pz_anzeige$prozentrang))
make_gauge_bifl(pz_anzeige$prozentrang)
}, bg = "transparent")
output$download_word = downloadHandler(
filename = function() {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
chiffre_esc = if (is.list(d) && is.null(d$error) && nchar(d$chiffre) > 0)
gsub("[^A-Za-z0-9]", "_", d$chiffre) else "export"
ausfuelldatum_fn = if (is.list(d) && is.null(d$error) && !is.null(d$datum_str))
tryCatch(
format(as.Date(d$datum_str, "%d.%m.%Y"), "%Y%m%d"),
error = function(e) format(Sys.Date(), "%Y%m%d")
)
else
format(Sys.Date(), "%Y%m%d")
paste0("BIFL_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
},
content = function(file) {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
daten_ok = is.list(d) && is.null(d$error)
if (!daten_ok) {
doc = read_docx()
doc = body_add_par(doc,
"Kein Datensatz geladen. Bitte zuerst Chiffre/Pseudonym, klinischen Status eingeben und 'Auswerten' klicken.",
style = "Normal")
print(doc, target = file)
return()
}
doc = tryCatch(
erstelle_bifl_docx(d),
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, server)

View file

@ -0,0 +1,67 @@
altersgruppe,intervall_von,intervall_bis,prozentrang,n
18-23,-13,-1,3,13
18-23,-1,1,11,13
18-23,1,2.5,19,18
18-23,2.5,3.5,29,14
18-23,3.5,4.5,37,15
18-23,4.5,5.5,50,31
18-23,5.5,6.5,63,16
18-23,6.5,7.5,74,25
18-23,7.5,9,85,13
18-23,9,13,95,20
24-27,-13,-1,6,18
24-27,-1,1,16,13
24-27,1,2.5,25,15
24-27,2.5,3.5,35,14
24-27,3.5,4.5,46,19
24-27,4.5,5.5,56,13
24-27,5.5,6.5,68,22
24-27,6.5,7.5,78,9
24-27,7.5,9,87,18
24-27,9,13,97,11
28-33,-13,-1,4,15
28-33,-1,1,14,17
28-33,1,2.5,24,18
28-33,2.5,3.5,35,20
28-33,3.5,4.5,47,19
28-33,4.5,5.5,58,17
28-33,5.5,6.5,68,18
28-33,6.5,7.5,78,15
28-33,7.5,9,87,17
28-33,9,13,97,13
34-42,-13,-1,7,24
34-42,-1,1,22,23
34-42,1,2.5,34,18
34-42,2.5,3.5,45,16
34-42,3.5,4.5,56,18
34-42,4.5,5.5,67,16
34-42,5.5,6.5,76,14
34-42,6.5,7.5,85,14
34-42,7.5,9,92,10
34-42,9,13,98,8
43-73,-13,-1,5,16
43-73,-1,1,15,16
43-73,1,2.5,25,14
43-73,2.5,3.5,36,18
43-73,3.5,4.5,45,12
43-73,4.5,5.5,54,15
43-73,5.5,6.5,63,12
43-73,6.5,7.5,71,12
43-73,7.5,9,83,27
43-73,9,13,96,12
gesamt,-13,-1,5,86
gesamt,-1,1,16,82
gesamt,1,2.5,26,83
gesamt,2.5,3.5,36,82
gesamt,3.5,4.5,46,83
gesamt,4.5,5.5,57,92
gesamt,5.5,6.5,67,82
gesamt,6.5,7.5,77,75
gesamt,7.5,9,87,85
gesamt,9,13,96,64
18-23,M,SD,4.9,3.7
24-27,M,SD,4.2,4.1
28-33,M,SD,4.5,3.6
34-42,M,SD,3.4,3.8
43-73,M,SD,4.3,4.3
gesamt,M,SD,4.3,3.9
1 altersgruppe intervall_von intervall_bis prozentrang n
2 18-23 -13 -1 3 13
3 18-23 -1 1 11 13
4 18-23 1 2.5 19 18
5 18-23 2.5 3.5 29 14
6 18-23 3.5 4.5 37 15
7 18-23 4.5 5.5 50 31
8 18-23 5.5 6.5 63 16
9 18-23 6.5 7.5 74 25
10 18-23 7.5 9 85 13
11 18-23 9 13 95 20
12 24-27 -13 -1 6 18
13 24-27 -1 1 16 13
14 24-27 1 2.5 25 15
15 24-27 2.5 3.5 35 14
16 24-27 3.5 4.5 46 19
17 24-27 4.5 5.5 56 13
18 24-27 5.5 6.5 68 22
19 24-27 6.5 7.5 78 9
20 24-27 7.5 9 87 18
21 24-27 9 13 97 11
22 28-33 -13 -1 4 15
23 28-33 -1 1 14 17
24 28-33 1 2.5 24 18
25 28-33 2.5 3.5 35 20
26 28-33 3.5 4.5 47 19
27 28-33 4.5 5.5 58 17
28 28-33 5.5 6.5 68 18
29 28-33 6.5 7.5 78 15
30 28-33 7.5 9 87 17
31 28-33 9 13 97 13
32 34-42 -13 -1 7 24
33 34-42 -1 1 22 23
34 34-42 1 2.5 34 18
35 34-42 2.5 3.5 45 16
36 34-42 3.5 4.5 56 18
37 34-42 4.5 5.5 67 16
38 34-42 5.5 6.5 76 14
39 34-42 6.5 7.5 85 14
40 34-42 7.5 9 92 10
41 34-42 9 13 98 8
42 43-73 -13 -1 5 16
43 43-73 -1 1 15 16
44 43-73 1 2.5 25 14
45 43-73 2.5 3.5 36 18
46 43-73 3.5 4.5 45 12
47 43-73 4.5 5.5 54 15
48 43-73 5.5 6.5 63 12
49 43-73 6.5 7.5 71 12
50 43-73 7.5 9 83 27
51 43-73 9 13 96 12
52 gesamt -13 -1 5 86
53 gesamt -1 1 16 82
54 gesamt 1 2.5 26 83
55 gesamt 2.5 3.5 36 82
56 gesamt 3.5 4.5 46 83
57 gesamt 4.5 5.5 57 92
58 gesamt 5.5 6.5 67 82
59 gesamt 6.5 7.5 77 75
60 gesamt 7.5 9 87 85
61 gesamt 9 13 96 64
62 18-23 M SD 4.9 3.7
63 24-27 M SD 4.2 4.1
64 28-33 M SD 4.5 3.6
65 34-42 M SD 3.4 3.8
66 43-73 M SD 4.3 4.3
67 gesamt M SD 4.3 3.9

View file

@ -0,0 +1,49 @@
altersgruppe,intervall_von,intervall_bis,prozentrang,n
18-23,-11.5,-3.5,7,28
18-23,-3.5,-1.5,23,33
18-23,-1.5,-0.5,40,31
18-23,-0.5,1,56,28
18-23,1,2,69,19
18-23,2,4.5,81,26
18-23,4.5,13,91,23
24-27,-11.5,-3.5,9,25
24-27,-3.5,-1.5,26,21
24-27,-1.5,-0.5,41,17
24-27,-0.5,1,53,17
24-27,1,2,65,14
24-27,2,4.5,79,24
24-27,4.5,13,94,16
28-33,-11.5,-3.5,6,19
28-33,-3.5,-1.5,23,26
28-33,-1.5,-0.5,38,15
28-33,-0.5,1,54,31
28-33,1,2,71,16
28-33,2,4.5,84,18
28-33,4.5,13,95,14
34-42,-11.5,-3.5,3,8
34-42,-3.5,-1.5,13,10
34-42,-1.5,-0.5,23,9
34-42,-0.5,1,36,17
34-42,1,2,52,14
34-42,2,4.5,72,25
34-42,4.5,13,93,15
43-73,-11.5,-3.5,10,34
43-73,-3.5,-1.5,27,27
43-73,-1.5,-0.5,41,21
43-73,-0.5,1,56,29
43-73,1,2,70,17
43-73,2,4.5,80,19
43-73,4.5,13,93,25
gesamt,-11.5,-3.5,8,114
gesamt,-3.5,-1.5,23,117
gesamt,-1.5,-0.5,38,93
gesamt,-0.5,1,53,122
gesamt,1,2,66,80
gesamt,2,4.5,80,112
gesamt,4.5,13,94,93
18-23,M,SD,0.2,3.6
24-27,M,SD,0.2,3.7
28-33,M,SD,0.4,3.1
34-42,M,SD,1.5,3.4
43-73,M,SD,0.1,4.0
gesamt,M,SD,0.4,3.6
1 altersgruppe intervall_von intervall_bis prozentrang n
2 18-23 -11.5 -3.5 7 28
3 18-23 -3.5 -1.5 23 33
4 18-23 -1.5 -0.5 40 31
5 18-23 -0.5 1 56 28
6 18-23 1 2 69 19
7 18-23 2 4.5 81 26
8 18-23 4.5 13 91 23
9 24-27 -11.5 -3.5 9 25
10 24-27 -3.5 -1.5 26 21
11 24-27 -1.5 -0.5 41 17
12 24-27 -0.5 1 53 17
13 24-27 1 2 65 14
14 24-27 2 4.5 79 24
15 24-27 4.5 13 94 16
16 28-33 -11.5 -3.5 6 19
17 28-33 -3.5 -1.5 23 26
18 28-33 -1.5 -0.5 38 15
19 28-33 -0.5 1 54 31
20 28-33 1 2 71 16
21 28-33 2 4.5 84 18
22 28-33 4.5 13 95 14
23 34-42 -11.5 -3.5 3 8
24 34-42 -3.5 -1.5 13 10
25 34-42 -1.5 -0.5 23 9
26 34-42 -0.5 1 36 17
27 34-42 1 2 52 14
28 34-42 2 4.5 72 25
29 34-42 4.5 13 93 15
30 43-73 -11.5 -3.5 10 34
31 43-73 -3.5 -1.5 27 27
32 43-73 -1.5 -0.5 41 21
33 43-73 -0.5 1 56 29
34 43-73 1 2 70 17
35 43-73 2 4.5 80 19
36 43-73 4.5 13 93 25
37 gesamt -11.5 -3.5 8 114
38 gesamt -3.5 -1.5 23 117
39 gesamt -1.5 -0.5 38 93
40 gesamt -0.5 1 53 122
41 gesamt 1 2 66 80
42 gesamt 2 4.5 80 112
43 gesamt 4.5 13 94 93
44 18-23 M SD 0.2 3.6
45 24-27 M SD 0.2 3.7
46 28-33 M SD 0.4 3.1
47 34-42 M SD 1.5 3.4
48 43-73 M SD 0.1 4.0
49 gesamt M SD 0.4 3.6

2879
BIFL/renv.lock Normal file

File diff suppressed because it is too large Load diff

14
BIFL/setup_renv.R Normal file
View file

@ -0,0 +1,14 @@
# Einmalig ausfuehren, bevor die App zum ersten Mal gestartet wird.
# Initialisiert renv und installiert alle benoetigten Pakete.
#
# DBI und RSQLite werden vom gesourcten Pseudonym-Skript benoetigt,
# nicht direkt von der App selbst.
renv::init()
pkgs = c("shiny", "dplyr", "ggplot2", "haven", "officer", "DBI", "RSQLite")
install.packages(pkgs)
renv::snapshot()
message("Setup abgeschlossen. App starten mit: shiny::runApp()")