server/DiagnostikApps
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit

Browse source
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
Download patch file Download diff file Expand all files Collapse all files

BIN
GBB/.RData Normal file
View file

Binary file not shown.

1
GBB/.Rprofile Normal file
View file

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

13
GBB/GBB.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

720
GBB/app.R Normal file
View file

@ -0,0 +1,720 @@
# Präambel ####
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_gbb.R"
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
AKZENT_FARBE = "#8B2635"
GBB_DISCLAIMER = paste0(
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
"keine klinische Diagnose. Es handelt sich um einen reinen Populationsvergleich ohne ",
"definierten Cutoff. Die Interpretation obliegt der behandelnden Person."
)
# Referenzwerte nach Braehler & Scheer (1995), siehe auswertung_normen_gbb.md.
# Kein Cutoff - reiner Populationsvergleich (M +/- 1 SD je Stichprobe).
GBB_REFERENZ = data.frame(
key = c("erschoepfung", "magen", "gliederschmerzen", "herzbeschwerden", "beschwerdedruck"),
label = c("Erschöpfung", "Magenbeschwerden", "Gliederschmerzen", "Herzbeschwerden",
"Beschwerdedruck (Gesamt)"),
range_max = c(24, 24, 24, 24, 96),
norm_m = c(4.61, 2.69, 5.40, 2.97, 15.66),
norm_sd = c(4.43, 3.27, 4.83, 3.58, 13.25),
pat_m = c(9.68, 5.40, 7.17, 6.55, 28.81),
pat_sd = c(6.35, 4.86, 5.70, 5.29, 17.86),
stringsAsFactors = FALSE
)
# Item-zu-Subskala-Zuordnung, je 6 Items, Range 0-24 je Subskala.
GBB_ERSCHOEPFUNG_ITEMS = c(1, 7, 29, 32, 36, 42)
GBB_MAGENBESCHWERDEN_ITEMS = c(3, 15, 18, 23, 25, 51)
GBB_GLIEDERSCHMERZEN_ITEMS = c(9, 11, 13, 27, 41, 55)
GBB_HERZBESCHWERDEN_ITEMS = c(2, 10, 20, 45, 52, 56)
GBB_SUBSKALEN_ITEMS = list(
erschoepfung = GBB_ERSCHOEPFUNG_ITEMS,
magen = GBB_MAGENBESCHWERDEN_ITEMS,
gliederschmerzen = GBB_GLIEDERSCHMERZEN_ITEMS,
herzbeschwerden = GBB_HERZBESCHWERDEN_ITEMS
)
library(shiny)
library(dplyr)
library(ggplot2)
library(haven)
library(officer)
library(DBI)
library(RSQLite)
# Infrastruktur ####
APP_VERZEICHNIS = normalizePath(getwd())
absPath = function(pfad) {
if (grepl("^([A-Za-z]:[/\\\\]|/)", pfad)) return(pfad)
file.path(APP_VERZEICHNIS, pfad)
}
PFAD_DOWNLOAD_SKRIPT = normalizePath(absPath(PFAD_DOWNLOAD_SKRIPT), mustWork = FALSE)
PFAD_PSEUDONYM_SKRIPT = normalizePath(absPath(PFAD_PSEUDONYM_SKRIPT), mustWork = FALSE)
# Helper ####
# Stufe (0-4) eines GBB-Items aus dem Rohwert ableiten. Das labels-Attribut wird
# bewusst von der ORIGINAL-Spalte (daten_gbb[[var]]) gelesen, nicht von einer
# gefilterten/subgesetteten Zeile, da das Attribut beim Subsetting verloren gehen
# kann. Die zu "nicht" gehoerende Zahl ist die Anker-Null, nie fest angenommen.
# Kein Rateversuch bei fehlendem "nicht"-Label: Fehler statt stillschweigend
# falscher Rechnung.
gbb_get_stufe = function(original_col, wert, bezeichnung) {
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) {
return(list(stufe = NA_integer_, warnung = NULL))
}
lbl_attr = attr(original_col, "labels")
if (is.null(lbl_attr) || length(lbl_attr) == 0 || !("nicht" %in% names(lbl_attr))) {
stop(paste0("Labels für ", bezeichnung, " nicht wie erwartet"))
}
anker_null = as.numeric(lbl_attr[["nicht"]])
stufe = as.numeric(wert[1]) - anker_null
warnung = NULL
if (is.na(stufe) || stufe < 0 || stufe > 4) {
warnung = paste0(
"Abgeleitete Stufe für ", bezeichnung, " (", stufe,
") liegt außerhalb des erwarteten Bereichs 0-4 - bitte Datengrundlage prüfen."
)
}
list(stufe = as.integer(round(stufe)), warnung = warnung)
}
# Wrapper um gbb_get_stufe, der den stop()-Fehlerfall (fehlendes "nicht"-Label)
# in ein Ergebnis-Feld statt eine R-Exception umwandelt, damit der Aufrufer im
# Server (eventReactive) sauber per return() abbrechen kann.
gbb_sicher_stufe = function(original_col, wert, bezeichnung) {
tryCatch(
gbb_get_stufe(original_col, wert, bezeichnung),
error = function(e) list(stufe = NA_integer_, warnung = NULL, fehler = e$message)
)
}
# Entfernt die fuehrende Itemnummer samt Punkt (und ggf. Escape-Backslash vor dem
# Punkt) aus dem label-Attribut, da Nummer und Wortlaut in der UI getrennt
# (item-nr / item-text) angezeigt werden.
gbb_clean_item_label = function(text) {
if (is.null(text) || length(text) == 0 || is.na(text[1])) return(NA_character_)
x = trimws(as.character(text[1]))
x = sub("^\\d+\\\\?\\.\\s*", "", x)
trimws(x)
}
# Horizontale Populationsvergleichs-Grafik: M +/- 1 SD von Normstichprobe und
# Patientenstichprobe als getrennt eingefaerbte, unterschiedlich gezeichnete
# Baender (kein Cutoff), individueller Wert als hervorgehobene vertikale Markierung.
make_gauge_gbb = function(range_max, norm_m, norm_sd, pat_m, pat_sd, wert) {
norm_von = max(0, norm_m - norm_sd)
norm_bis = min(range_max, norm_m + norm_sd)
pat_von = max(0, pat_m - pat_sd)
pat_bis = min(range_max, pat_m + pat_sd)
p = ggplot() +
geom_rect(aes(xmin = 0, xmax = range_max, ymin = 0, ymax = 1),
fill = NA, color = "#9E9E9E", linewidth = 0.5) +
geom_segment(aes(x = norm_von, xend = norm_bis, y = 0.68, yend = 0.68),
color = "#2E7D32", linewidth = 3, lineend = "round") +
geom_point(aes(x = norm_m, y = 0.68), color = "#2E7D32", size = 2.6) +
geom_segment(aes(x = pat_von, xend = pat_bis, y = 0.32, yend = 0.32),
color = "#5E35B1", linewidth = 3, lineend = "round", linetype = "22") +
geom_point(aes(x = pat_m, y = 0.32), color = "#5E35B1", size = 2.6, shape = 17) +
annotate("text", x = range_max, y = 0.86, label = "Normstichprobe (M±1SD)",
hjust = 1, size = 3, color = "#2E7D32") +
annotate("text", x = range_max, y = 0.14, label = "Psychosom. Patient:innen (M±1SD)",
hjust = 1, size = 3, color = "#5E35B1") +
scale_x_continuous(limits = c(-0.03 * range_max, 1.03 * range_max),
breaks = c(0, range_max)) +
scale_y_continuous(limits = c(-0.1, 1.35)) +
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 = paste0("Rohwert (0-", range_max, ")"), y = NULL)
if (!is.na(wert)) {
p = p +
geom_segment(aes(x = wert, xend = wert, y = -0.05, yend = 1.05),
color = AKZENT_FARBE, linewidth = 2.5) +
geom_label(aes(x = wert, y = 1.22, label = paste0("Wert: ", wert)),
fill = AKZENT_FARBE, color = "white", fontface = "bold",
linewidth = 0, size = 3.8)
}
p
}
# 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; }
#download_word {
background: #8B2635; color: white; border: none;
font-weight: 600; padding: 8px 20px; border-radius: 4px;
}
#download_word:hover { background: #6d1e29; color: white; }
.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; }
.score-zahl { font-size: 2rem; font-weight: 800; color: #8B2635; }
.info-text { font-size: 0.82em; color: #777; font-style: italic; margin-top: 8px; }
.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-liste-titel {
cursor: pointer; color: #555; font-size: 0.88em; margin-top: 4px; display: inline-block;
}
.item-zeile {
display: flex; align-items: flex-start; gap: 10px;
padding: 6px 0; border-bottom: 1px solid #F0F0F0;
}
.item-nr { font-weight: 600; color: #8B2635; min-width: 30px; flex-shrink: 0; }
.item-text { flex: 1; color: #333; font-size: 0.92em; }
.stufe-badge {
border-radius: 4px; padding: 2px 9px; font-weight: 700;
font-size: 0.82em; white-space: nowrap; display: inline-block; flex-shrink: 0;
min-width: 22px; text-align: center;
}
.stufe-badge-na { background: #E0E0E0; color: #757575; font-style: italic; font-weight: 500; }
.stufe-badge-0 { background: #2E7D32; color: white; }
.stufe-badge-1 { background: #C0CA33; color: #333333; }
.stufe-badge-2 { background: #FB8C00; color: white; }
.stufe-badge-3 { background: #D84315; color: white; }
.stufe-badge-4 { background: #8B2635; color: white; }
"
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("Gießener Beschwerdebogen (GBB)"),
tags$p("Subskalen-Auswertung und Populationsvergleich | Brähler & Scheer 1995")
),
div(class = "container-fluid",
div(class = "input-panel",
div(style = "min-width: 360px; white-space: nowrap;",
textInput("pseudonym",
label = tagList(
"Pseudonym",
tags$span(style = "font-weight: normal; font-style: italic; font-size: 0.78em; color: #888; margin-left: 4px; white-space: nowrap;",
"optional, hat Vorrang vor Chiffre")
),
placeholder = "optional", width = "340px")
),
div(style = "min-width: 200px;",
textInput("chiffre", label = "Patientenchiffre",
placeholder = "z.B. P000123", width = "100%")
),
actionButton("btn_suchen", "Auswerten", class = "btn btn-primary btn-laden"),
div(style = "margin-left: auto;",
downloadButton("download_word", "Word-Export (.docx)")
)
),
uiOutput("fehler_ui"),
uiOutput("warnung_ui"),
uiOutput("ergebnis_ui")
)
)
# Word-Export ####
erstelle_gbb_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_klein = fp_text(font.size = 9, color = "#666666")
fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
fp_warn = fp_text(font.size = 10, italic = TRUE, color = "#BF360C")
fp_wert = fp_text(bold = TRUE, font.size = 12, color = AKZENT_FARBE)
doc = body_add_fpar(doc, fpar(ftext("Gießener Beschwerdebogen (GBB) - Auswertung", fp_titel)))
doc = body_add_fpar(doc, fpar(
ftext("Chiffre: ", fp_label), ftext(erg$chiffre, fp_normal),
ftext(" Ausfülldatum: ", fp_label), ftext(erg$datum_str, fp_normal)
))
for (w in erg$warnungen) {
doc = body_add_fpar(doc, fpar(ftext(w, fp_warn)))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Subskalen und Populationsvergleich", fp_abschnitt)))
for (i in seq_len(nrow(erg$subskalen))) {
sub = erg$subskalen[i, ]
wert_txt = if (is.na(sub$summe)) "k. A." else as.character(sub$summe)
doc = body_add_fpar(doc, fpar(
ftext(paste0(sub$label, ": "), fp_label),
ftext(paste0(wert_txt, " / ", sub$range_max), fp_wert)
))
doc = body_add_fpar(doc, fpar(ftext(
paste0(
"Normstichprobe (N=1601): M=", sub$norm_m, " SD=", sub$norm_sd,
" | Psychosom. Patient:innen (N=4076): M=", sub$pat_m, " SD=", sub$pat_sd
), fp_klein
)))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Körperlich vs. seelisch", fp_abschnitt)))
doc = body_add_fpar(doc, fpar(
ftext("Körperliche Beschwerden (0-4): ", fp_label),
ftext(if (is.na(erg$koerperlich_stufe)) "k. A." else as.character(erg$koerperlich_stufe), fp_normal),
ftext(" Seelisches Befinden (0-4): ", fp_label),
ftext(if (is.na(erg$seelisch_stufe)) "k. A." else as.character(erg$seelisch_stufe), fp_normal)
))
doc = body_add_par(doc, "", style = "Normal")
zusatz_idx = which(!is.na(erg$zusatz_texte))
if (length(zusatz_idx) > 0) {
doc = body_add_fpar(doc, fpar(ftext("Freitext-Zusatzbeschwerden", fp_abschnitt)))
for (i in zusatz_idx) {
stufe_txt = if (is.na(erg$zusatz_stufen[i])) "k. A." else as.character(erg$zusatz_stufen[i])
doc = body_add_fpar(doc, fpar(
ftext(paste0(erg$zusatz_texte[i], " - Stärke: "), fp_normal),
ftext(stufe_txt, fp_wert)
))
}
doc = body_add_par(doc, "", style = "Normal")
}
doc = body_add_fpar(doc, fpar(ftext(GBB_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)))
}
})
# Skripte werden NICHT beim App-Start gesourct, nur beim Klick auf "Auswerten".
ergebnis_r = eventReactive(input$btn_suchen, {
chiffre = toupper(trimws(input$chiffre))
if (nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0) {
return(list(typ = "leere_eingabe", meldung = "Bitte Chiffre oder Pseudonym eingeben."))
}
if (nchar(trimws(input$pseudonym)) == 0 && !grepl("^[A-Z][0-9]{6}$", chiffre)) {
return(list(typ = "format_fehler", chiffre = chiffre))
}
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
return(list(typ = "skript_fehler",
meldung = paste0("Download-Skript nicht gefunden unter:\n", PFAD_DOWNLOAD_SKRIPT)))
}
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
return(list(typ = "skript_fehler",
meldung = paste0("Pseudonym-Skript nicht gefunden unter:\n", PFAD_PSEUDONYM_SKRIPT)))
}
ok = tryCatch({
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
list(ok = TRUE)
}, error = function(e) list(ok = FALSE, msg = e$message))
if (!ok$ok) return(list(typ = "skript_fehler", meldung = paste0("Fehler im Download-Skript: ", ok$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
})
if (is.null(db_ordner)) {
return(list(typ = "skript_fehler", meldung = paste0(
"pseudonyme.db nicht gefunden. Gesucht ausgehend vom Pseudonym-Skript-Ordner ",
"bis zu 5 Ebenen nach oben."
)))
}
alter_wd = getwd()
on.exit(setwd(alter_wd), add = TRUE)
setwd(db_ordner)
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(typ = "skript_fehler", meldung = paste0("Fehler im Pseudonym-Skript: ", ok_ps$msg)))
if (!exists("daten_gbb", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = "Objekt 'daten_gbb' wurde nach dem Sourcen des Download-Skripts nicht gefunden."))
}
if (!exists("pseudo", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = "Objekt 'pseudo' wurde nach dem Sourcen des Pseudonym-Skripts nicht gefunden."))
}
daten = get("daten_gbb", envir = .GlobalEnv)
pseudo_df = get("pseudo", envir = .GlobalEnv)
warnungen = c()
pseudonym_wert = trimws(input$pseudonym)
# Wenn Pseudonym eingegeben wurde: Chiffre daraus zurueckerhalten, damit
# Kopfzeile/Dateiname auch bei reiner Pseudonym-Eingabe korrekt sind.
if (nchar(pseudonym_wert) > 0) {
pw_treffer = pseudo_df[pseudo_df$pseudonym == pseudonym_wert, ]
if (nrow(pw_treffer) == 0) {
return(list(typ = "pseudonym_unbekannt", meldung = paste0(
"Pseudonym '", pseudonym_wert, "' wurde in der Pseudonym-Datenbank nicht gefunden."
)))
}
chiffre = toupper(trimws(pw_treffer$chiffre[1]))
}
treffer_ps = pseudo_df[pseudo_df$chiffre == chiffre, ]
if (nrow(treffer_ps) == 0) {
return(list(typ = "chiffre_unbekannt", meldung = paste0(
"Chiffre '", chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden."
)))
}
alle_session_ids = unique(treffer_ps$pseudonym)
# Eindeutigkeits-Override: explizit eingegebenes Pseudonym hat immer Vorrang.
if (nchar(pseudonym_wert) > 0) {
alle_session_ids = pseudonym_wert
}
treffer_dat = daten[daten$session %in% alle_session_ids, ]
if (nrow(treffer_dat) == 0) {
return(list(typ = "kein_datensatz", meldung = paste0(
"Kein GBB-Datensatz für Chiffre '", chiffre, "' gefunden. ",
"(", length(alle_session_ids), " Sitzungskennung(en) geprüft)"
)))
}
if (nrow(treffer_dat) > 1) {
n = nrow(treffer_dat)
sortier_wert = tryCatch(as.POSIXct(treffer_dat$created), error = function(e) treffer_dat$created)
treffer_dat = treffer_dat[order(sortier_wert, decreasing = TRUE), ]
datum_neu = tryCatch(
format(as.POSIXct(treffer_dat$created[1]), "%d.%m.%Y %H:%M"),
error = function(e) as.character(treffer_dat$created[1])
)
warnungen = c(warnungen, paste0(
"Mehrere Ausfüllungen gefunden (", n, " Einträge). 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) as.character(zeile$created[1])
)
# --- 57 Kernitems: Stufe 0-4 je Item ableiten ---
item_stufen = setNames(rep(NA_integer_, 57), paste0("gbb_", sprintf("%02d", 1:57)))
item_texte = rep(NA_character_, 57)
for (i in 1:57) {
var = paste0("gbb_", sprintf("%02d", i))
res = gbb_sicher_stufe(daten[[var]], zeile[[var]][1], paste0("Item ", i))
if (!is.null(res$fehler)) return(list(typ = "daten_fehler", meldung = res$fehler))
item_stufen[[var]] = res$stufe
if (!is.null(res$warnung)) warnungen = c(warnungen, res$warnung)
item_texte[i] = gbb_clean_item_label(attr(daten[[var]], "label"))
}
# --- Subskalen (4 x 6 Items, Range 0-24) + Beschwerdedruck (Summe, Range 0-96) ---
subskalen = GBB_REFERENZ
subskalen$summe = NA_real_
for (i in seq_len(nrow(subskalen))) {
key = subskalen$key[i]
if (key == "beschwerdedruck") next
items_key = GBB_SUBSKALEN_ITEMS[[key]]
werte = sapply(items_key, function(nr) item_stufen[[paste0("gbb_", sprintf("%02d", nr))]])
if (any(is.na(werte))) {
warnungen = c(warnungen, paste0(
"Subskala '", subskalen$label[i], "' unvollständig (fehlende Itemwerte) - Summenscore nicht berechnet."
))
}
subskalen$summe[i] = sum(werte)
}
subskalen$summe[subskalen$key == "beschwerdedruck"] =
sum(subskalen$summe[subskalen$key != "beschwerdedruck"])
# --- Körperlich vs. seelisch (reine Anzeige, keine Verrechnung) ---
res_koerp = gbb_sicher_stufe(daten[["gbb_koerperlich"]], zeile[["gbb_koerperlich"]][1], "gbb_koerperlich")
if (!is.null(res_koerp$fehler)) return(list(typ = "daten_fehler", meldung = res_koerp$fehler))
koerperlich_stufe = res_koerp$stufe
if (!is.null(res_koerp$warnung)) warnungen = c(warnungen, res_koerp$warnung)
res_seel = gbb_sicher_stufe(daten[["gbb_seelisch"]], zeile[["gbb_seelisch"]][1], "gbb_seelisch")
if (!is.null(res_seel$fehler)) return(list(typ = "daten_fehler", meldung = res_seel$fehler))
seelisch_stufe = res_seel$stufe
if (!is.null(res_seel$warnung)) warnungen = c(warnungen, res_seel$warnung)
# --- Freitext-Zusatzbeschwerden: nur befuellt wenn zugehoeriger Freitext nicht leer ist ---
zusatz_texte = rep(NA_character_, 5)
zusatz_stufen = rep(NA_integer_, 5)
for (i in 1:5) {
txt_var = paste0("gbb_zusatz_", sprintf("%02d", i), "_text")
wert_var = paste0("gbb_zusatz_", sprintf("%02d", i))
txt_roh = zeile[[txt_var]][1]
txt_ok = !is.null(txt_roh) && !is.na(txt_roh) && nchar(trimws(as.character(txt_roh))) > 0
if (txt_ok) {
zusatz_texte[i] = trimws(as.character(txt_roh))
res_z = gbb_sicher_stufe(daten[[wert_var]], zeile[[wert_var]][1], paste0("Zusatzbeschwerde ", i))
if (!is.null(res_z$fehler)) return(list(typ = "daten_fehler", meldung = res_z$fehler))
zusatz_stufen[i] = res_z$stufe
if (!is.null(res_z$warnung)) warnungen = c(warnungen, res_z$warnung)
}
}
list(
typ = "ok",
chiffre = chiffre,
datum_str = datum_str,
warnungen = warnungen,
subskalen = subskalen,
koerperlich_stufe = koerperlich_stufe,
seelisch_stufe = seelisch_stufe,
zusatz_texte = zusatz_texte,
zusatz_stufen = zusatz_stufen,
item_texte = item_texte,
item_stufen = item_stufen
)
})
lapply(GBB_REFERENZ$key, function(key) {
local({
k = key
output_id = paste0("gauge_", k)
output[[output_id]] = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(identical(d$typ, "ok"))
sub = d$subskalen[d$subskalen$key == k, ]
make_gauge_gbb(sub$range_max, sub$norm_m, sub$norm_sd, sub$pat_m, sub$pat_sd, sub$summe)
}, bg = "transparent")
})
})
output$fehler_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (identical(d$typ, "ok")) return(NULL)
txt = switch(d$typ,
"leere_eingabe" = d$meldung,
"format_fehler" = paste0(
"Ungültige Chiffre '", d$chiffre, "'. Erwartet: ein Großbuchstabe + 6 Ziffern (z.B. P000123)."
),
d$meldung
)
div(class = "alert-fehler", txt)
})
output$warnung_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (!identical(d$typ, "ok") || length(d$warnungen) == 0) return(NULL)
div(lapply(d$warnungen, function(w) div(class = "alert-warnung", w)))
})
output$ergebnis_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (!identical(d$typ, "ok")) return(NULL)
subskalen_ui = lapply(seq_len(nrow(d$subskalen)), function(i) {
sub = d$subskalen[i, ]
wert_txt = if (is.na(sub$summe)) "k. A." else as.character(sub$summe)
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", sub$label),
fluidRow(
column(3,
div(class = "score-zahl", wert_txt),
div(paste0("Rohwert (0-", sub$range_max, ")"), style = "color:#555;")
),
column(9, plotOutput(paste0("gauge_", sub$key), height = "130px"))
),
div(class = "info-text",
"Populationsvergleich zu Normstichprobe und psychosomatischen Patient:innen - kein Cutoff, keine klinische Einordnung."
)
)
})
koerp_seel_block = div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Körperlich vs. seelisch"),
div(class = "kontext-zeile",
div(class = "kontext-label", "Körperliche Beschwerden (0-4):"),
div(if (is.na(d$koerperlich_stufe)) "k. A." else as.character(d$koerperlich_stufe))
),
div(class = "kontext-zeile",
div(class = "kontext-label", "Seelisches Befinden (0-4):"),
div(if (is.na(d$seelisch_stufe)) "k. A." else as.character(d$seelisch_stufe))
)
)
zusatz_idx = which(!is.na(d$zusatz_texte))
zusatz_block = if (length(zusatz_idx) > 0) {
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Freitext-Zusatzbeschwerden"),
lapply(zusatz_idx, function(i) {
badge_key = if (is.na(d$zusatz_stufen[i])) "na" else as.character(d$zusatz_stufen[i])
wert_txt = if (is.na(d$zusatz_stufen[i])) "k. A." else as.character(d$zusatz_stufen[i])
div(class = "item-zeile",
div(class = "item-text", d$zusatz_texte[i]),
span(class = paste0("stufe-badge stufe-badge-", badge_key), wert_txt)
)
})
)
} else NULL
items_roh_ui = div(class = "abschnitt-karte",
tags$details(
tags$summary(class = "item-liste-titel", "Alle 57 Kernitems roh"),
div(style = "margin-top: 10px;",
lapply(seq_len(57), function(i) {
stufe = d$item_stufen[i]
badge_key = if (is.na(stufe)) "na" else as.character(stufe)
wert_txt = if (is.na(stufe)) "k. A." else as.character(stufe)
txt = if (!is.na(d$item_texte[i])) d$item_texte[i] else paste0("Item ", i)
div(class = "item-zeile",
div(class = "item-nr", paste0(i, ".")),
div(class = "item-text", txt),
span(class = paste0("stufe-badge stufe-badge-", badge_key), wert_txt)
)
})
)
)
)
tagList(
div(class = "abschnitt-karte",
div(class = "meta-block",
tags$strong("Chiffre: "), d$chiffre,
tags$span(" | ", style = "color:#ccc;"),
tags$strong("Ausfülldatum: "), d$datum_str
)
),
subskalen_ui,
koerp_seel_block,
zusatz_block,
items_roh_ui
)
})
output$download_word = downloadHandler(
filename = function() {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
chiffre_esc = if (is.list(d) && identical(d$typ, "ok"))
gsub("[^A-Za-z0-9_-]", "_", d$chiffre) else "export"
ausfuelldatum_fn = if (is.list(d) && identical(d$typ, "ok") && !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("GBB_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
},
content = function(file) {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
daten_ok = is.list(d) && identical(d$typ, "ok")
if (!daten_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_gbb_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)

3019
GBB/renv.lock Normal file
View file

File diff suppressed because it is too large Load diff

14
GBB/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", "formr")
install.packages(pkgs)
renv::snapshot()
message("Setup abgeschlossen. App starten mit: shiny::runApp()")