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