1071 lines
38 KiB
R
1071 lines
38 KiB
R
# Präambel ####
|
||
|
||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_bsl.R" # liefert: daten_bsl
|
||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo
|
||
PFAD_NORMTABELLEN = "normtabellen"
|
||
AKZENT_FARBE = "#8B2635"
|
||
|
||
BSL_DISCLAIMER = paste0(
|
||
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
|
||
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ",
|
||
"Fuer die BSL liegt keine dokumentierte klinische Cutoff-Schwelle vor, es wird ",
|
||
"ausschliesslich der Prozentrang gegenueber der Referenzstichprobe berichtet."
|
||
)
|
||
|
||
BSL_KRITISCH_DISCLAIMER = paste0(
|
||
"Kein automatisiertes klinisches Urteil, ersetzt keine klinische Einschaetzung."
|
||
)
|
||
|
||
# 5 Antwortstufen 0-4 (ueberhaupt nicht ... sehr stark), Verlauf gruen -> dunkelrot,
|
||
# analog zu den anderen 5-stufigen Instrumenten dieser App-Familie (z.B. PG-13-R).
|
||
BSL_BADGE_FARBEN = c(
|
||
"0" = "#4CAF50",
|
||
"1" = "#F48FB1",
|
||
"2" = "#EF5350",
|
||
"3" = "#B71C1C",
|
||
"4" = "#4A0000"
|
||
)
|
||
BSL_BADGE_TEXT_FARBEN = c(
|
||
"0" = "white",
|
||
"1" = "#333333",
|
||
"2" = "white",
|
||
"3" = "white",
|
||
"4" = "white"
|
||
)
|
||
|
||
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)
|
||
PFAD_NORMTABELLEN = normalizePath(absPath(PFAD_NORMTABELLEN), mustWork = FALSE)
|
||
|
||
|
||
# Helper ####
|
||
|
||
# Antworttext -> Punktwert, Hauptitems (bsl_001-bsl_105, inkl. Items 96-105 die nur deskriptiv sind).
|
||
BSL_TEXT_STUFEN_HAUPT = c(
|
||
"überhaupt nicht" = 0L,
|
||
"ein wenig" = 1L,
|
||
"ziemlich" = 2L,
|
||
"stark" = 3L,
|
||
"sehr stark" = 4L
|
||
)
|
||
|
||
# Antworttext -> Punktwert, Ergaenzungsskala (bsl_erg_01-11).
|
||
BSL_TEXT_STUFEN_ERG = c(
|
||
"gar nicht" = 0L,
|
||
"1 mal" = 1L,
|
||
"2 mal" = 2L,
|
||
"täglich" = 3L,
|
||
"mehrmals täglich" = 4L
|
||
)
|
||
|
||
# formr liefert bei Itemtyp mc erwartungsgemaess den Antworttext, moeglicherweise aber
|
||
# je nach Instanz-Konfiguration einen 1-basierten numerischen Index (choice1 -> 1 ... choice5 -> 5).
|
||
# Beide Faelle werden hier robust abgedeckt; ein nicht erkannter Wert ergibt NA statt Raten.
|
||
bsl_recode_item = function(wert, ergaenzungsskala = FALSE) {
|
||
if (is.null(wert) || length(wert) == 0) return(NA_integer_)
|
||
w = wert[1]
|
||
if (is.na(w)) return(NA_integer_)
|
||
|
||
tabelle = if (isTRUE(ergaenzungsskala)) BSL_TEXT_STUFEN_ERG else BSL_TEXT_STUFEN_HAUPT
|
||
|
||
if (is.character(w) || is.factor(w)) {
|
||
txt = tolower(trimws(gsub("\\*\\*", "", as.character(w))))
|
||
pos = match(txt, tolower(trimws(names(tabelle))))
|
||
if (!is.na(pos)) return(as.integer(unname(tabelle[pos])))
|
||
|
||
# Fallback: Text ist tatsaechlich eine Zahl (z.B. weil als Zeichenkette exportiert).
|
||
if (grepl("^-?[0-9]+(\\.[0-9]+)?$", txt)) {
|
||
n = suppressWarnings(as.numeric(txt))
|
||
punkt = n - 1
|
||
if (!is.na(punkt) && punkt >= 0 && punkt <= 4) return(as.integer(round(punkt)))
|
||
}
|
||
return(NA_integer_)
|
||
}
|
||
|
||
if (is.numeric(w)) {
|
||
punkt = w - 1
|
||
if (!is.na(punkt) && punkt >= 0 && punkt <= 4) return(as.integer(round(punkt)))
|
||
return(NA_integer_)
|
||
}
|
||
|
||
NA_integer_
|
||
}
|
||
|
||
# Rueckrichtung: Punktwert (0-4) -> kanonischer Antworttext, unabhaengig davon ob die
|
||
# formr-Rohantwort ein Text oder ein numerischer Index war.
|
||
bsl_antwort_text = function(punktwert, ergaenzungsskala = FALSE) {
|
||
if (is.na(punktwert)) return(NA_character_)
|
||
tabelle = if (isTRUE(ergaenzungsskala)) BSL_TEXT_STUFEN_ERG else BSL_TEXT_STUFEN_HAUPT
|
||
pos = which(tabelle == punktwert)
|
||
if (length(pos) == 0) return(NA_character_)
|
||
names(tabelle)[pos[1]]
|
||
}
|
||
|
||
# range_ticks 0,100,10 liefert erwartungsgemaess direkt einen numerischen Wert 0-100.
|
||
# Defensive Pruefung, falls doch Text/NA/ausserhalb des Bereichs geliefert wird.
|
||
bsl_recode_vas = function(wert) {
|
||
if (is.null(wert) || length(wert) == 0) return(NA_real_)
|
||
w = wert[1]
|
||
if (is.na(w)) return(NA_real_)
|
||
n = suppressWarnings(as.numeric(as.character(w)))
|
||
if (is.na(n) || n < 0 || n > 100) return(NA_real_)
|
||
n
|
||
}
|
||
|
||
# Itemtext aus dem label-Attribut der Original-Spalte, falls formr/get_data_bsl.R eines
|
||
# mitliefert. Kein Rateergebnis: ohne Attribut wird ein generischer Fallback verwendet,
|
||
# es wird kein Wortlaut erfunden.
|
||
bsl_item_label = function(original_col, fallback) {
|
||
lbl = attr(original_col, "label")
|
||
if (is.null(lbl) || length(lbl) == 0 || is.na(lbl[1]) ||
|
||
nchar(trimws(as.character(lbl[1]))) == 0) {
|
||
return(fallback)
|
||
}
|
||
text = as.character(lbl[1])
|
||
text = gsub("\\*\\*", "", text) # Markdown-Bold-Sternchen entfernen
|
||
text = gsub("\\\\(.)", "\\1", text, perl = TRUE) # Markdown-Escapes (\\*, \\_, \\(, ...) aufloesen
|
||
# formr haengt im label-Attribut manchmal die Itemnummer voran (z.B. "1. " oder "96. ").
|
||
# Die App praefigiert die Nummer selbst separat vor dem Text, daher hier entfernen,
|
||
# sonst erscheint sie doppelt ("96. 96. ... Text").
|
||
text = sub("^\\d+[.)\\s]\\s*", "", trimws(text))
|
||
trimws(text)
|
||
}
|
||
|
||
# 7 Subskalen mit Item-Zuordnung, Reverse-Coding (nur Dysphorie) und Rohwert-Maximum.
|
||
BSL_SUBSKALEN = list(
|
||
selbstwahrnehmung = list(
|
||
name = "Selbstwahrnehmung",
|
||
items = c(1, 8, 12, 14, 15, 16, 17, 23, 33, 36, 43, 46, 54, 58, 61, 71, 75, 90, 92),
|
||
reverse = integer(0),
|
||
max = 76,
|
||
norm_key = "selbstwahrnehmung"
|
||
),
|
||
affektregulation = list(
|
||
name = "Affektregulation",
|
||
items = c(4, 10, 30, 31, 32, 42, 47, 50, 56, 70, 73, 83, 91),
|
||
reverse = integer(0),
|
||
max = 52,
|
||
norm_key = "affektregulation"
|
||
),
|
||
autoaggression = list(
|
||
name = "Autoaggression",
|
||
items = c(18, 22, 28, 35, 38, 62, 74, 82, 85, 87, 93, 94),
|
||
reverse = integer(0),
|
||
max = 48,
|
||
norm_key = "autoaggression"
|
||
),
|
||
dysphorie = list(
|
||
name = "Dysphorie",
|
||
items = c(5, 21, 26, 39, 55, 63, 68, 72, 80, 95),
|
||
reverse = c(21, 26, 39, 55, 63, 68, 72, 80, 95),
|
||
max = 40,
|
||
norm_key = "dysphorie"
|
||
),
|
||
soziale_isolation = list(
|
||
name = "Soziale Isolation",
|
||
items = c(3, 11, 13, 19, 24, 48, 51, 65, 69, 79, 84, 89),
|
||
reverse = integer(0),
|
||
max = 48,
|
||
norm_key = "soziale_isolation"
|
||
),
|
||
intrusionen = list(
|
||
name = "Intrusionen",
|
||
items = c(20, 25, 41, 44, 52, 57, 59, 66, 67, 78, 81),
|
||
reverse = integer(0),
|
||
max = 44,
|
||
norm_key = "intrusionen"
|
||
),
|
||
feindseligkeit = list(
|
||
name = "Feindseligkeit",
|
||
items = c(27, 40, 45, 53, 60, 64),
|
||
reverse = integer(0),
|
||
max = 24,
|
||
norm_key = "feindseligkeit"
|
||
)
|
||
)
|
||
|
||
# Dysphorie-Umpolitems gehen auch in die Gesamtskala mit dem umgepolten Wert ein (4 - Punktwert),
|
||
# Item 5 bleibt in beiden Faellen unumgepolt (bestaetigte Nutzerentscheidung, kein Rateergebnis).
|
||
BSL_DYSPHORIE_REVERSE = c(21, 26, 39, 55, 63, 68, 72, 80, 95)
|
||
|
||
# Items, die nur in die Gesamtskala einfliessen, in keine Subskala.
|
||
BSL_NUR_GESAMT_ITEMS = c(2, 6, 7, 9, 29, 34, 37, 49, 76, 77, 86, 88)
|
||
|
||
# Gesamtskala = Summe Items 1-95 (mit Umpolung der Dysphorie-Umpolitems).
|
||
BSL_GESAMT_ITEMS = 1:95
|
||
|
||
# Einzelitems 1-95, nach Subskala gruppiert (zusaetzlich zu den aggregierten Balken), rein
|
||
# deskriptiv: Antworttext ist die tatsaechlich gegebene (nicht umgepolte) Antwort, die Umpolung
|
||
# betrifft nur die Summenbildung in bsl_score_skala, nicht die Anzeige des Einzelitems.
|
||
bsl_gruppiere_hauptitems = function(haupt_punkte, daten) {
|
||
baue_item_liste = function(item_nrn) {
|
||
lapply(sort(item_nrn), function(i) {
|
||
col = paste0("bsl_", sprintf("%03d", i))
|
||
punkt = haupt_punkte[[as.character(i)]]
|
||
list(
|
||
nr = i,
|
||
text = bsl_item_label(daten[[col]], paste0("Item ", i)),
|
||
punktwert = punkt,
|
||
antwort = bsl_antwort_text(punkt, ergaenzungsskala = FALSE)
|
||
)
|
||
})
|
||
}
|
||
|
||
gruppen = lapply(BSL_SUBSKALEN, function(sk) {
|
||
list(titel = sk$name, items = baue_item_liste(sk$items))
|
||
})
|
||
gruppen[["nur_gesamt"]] = list(
|
||
titel = "Weitere Items (nur Gesamtskala, keiner Subskala zugeordnet)",
|
||
items = baue_item_liste(BSL_NUR_GESAMT_ITEMS)
|
||
)
|
||
gruppen
|
||
}
|
||
|
||
# Missing-Regel: > 10% fehlende Items je Skala -> nicht auswertbar (Rohwert = NA).
|
||
bsl_score_skala = function(item_nrn, werte_punkte, reverse_nrn = integer(0),
|
||
max_missing_anteil = 0.10) {
|
||
roh = sapply(item_nrn, function(i) {
|
||
p = werte_punkte[[as.character(i)]]
|
||
if (is.null(p) || is.na(p)) return(NA_integer_)
|
||
if (i %in% reverse_nrn) return(4L - as.integer(p))
|
||
as.integer(p)
|
||
})
|
||
anteil_fehlend = sum(is.na(roh)) / length(item_nrn)
|
||
auswertbar = anteil_fehlend <= max_missing_anteil
|
||
list(
|
||
rohwert = if (auswertbar) as.integer(sum(roh, na.rm = TRUE)) else NA_integer_,
|
||
anteil_fehlend = anteil_fehlend,
|
||
auswertbar = auswertbar
|
||
)
|
||
}
|
||
|
||
# Exakter Rohwert-Match gegen eine Normtabelle (Spalten: wert_spalte, prozentrang).
|
||
# Kein Interpolieren, kein Absturz bei fehlendem Rohwert (sollte bei voller Range nicht vorkommen).
|
||
bsl_norm_lookup = function(tabelle, rohwert, wert_spalte = "rohwert") {
|
||
if (is.null(tabelle) || is.null(rohwert) || length(rohwert) == 0 || is.na(rohwert)) {
|
||
return(NA_real_)
|
||
}
|
||
zeile = tabelle[tabelle[[wert_spalte]] == rohwert, , drop = FALSE]
|
||
if (nrow(zeile) == 0) return(NA_real_)
|
||
suppressWarnings(as.numeric(zeile$prozentrang[1]))
|
||
}
|
||
|
||
# Ein horizontaler ggplot2-Balken je Zeile (Gesamtskala + 7 Subskalen), Skala 0-100 (Prozentrang),
|
||
# bewusst ohne Referenzlinie. Beschriftung mit Rohwert und Prozentrang direkt am Balken.
|
||
bsl_profil_plot = function(gesamt, subskalen) {
|
||
reihen = c(
|
||
list(list(name = "Gesamtskala", daten = gesamt)),
|
||
lapply(subskalen, function(sk) list(name = sk$name, daten = sk))
|
||
)
|
||
|
||
namen = vapply(reihen, function(r) r$name, character(1))
|
||
pr = vapply(reihen, function(r) {
|
||
d = r$daten
|
||
if (d$auswertbar && !is.na(d$prozentrang)) d$prozentrang else 0
|
||
}, numeric(1))
|
||
label = vapply(reihen, function(r) {
|
||
d = r$daten
|
||
if (!d$auswertbar) return("nicht auswertbar (> 10% fehlende Werte)")
|
||
if (is.na(d$rohwert)) return("keine Angabe")
|
||
pr_txt = if (is.na(d$prozentrang)) "PR: k. A." else paste0("PR: ", round(d$prozentrang))
|
||
paste0(d$rohwert, " / ", d$max, " (", pr_txt, ")")
|
||
}, character(1))
|
||
|
||
df = data.frame(
|
||
name = factor(namen, levels = rev(namen)),
|
||
pr = pr,
|
||
label = label,
|
||
stringsAsFactors = FALSE
|
||
)
|
||
|
||
ggplot(df, aes(x = name, y = pr)) +
|
||
geom_col(fill = AKZENT_FARBE, width = 0.6) +
|
||
geom_text(aes(label = label), hjust = -0.02, size = 3.3, color = "#333333") +
|
||
coord_flip(clip = "off") +
|
||
scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 20),
|
||
expand = expansion(mult = c(0, 0.6))) +
|
||
labs(x = NULL, y = "Prozentrang") +
|
||
theme_minimal(base_size = 12) +
|
||
theme(
|
||
panel.grid.major.y = element_blank(),
|
||
panel.grid.minor = element_blank(),
|
||
plot.margin = margin(t = 5, r = 150, b = 5, l = 5)
|
||
)
|
||
}
|
||
|
||
# VAS-Prozentrang separat, gleiche Balkendarstellung wie die Subskalen.
|
||
bsl_vas_plot = function(vas) {
|
||
pr_val = if (!is.na(vas$prozentrang)) vas$prozentrang else 0
|
||
label = if (is.na(vas$rohwert)) {
|
||
"keine Angabe"
|
||
} else if (is.na(vas$prozentrang)) {
|
||
paste0(vas$rohwert, " / 100 (PR: k. A.)")
|
||
} else {
|
||
paste0(vas$rohwert, " / 100 (PR: ", round(vas$prozentrang), ")")
|
||
}
|
||
|
||
df = data.frame(
|
||
name = factor("VAS Gesamtbefindlichkeit"),
|
||
pr = pr_val,
|
||
label = label,
|
||
stringsAsFactors = FALSE
|
||
)
|
||
|
||
ggplot(df, aes(x = name, y = pr)) +
|
||
geom_col(fill = AKZENT_FARBE, width = 0.5) +
|
||
geom_text(aes(label = label), hjust = -0.02, size = 3.3, color = "#333333") +
|
||
coord_flip(clip = "off") +
|
||
scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 20),
|
||
expand = expansion(mult = c(0, 0.6))) +
|
||
labs(x = NULL, y = "Prozentrang") +
|
||
theme_minimal(base_size = 12) +
|
||
theme(
|
||
panel.grid.major.y = element_blank(),
|
||
panel.grid.minor = element_blank(),
|
||
plot.margin = margin(t = 5, r = 150, b = 5, l = 5)
|
||
)
|
||
}
|
||
|
||
# Deskriptive Itemliste (Ergaenzungsskala und Items 96-105): Stufen-Badge + Antworttext,
|
||
# kein Summenscore, keine Norm.
|
||
bsl_item_liste_ui = function(items) {
|
||
lapply(items, function(it) {
|
||
if (!is.na(it$punktwert)) {
|
||
sk = as.character(it$punktwert)
|
||
badge_text = if (!is.na(it$antwort)) it$antwort else as.character(it$punktwert)
|
||
} else {
|
||
sk = "na"
|
||
badge_text = "keine Angabe"
|
||
}
|
||
div(class = "item-zeile",
|
||
div(class = "item-nr", paste0(it$nr, ".")),
|
||
div(class = "item-text", it$text),
|
||
span(class = paste0("stufe-badge stufe-badge-", sk), badge_text)
|
||
)
|
||
})
|
||
}
|
||
|
||
|
||
# Datenaufbereitung ####
|
||
|
||
# 9 Normtabellen-CSVs, statisch beim App-Start geladen. Beim Fehlen einer Datei bricht die
|
||
# App mit einer klaren Fehlermeldung inkl. Dateiname ab, statt eine Tabelle stillschweigend
|
||
# zu ueberspringen.
|
||
BSL_NORM_DATEIEN = c(
|
||
gesamtskala = "gesamtskala.csv",
|
||
selbstwahrnehmung = "selbstwahrnehmung.csv",
|
||
affektregulation = "affektregulation.csv",
|
||
autoaggression = "autoaggression.csv",
|
||
dysphorie = "dysphorie.csv",
|
||
soziale_isolation = "soziale_isolation.csv",
|
||
intrusionen = "intrusionen.csv",
|
||
feindseligkeit = "feindseligkeit.csv",
|
||
vas = "vas_gesamtbefindlichkeit.csv"
|
||
)
|
||
|
||
bsl_lade_normtabellen = function(ordner, dateien) {
|
||
tabs = list()
|
||
for (nm in names(dateien)) {
|
||
pfad = file.path(ordner, dateien[[nm]])
|
||
if (!file.exists(pfad)) {
|
||
stop(paste0(
|
||
"Normtabelle fehlt: '", dateien[[nm]], "'. Erwartet unter: ", pfad, ". ",
|
||
"Bitte alle 9 Normtabellen-CSVs gemaess Vorgabe in den Ordner '", ordner,
|
||
"' legen, bevor die App gestartet wird."
|
||
))
|
||
}
|
||
tabs[[nm]] = read.csv(pfad, stringsAsFactors = FALSE)
|
||
}
|
||
tabs
|
||
}
|
||
|
||
BSL_NORMTABELLEN = bsl_lade_normtabellen(PFAD_NORMTABELLEN, BSL_NORM_DATEIEN)
|
||
|
||
|
||
# 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; }
|
||
.kritisch-block {
|
||
background: #6D0000; color: white; border-radius: 6px;
|
||
padding: 16px 20px; margin-bottom: 16px; border-left: 6px solid #FF6B6B;
|
||
}
|
||
.kritisch-block h4 { margin: 0 0 10px; font-size: 1.1rem; font-weight: 700; }
|
||
.kritisch-zeile {
|
||
background: rgba(255,255,255,0.12); border-radius: 3px;
|
||
padding: 8px 12px; margin: 6px 0; font-size: 0.92em; line-height: 1.5;
|
||
}
|
||
.kritisch-disclaimer {
|
||
margin-top: 10px; font-size: 0.82em; opacity: 0.85; font-style: italic;
|
||
}
|
||
.subskala-titel-item {
|
||
color: #8B2635; font-weight: 700; margin-top: 16px; margin-bottom: 4px;
|
||
font-size: 0.95em; border-bottom: 1px solid #eee; padding-bottom: 3px;
|
||
}
|
||
.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; }
|
||
.stufe-badge {
|
||
border-radius: 4px; padding: 2px 9px; font-weight: 700;
|
||
font-size: 0.82em; white-space: nowrap; display: inline-block; flex-shrink: 0;
|
||
}
|
||
.stufe-badge-0 { background: #4CAF50; color: white; }
|
||
.stufe-badge-1 { background: #F48FB1; color: #333333; }
|
||
.stufe-badge-2 { background: #EF5350; color: white; }
|
||
.stufe-badge-3 { background: #B71C1C; color: white; }
|
||
.stufe-badge-4 { background: #4A0000; color: white; }
|
||
.stufe-badge-na { background: #BBBBBB; 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("BSL-105 – Borderline Symptom Liste"),
|
||
tags$p("105-Item-Version | Einzelfall-Auswertung, ausschliesslich Prozentrang, kein Cutoff")
|
||
),
|
||
|
||
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("kritisch_ui"),
|
||
uiOutput("ergebnis_ui")
|
||
)
|
||
)
|
||
|
||
|
||
# Word-Export ####
|
||
|
||
# Eine Item-Zeile (Nummer + Text + Antwort-Badge) im Word-Dokument, wiederverwendet fuer
|
||
# Einzelitems 1-95, Ergaenzungsskala und Items 96-105.
|
||
bsl_docx_item_zeile = function(doc, it, fp_normal) {
|
||
stufe_key = if (!is.na(it$punktwert)) as.character(it$punktwert) else NA_character_
|
||
antwort_txt = if (!is.na(it$antwort)) it$antwort else "keine Angabe"
|
||
fp_badge = fp_text(
|
||
color = if (!is.na(stufe_key)) BSL_BADGE_TEXT_FARBEN[[stufe_key]] else "#333333",
|
||
bold = TRUE,
|
||
shading.color = if (!is.na(stufe_key)) BSL_BADGE_FARBEN[[stufe_key]] else "#BBBBBB",
|
||
font.size = 10
|
||
)
|
||
body_add_fpar(doc, fpar(
|
||
ftext(paste0(it$nr, ". ", it$text, " "), fp_normal),
|
||
ftext(paste0(" ", antwort_txt, " "), fp_badge)
|
||
))
|
||
}
|
||
|
||
erstelle_bsl_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, italic = TRUE, color = "#777777")
|
||
fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
|
||
fp_kritisch_titel = fp_text(color = "#B71C1C", bold = TRUE, font.size = 12)
|
||
fp_kritisch_text = fp_text(color = "#B71C1C", font.size = 10)
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("BSL-105 – 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, fp_normal)
|
||
))
|
||
if (length(erg$warnungen) > 0) {
|
||
for (w in erg$warnungen) {
|
||
doc = body_add_fpar(doc, fpar(ftext(w, fp_klein)))
|
||
}
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
if (length(erg$kritische_treffer) > 0) {
|
||
doc = body_add_fpar(doc, fpar(ftext("Kritische Items", fp_kritisch_titel)))
|
||
for (kt in erg$kritische_treffer) {
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext(paste0(kt$bezeichnung, ": ", kt$text), fp_kritisch_text)
|
||
))
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext(paste0("Antwort: ", kt$antwort, " (", kt$schwelle_txt, ")"), fp_kritisch_text)
|
||
))
|
||
}
|
||
doc = body_add_fpar(doc, fpar(ftext(BSL_KRITISCH_DISCLAIMER, fp_klein)))
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
}
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Gesamtskala", fp_abschnitt)))
|
||
ges = erg$gesamtskala
|
||
ges_txt = if (!ges$auswertbar) {
|
||
"nicht auswertbar (> 10% fehlende Werte)"
|
||
} else {
|
||
paste0(ges$rohwert, " / ", ges$max, " Prozentrang: ",
|
||
if (is.na(ges$prozentrang)) "k. A." else round(ges$prozentrang))
|
||
}
|
||
doc = body_add_fpar(doc, fpar(ftext(ges_txt, fp_normal)))
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Subskalen", fp_abschnitt)))
|
||
for (sk in erg$subskalen) {
|
||
sk_txt = if (!sk$auswertbar) {
|
||
"nicht auswertbar (> 10% fehlende Werte)"
|
||
} else {
|
||
paste0(sk$rohwert, " / ", sk$max, " Prozentrang: ",
|
||
if (is.na(sk$prozentrang)) "k. A." else round(sk$prozentrang))
|
||
}
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext(paste0(sk$name, ": "), fp_label),
|
||
ftext(sk_txt, fp_normal)
|
||
))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("VAS Gesamtbefindlichkeit", fp_abschnitt)))
|
||
vas_txt = if (is.na(erg$vas$rohwert)) {
|
||
"keine Angabe"
|
||
} else {
|
||
paste0(erg$vas$rohwert, " / 100 Prozentrang: ",
|
||
if (is.na(erg$vas$prozentrang)) "k. A." else round(erg$vas$prozentrang))
|
||
}
|
||
doc = body_add_fpar(doc, fpar(ftext(vas_txt, fp_normal)))
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Einzelitems 1–95 (nach Subskala gruppiert)", fp_abschnitt)))
|
||
for (gruppe in erg$haupt_items) {
|
||
doc = body_add_fpar(doc, fpar(ftext(gruppe$titel, fp_label)))
|
||
for (it in gruppe$items) {
|
||
doc = bsl_docx_item_zeile(doc, it, fp_normal)
|
||
}
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Ergänzungsskala (deskriptiv, kein Summenscore)", fp_abschnitt)))
|
||
for (it in erg$ergaenzung_items) {
|
||
doc = bsl_docx_item_zeile(doc, it, fp_normal)
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Items 96–105 (deskriptiv, kein Summenscore)", fp_abschnitt)))
|
||
for (it in erg$item_96_105) {
|
||
doc = bsl_docx_item_zeile(doc, it, fp_normal)
|
||
}
|
||
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
doc = body_add_fpar(doc, fpar(ftext(BSL_DISCLAIMER, fp_disclaimer)))
|
||
|
||
doc
|
||
}
|
||
|
||
|
||
# Server ####
|
||
|
||
server = function(input, output, session) {
|
||
# --- pseudonym-support-injection v1 ---
|
||
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(error = "Bitte eine Patientenchiffre eingeben."))
|
||
}
|
||
if (!(nchar(trimws(input$pseudonym)) > 0 || grepl("^[A-Z][0-9]{6}$", chiffre))) {
|
||
return(list(error = paste0(
|
||
"Ungültige Chiffre. Erwartet: ein Grossbuchstabe + 6 Ziffern (z.B. P000123).")))
|
||
}
|
||
|
||
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)))
|
||
}
|
||
|
||
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_bsl", envir = .GlobalEnv)) {
|
||
return(list(error = paste0(
|
||
"Objekt 'daten_bsl' nach dem Sourcen nicht gefunden. Bitte Download-Skript prüfen.")))
|
||
}
|
||
if (!exists("pseudo", envir = .GlobalEnv)) {
|
||
return(list(error = paste0(
|
||
"Objekt 'pseudo' nach dem Sourcen nicht gefunden. Bitte Pseudonym-Skript prüfen.")))
|
||
}
|
||
|
||
daten = get("daten_bsl", envir = .GlobalEnv)
|
||
pseudo_df = get("pseudo", envir = .GlobalEnv)
|
||
|
||
treffer_ps = pseudo_df[pseudo_df$chiffre == chiffre, , drop = FALSE]
|
||
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, , drop = FALSE]
|
||
if (nrow(treffer_dat) == 0) {
|
||
return(list(error = paste0(
|
||
"Kein BSL-Datensatz für Chiffre '", chiffre, "' gefunden. ",
|
||
"(", length(alle_session_ids), " Pseudonym(e) geprüft)")))
|
||
}
|
||
|
||
warnungen = character(0)
|
||
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"
|
||
)
|
||
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_posix = tryCatch(as.POSIXct(zeile[["created"]][1]), error = function(e) NULL)
|
||
datum_ok = !is.null(datum_posix) && length(datum_posix) > 0 && !is.na(datum_posix)
|
||
ausfuelldatum = if (datum_ok) format(datum_posix, "%d.%m.%Y") else format(Sys.Date(), "%d.%m.%Y")
|
||
ausfuelldatum_dateikennung = if (datum_ok) format(datum_posix, "%Y%m%d") else format(Sys.Date(), "%Y%m%d")
|
||
|
||
# Hauptitems 1-105 -> Punktwerte (0-4), inkl. Items 96-105 (nur deskriptiv).
|
||
haupt_punkte = setNames(
|
||
lapply(1:105, function(i) {
|
||
col = paste0("bsl_", sprintf("%03d", i))
|
||
bsl_recode_item(zeile[[col]], ergaenzungsskala = FALSE)
|
||
}),
|
||
as.character(1:105)
|
||
)
|
||
|
||
# Ergaenzungsskala 1-11 -> Punktwerte (0-4).
|
||
erg_punkte = setNames(
|
||
lapply(1:11, function(i) {
|
||
col = paste0("bsl_erg_", sprintf("%02d", i))
|
||
bsl_recode_item(zeile[[col]], ergaenzungsskala = TRUE)
|
||
}),
|
||
as.character(1:11)
|
||
)
|
||
|
||
vas_rohwert = bsl_recode_vas(zeile[["bsl_vas"]])
|
||
|
||
# 7 Subskalen: Rohwert -> Prozentrang, Missing-Regel (> 10% fehlend -> nicht auswertbar).
|
||
subskalen_erg = lapply(BSL_SUBSKALEN, function(sk) {
|
||
sc = bsl_score_skala(sk$items, haupt_punkte, sk$reverse)
|
||
pr = if (sc$auswertbar) bsl_norm_lookup(BSL_NORMTABELLEN[[sk$norm_key]], sc$rohwert) else NA_real_
|
||
list(
|
||
name = sk$name,
|
||
rohwert = sc$rohwert,
|
||
max = sk$max,
|
||
anteil_fehlend = sc$anteil_fehlend,
|
||
auswertbar = sc$auswertbar,
|
||
prozentrang = pr
|
||
)
|
||
})
|
||
|
||
# Gesamtskala = Summe Items 1-95 (mit Umpolung der Dysphorie-Umpolitems).
|
||
gesamt_sc = bsl_score_skala(BSL_GESAMT_ITEMS, haupt_punkte, BSL_DYSPHORIE_REVERSE)
|
||
gesamt_pr = if (gesamt_sc$auswertbar) {
|
||
bsl_norm_lookup(BSL_NORMTABELLEN[["gesamtskala"]], gesamt_sc$rohwert)
|
||
} else {
|
||
NA_real_
|
||
}
|
||
gesamtskala = list(
|
||
rohwert = gesamt_sc$rohwert,
|
||
max = 380,
|
||
anteil_fehlend = gesamt_sc$anteil_fehlend,
|
||
auswertbar = gesamt_sc$auswertbar,
|
||
prozentrang = gesamt_pr
|
||
)
|
||
|
||
vas_pr = bsl_norm_lookup(BSL_NORMTABELLEN[["vas"]], vas_rohwert, wert_spalte = "vas_wert")
|
||
vas = list(rohwert = vas_rohwert, prozentrang = vas_pr)
|
||
|
||
# Einzelitems 1-95, nach Subskala gruppiert (zusaetzlich zur aggregierten Balkendarstellung).
|
||
haupt_items = bsl_gruppiere_hauptitems(haupt_punkte, daten)
|
||
|
||
# Ergaenzungsskala, rein deskriptiv (kein Summenscore, kein Cutoff, keine Norm).
|
||
ergaenzung_items = lapply(1:11, function(i) {
|
||
col = paste0("bsl_erg_", sprintf("%02d", i))
|
||
punkt = erg_punkte[[as.character(i)]]
|
||
list(
|
||
nr = i,
|
||
text = bsl_item_label(daten[[col]], paste0("Ergänzungsitem ", i)),
|
||
punktwert = punkt,
|
||
antwort = bsl_antwort_text(punkt, ergaenzungsskala = TRUE)
|
||
)
|
||
})
|
||
|
||
# Items 96-105, rein deskriptiv (kein Summenscore, kein Cutoff, keine Norm).
|
||
item_96_105 = lapply(96:105, function(i) {
|
||
col = paste0("bsl_", sprintf("%03d", i))
|
||
punkt = haupt_punkte[[as.character(i)]]
|
||
list(
|
||
nr = i,
|
||
text = bsl_item_label(daten[[col]], paste0("Item ", i)),
|
||
punktwert = punkt,
|
||
antwort = bsl_antwort_text(punkt, ergaenzungsskala = FALSE)
|
||
)
|
||
})
|
||
|
||
# Kritische Items: zwei unterschiedliche Schwellen (bewusst nicht identisch, siehe unten).
|
||
# Hauptitems: Schwelle Stufe >= 2 ("ziemlich" oder staerker).
|
||
kritisch_haupt_def = data.frame(
|
||
item = c(18, 22, 62, 104),
|
||
text = c(
|
||
"... hatte ich Todessehnsucht",
|
||
"... dachte ich an Selbstverletzungen",
|
||
"... litt ich unter Selbstmordgedanken",
|
||
"... hatte ich den Drang, mich selbst zu verletzen"
|
||
),
|
||
schwelle = c(2L, 2L, 2L, 2L),
|
||
stringsAsFactors = FALSE
|
||
)
|
||
# Ergaenzungsskala: Schwelle Stufe >= 1 ("1 mal" oder haeufiger) - abweichend niedriger
|
||
# angesetzt, weil bei diesen beiden Items bereits ein einmaliges Vorkommnis klinisch
|
||
# relevant ist.
|
||
kritisch_erg_def = data.frame(
|
||
item_nr = c(2L, 3L),
|
||
text = c(
|
||
"... äußerte ich mich gegenüber anderen, daß ich mich umbringen würde",
|
||
"... machte ich einen Suizidversuch"
|
||
),
|
||
schwelle = c(1L, 1L),
|
||
stringsAsFactors = FALSE
|
||
)
|
||
|
||
kritische_treffer = list()
|
||
for (i in seq_len(nrow(kritisch_haupt_def))) {
|
||
item_nr = kritisch_haupt_def$item[i]
|
||
punkt = haupt_punkte[[as.character(item_nr)]]
|
||
if (!is.na(punkt) && punkt >= kritisch_haupt_def$schwelle[i]) {
|
||
kritische_treffer[[length(kritische_treffer) + 1]] = list(
|
||
bezeichnung = paste0("Item ", item_nr),
|
||
text = kritisch_haupt_def$text[i],
|
||
antwort = bsl_antwort_text(punkt, ergaenzungsskala = FALSE),
|
||
schwelle_txt = paste0("Schwelle: Stufe >= ", kritisch_haupt_def$schwelle[i])
|
||
)
|
||
}
|
||
}
|
||
for (i in seq_len(nrow(kritisch_erg_def))) {
|
||
item_nr = kritisch_erg_def$item_nr[i]
|
||
punkt = erg_punkte[[as.character(item_nr)]]
|
||
if (!is.na(punkt) && punkt >= kritisch_erg_def$schwelle[i]) {
|
||
kritische_treffer[[length(kritische_treffer) + 1]] = list(
|
||
bezeichnung = paste0("Ergänzungsitem ", item_nr),
|
||
text = kritisch_erg_def$text[i],
|
||
antwort = bsl_antwort_text(punkt, ergaenzungsskala = TRUE),
|
||
schwelle_txt = paste0("Schwelle: Stufe >= ", kritisch_erg_def$schwelle[i])
|
||
)
|
||
}
|
||
}
|
||
|
||
list(
|
||
error = NULL,
|
||
chiffre = chiffre,
|
||
ausfuelldatum = ausfuelldatum,
|
||
ausfuelldatum_dateikennung = ausfuelldatum_dateikennung,
|
||
warnungen = warnungen,
|
||
subskalen = subskalen_erg,
|
||
gesamtskala = gesamtskala,
|
||
vas = vas,
|
||
haupt_items = haupt_items,
|
||
ergaenzung_items = ergaenzung_items,
|
||
item_96_105 = item_96_105,
|
||
kritische_treffer = kritische_treffer
|
||
)
|
||
})
|
||
|
||
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) || length(d$warnungen) == 0) return(NULL)
|
||
tagList(lapply(d$warnungen, function(w) div(class = "alert-warnung", w)))
|
||
})
|
||
|
||
output$kritisch_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
if (!is.null(d$error) || length(d$kritische_treffer) == 0) return(NULL)
|
||
|
||
zeilen = lapply(d$kritische_treffer, function(kt) {
|
||
div(class = "kritisch-zeile",
|
||
tags$strong(paste0(kt$bezeichnung, ": ")), kt$text, tags$br(),
|
||
tags$span(paste0("Antwort: ", kt$antwort, " (", kt$schwelle_txt, ")"))
|
||
)
|
||
})
|
||
|
||
div(class = "kritisch-block",
|
||
tags$h4("Kritische Items – bitte gesondert beachten"),
|
||
zeilen,
|
||
div(class = "kritisch-disclaimer", BSL_KRITISCH_DISCLAIMER)
|
||
)
|
||
})
|
||
|
||
output$ergebnis_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
if (!is.null(d$error)) return(NULL)
|
||
|
||
ergaenzung_ui = bsl_item_liste_ui(d$ergaenzung_items)
|
||
item96_105_ui = bsl_item_liste_ui(d$item_96_105)
|
||
haupt_items_ui = lapply(d$haupt_items, function(gruppe) {
|
||
tagList(
|
||
div(class = "subskala-titel-item", gruppe$titel),
|
||
bsl_item_liste_ui(gruppe$items)
|
||
)
|
||
})
|
||
|
||
div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "BSL-105 – Auswertung"),
|
||
|
||
div(class = "meta-block",
|
||
tags$strong("Chiffre: "), d$chiffre,
|
||
tags$span(" | ", style = "color:#ccc;"),
|
||
tags$strong("Ausfülldatum: "), d$ausfuelldatum
|
||
),
|
||
|
||
tags$hr(),
|
||
|
||
tags$h5("Gesamtskala und Subskalen (Prozentrang)"),
|
||
plotOutput("profil_plot", height = "320px"),
|
||
|
||
tags$hr(),
|
||
|
||
tags$h5("VAS Gesamtbefindlichkeit"),
|
||
plotOutput("vas_plot", height = "90px"),
|
||
|
||
tags$hr(),
|
||
|
||
tags$h5("Einzelitems 1–95 (nach Subskala gruppiert)"),
|
||
div(haupt_items_ui),
|
||
|
||
tags$hr(),
|
||
|
||
tags$h5("Ergänzungsskala (11 Items, deskriptiv – kein Summenscore, keine Norm)"),
|
||
div(ergaenzung_ui),
|
||
|
||
tags$hr(),
|
||
|
||
tags$h5("Items 96–105 (deskriptiv – kein Summenscore, keine Norm)"),
|
||
div(item96_105_ui)
|
||
)
|
||
})
|
||
|
||
# tryCatch hier bewusst NICHT nur zur Absicherung: Ein Rendering-Fehler soll als lesbarer
|
||
# Text im Plotbereich erscheinen statt die Grafik nur stillschweigend leer zu lassen.
|
||
output$profil_plot = renderPlot({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
req(is.null(d$error))
|
||
tryCatch(
|
||
bsl_profil_plot(d$gesamtskala, d$subskalen),
|
||
error = function(e) {
|
||
ggplot() +
|
||
annotate("text", x = 0, y = 0,
|
||
label = paste0("Fehler beim Erstellen der Grafik: ", e$message),
|
||
color = "#B71C1C", size = 4) +
|
||
theme_void()
|
||
}
|
||
)
|
||
}, bg = "transparent")
|
||
|
||
output$vas_plot = renderPlot({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
req(is.null(d$error))
|
||
tryCatch(
|
||
bsl_vas_plot(d$vas),
|
||
error = function(e) {
|
||
ggplot() +
|
||
annotate("text", x = 0, y = 0,
|
||
label = paste0("Fehler beim Erstellen der Grafik: ", e$message),
|
||
color = "#B71C1C", size = 4) +
|
||
theme_void()
|
||
}
|
||
)
|
||
}, 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)
|
||
d$chiffre else "export"
|
||
datum_fn = if (is.list(d) && is.null(d$error) && !is.null(d$ausfuelldatum_dateikennung))
|
||
d$ausfuelldatum_dateikennung else format(Sys.Date(), "%Y%m%d")
|
||
paste0("BSL_", chiffre_esc, "_", datum_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 eingeben und 'Auswerten' klicken.",
|
||
style = "Normal")
|
||
print(doc, target = file)
|
||
return()
|
||
}
|
||
doc = tryCatch(
|
||
erstelle_bsl_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)
|