DiagnostikApps/ACQ BSQ MI/app.R
2026-09-22 18:35:43 +02:00

1272 lines
51 KiB
R
Raw Permalink Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

# Präambel ####
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_acqbsqmi.R"
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
AKZENT_FARBE = "#8B2635"
ACQBSQMI_DISCLAIMER = paste0(
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ",
"Die dargestellten Referenzwerte sind deskriptive Vergleichswerte aus publizierten ",
"Stichproben, keine diagnostischen Cutoffs."
)
# OFFEN (1): Keine publizierten diagnostischen Cutoffs fuer ACQ/BSQ/MI in diesem
# Manual-Auszug. Die App zeigt ausschliesslich deskriptive Einordnung gegenueber
# den vier Referenzgruppen (Perzentil und Stanine), keine kategoriale Klassifikation
# ("auffaellig"/"unauffaellig").
# OFFEN (2): Diskrepanz N=206 (Tab. A5) vs. N=208 (Tab. A6) bei Kontrollgruppe MIA.
# Vermutlich OCR-Lesefehler; wirkt sich nicht auf Werte aus. Sichtbar als Fussnote.
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 ####
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) == suppressWarnings(as.numeric(wert[1])))
if (length(pos) > 0) return(gsub("\\*\\*", "", names(lbl_attr)[pos[1]]))
}
NA_character_
}
get_numeric_wert = function(wert) {
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_real_)
suppressWarnings(as.numeric(wert[1]))
}
clean_label = function(text) {
if (is.null(text) || length(text) == 0 || is.na(text[1])) return(NA_character_)
gsub("\\*\\*", "", trimws(as.character(text[1])))
}
raw_to_char_or_null = function(x) {
if (is.null(x) || length(x) == 0) return(NULL)
s = trimws(as.character(x[1]))
if (is.na(s) || s == "" || s == "NA") NULL else s
}
mi_ist_zutreffend = function(original_col, wert) {
txt = get_label_text(original_col, wert)
if (is.na(txt)) return(FALSE)
grepl("^ja$", trimws(txt), ignore.case = TRUE)
}
berechne_mittelwert_mit_warnung = function(werte, max_fehlend) {
n_gesamt = length(werte)
n_fehlend = sum(is.na(werte))
n_vorhanden = n_gesamt - n_fehlend
score = if (n_vorhanden == 0) NA_real_ else mean(werte, na.rm = TRUE)
warnung = if (!is.na(score) && n_fehlend > max_fehlend)
paste0("Zu viele fehlende Items (", n_fehlend, " von ", n_gesamt,
" fehlen; Toleranz: max. ", max_fehlend, "). ",
"Wert ist moeglicherweise eine Ueberschaetzung, mit Vorsicht interpretieren.")
else NULL
list(score = score, n_fehlend = n_fehlend, n_gesamt = n_gesamt,
n_vorhanden = n_vorhanden, warnung = warnung)
}
berechne_perzentil = function(score, skala, gruppe) {
if (is.null(score) || is.na(score)) return(NA_character_)
tab = perzentile_acq_bsq_mi[
perzentile_acq_bsq_mi$skala == skala &
perzentile_acq_bsq_mi$gruppe == gruppe, ]
if (nrow(tab) == 0) return(NA_character_)
tab = tab[order(tab$perzentil), ]
if (score <= tab$wert[1]) return(paste0("< ", tab$perzentil[1], ". Pz."))
if (score >= tab$wert[nrow(tab)]) return(paste0("> ", tab$perzentil[nrow(tab)], ". Pz."))
for (i in seq_len(nrow(tab) - 1)) {
if (score >= tab$wert[i] && score < tab$wert[i + 1]) {
p_unten = tab$perzentil[i]; p_oben = tab$perzentil[i + 1]
w_unten = tab$wert[i]; w_oben = tab$wert[i + 1]
if (w_oben == w_unten) return(paste0(p_unten, ". Pz."))
p_interp = p_unten + (score - w_unten) / (w_oben - w_unten) * (p_oben - p_unten)
return(paste0(round(p_interp), ". Pz."))
}
}
NA_character_
}
berechne_stanine = function(score, skala, gruppe) {
if (is.null(score) || is.na(score)) return(NA_character_)
tab = stanine_acq_bsq_mi[
stanine_acq_bsq_mi$skala == skala &
stanine_acq_bsq_mi$gruppe == gruppe, ]
if (nrow(tab) == 0) return(NA_character_)
for (i in seq_len(nrow(tab))) {
if (score >= tab$untergrenze[i] && score <= tab$obergrenze[i])
return(as.character(tab$stanine[i]))
}
NA_character_
}
make_vergleich_plot = function(score, skala_key, titel) {
ref = referenz_acq_bsq_mi[referenz_acq_bsq_mi$skala == skala_key, ]
kurz_map = c(
"Paniksyndrom" = "Panik",
"Andere Angststoerungen" = "And. Angst",
"Psychosomat. Patienten ohne Angststoerung" = "Psychosomat.",
"Kontrollpersonen ohne psychische Stoerung" = "Kontrolle"
)
ref$gruppe_kurz = kurz_map[ref$gruppe]
ref$gruppe_f = factor(ref$gruppe_kurz,
levels = rev(c("Panik", "And. Angst", "Psychosomat.", "Kontrolle")))
p = ggplot(ref, aes(y = gruppe_f, x = mittelwert)) +
geom_errorbar(aes(xmin = mittelwert - sd, xmax = mittelwert + sd),
orientation = "y", width = 0.3, color = "#9E9E9E", linewidth = 0.8) +
geom_point(size = 3.5, color = "#757575") +
scale_x_continuous(limits = c(1, 5), breaks = 1:5) +
labs(x = "Mittelwert (+-1 SD)", y = NULL,
title = paste0("Einordnung: ", titel)) +
theme_minimal(base_size = 11) +
coord_cartesian(clip = "off") +
theme(
plot.title = element_text(size = 10, color = "#555", face = "plain"),
panel.grid.minor = element_blank(),
axis.text.y = element_text(size = 10),
plot.margin = margin(4, 10, 22, 4)
)
if (!is.null(score) && !is.na(score)) {
p = p +
geom_vline(xintercept = score, color = AKZENT_FARBE,
linewidth = 1.3, linetype = "solid") +
annotate("label", x = score, y = 0.3,
label = paste0("Pat: ", round(score, 2)),
color = "white", fill = AKZENT_FARBE,
size = 3, fontface = "bold", linewidth = 0)
}
p
}
normen_tabelle_html = function(score, skala_key) {
gruppen = c(
"Paniksyndrom",
"Andere Angststoerungen",
"Psychosomat. Patienten ohne Angststoerung",
"Kontrollpersonen ohne psychische Stoerung"
)
kurz_map = c(
"Paniksyndrom" = "Panik",
"Andere Angststoerungen" = "And. Angst",
"Psychosomat. Patienten ohne Angststoerung" = "Psychosomat.",
"Kontrollpersonen ohne psychische Stoerung" = "Kontrolle"
)
reihen = lapply(gruppen, function(g) {
p_txt = berechne_perzentil(score, skala_key, g)
s_txt = berechne_stanine(score, skala_key, g)
tags$tr(
tags$td(kurz_map[g],
style = "padding:2px 8px; color:#555; font-size:0.87em;"),
tags$td(if (is.na(p_txt)) "-" else p_txt,
style = "padding:2px 8px; font-size:0.87em; text-align:right;"),
tags$td(if (is.na(s_txt)) "-" else s_txt,
style = "padding:2px 8px; font-size:0.87em; text-align:right;")
)
})
tags$table(style = "width:100%; border-collapse:collapse; margin-top:4px;",
tags$thead(tags$tr(
tags$th("Gruppe", style = "text-align:left; padding:2px 8px; font-size:0.8em; color:#888; font-weight:500;"),
tags$th("Perzentil", style = "text-align:right; padding:2px 8px; font-size:0.8em; color:#888; font-weight:500;"),
tags$th("Stanine", style = "text-align:right; padding:2px 8px; font-size:0.8em; color:#888; font-weight:500;")
)),
tags$tbody(reihen)
)
}
score_block_ui = function(score_info, skala_key, titel, plot_id, einheit = "Mittelwert (1-5)") {
score_text = if (is.null(score_info$score) || is.na(score_info$score))
"k. A." else sprintf("%.2f", score_info$score)
tagList(
if (!is.null(score_info$warnung))
div(class = "alert-warnung", score_info$warnung),
div(class = "abschnitt-titel", style = "font-size:1rem; margin-bottom:6px;", titel),
div(class = "score-zahl", score_text),
div(einheit, style = "color:#555; font-size:0.85em; margin-bottom:4px;"),
normen_tabelle_html(score_info$score, skala_key),
plotOutput(plot_id, height = "155px")
)
}
acq_bsq_badge_css = function(wert_num) {
if (is.na(wert_num)) return("background:#E0E0E0; color:#555;")
switch(as.character(as.integer(round(wert_num))),
"1" = "background:#4CAF50; color:white;",
"2" = "background:#F48FB1; color:#333;",
"3" = "background:#EF5350; color:white;",
"4" = "background:#B71C1C; color:white;",
"5" = "background:#4A0000; color:white;",
"background:#E0E0E0; color:#555;"
)
}
render_acq_bsq_item = function(item) {
badge_css = acq_bsq_badge_css(item$wert_num)
badge_text = if (is.na(item$wert_text)) "k. A." else item$wert_text
item_text = if (is.na(item$text)) paste0("Item ", item$nr) else item$text
div(class = "item-zeile",
div(class = "item-nr", item$nr_label),
div(class = "item-text", item_text),
tags$span(
style = paste0("border-radius:4px; padding:2px 9px; font-weight:700; ",
"font-size:0.82em; white-space:nowrap; flex-shrink:0; ",
badge_css),
badge_text
)
)
}
mi_wert_badge = function(wert_num, label) {
bg = if (is.na(wert_num)) "#E0E0E0" else
c("1"="#4CAF50","1.5"="#8BC34A","2"="#CDDC39","2.5"="#FFEB3B",
"3"="#FFC107","3.5"="#FF9800","4"="#EF5350","4.5"="#D32F2F","5"="#B71C1C")[
as.character(wert_num)]
if (is.na(bg) || is.null(bg)) bg = "#9E9E9E"
col = if (is.na(wert_num) || wert_num < 3) "#333" else "white"
wert_txt = if (is.na(wert_num)) "k.A." else sprintf("%.1f", wert_num)
tags$span(
style = paste0("border-radius:4px; padding:2px 7px; font-weight:700; ",
"font-size:0.82em; background:", bg, "; color:", col, ";"),
paste0(label, " ", wert_txt)
)
}
render_mi_item = function(item) {
item_text = if (is.na(item$text)) paste0("Situation ", item$nr) else item$text
if (!item$zutreffend) {
return(div(class = "item-zeile",
div(class = "item-nr", item$nr_label),
div(class = "item-text", style = "color:#9E9E9E;", item_text),
tags$span(style = "color:#BDBDBD; font-size:0.82em; flex-shrink:0;",
"betrifft mich nicht")
))
}
div(class = "item-zeile",
div(class = "item-nr", item$nr_label),
div(class = "item-text", item_text),
div(style = "flex-shrink:0; display:flex; gap:5px;",
mi_wert_badge(item$begl_num, "Begl"),
mi_wert_badge(item$allein_num, "Allein")
)
)
}
top3_liste_html = function(txt) {
if (is.null(txt) || is.na(txt) || trimws(txt) == "") return(NULL)
parts = trimws(strsplit(txt, "[,;\n\r]")[[1]])
parts = parts[nchar(parts) > 0]
if (length(parts) == 0) return(NULL)
tags$ul(style = "margin:4px 0 0 16px; padding:0; font-size:0.92em; color:#444;",
lapply(parts, tags$li))
}
render_rang_acq_bsq = function(items, n_score, kurzlabels = NULL, weitere_text = NULL) {
alle_items = items[seq_len(min(n_score + 1L, length(items)))]
sortiert = alle_items[order(sapply(alle_items, function(x)
if (is.na(x$wert_num)) Inf else -x$wert_num
))]
make_badge_txt = function(item) {
if (!is.null(kurzlabels) && !is.na(item$wert_num)) {
idx = as.integer(round(item$wert_num))
if (idx >= 1L && idx <= length(kurzlabels)) return(kurzlabels[idx])
}
if (is.na(item$wert_text)) "k.A." else item$wert_text
}
rang_nr = 0L
lapply(sortiert, function(item) {
is_w = !item$in_score
if (!is_w) rang_nr <<- rang_nr + 1L
nr_label = if (is_w) "zus." else paste0(rang_nr, ".")
item_txt = if (is_w) {
if (!is.null(weitere_text)) paste0("Weitere: ", weitere_text)
else if (!is.na(item$text)) item$text else "Weitere"
} else {
if (is.na(item$text)) paste0("Item ", item$nr) else item$text
}
badge_css = acq_bsq_badge_css(item$wert_num)
div(class = "item-zeile", style = if (is_w) "background:#F5F5F5;" else "",
div(class = "item-nr", nr_label),
div(class = "item-text",
style = if (is_w) "font-style:italic; font-weight:bold; color:#666;" else "",
if (!is_w)
tags$span(style = "color:#aaa; font-size:0.82em; margin-right:5px;",
paste0("(", item$nr, ")")),
item_txt
),
if (!is.na(item$wert_num))
tags$span(style = paste0("border-radius:4px; padding:2px 9px; font-weight:700; ",
"font-size:0.82em; white-space:nowrap; flex-shrink:0; ",
badge_css),
make_badge_txt(item))
)
})
}
render_rang_mi = function(mi_items) {
score_items = Filter(function(x) x$in_score, mi_items)
if (length(score_items) == 0)
return(div(style = "color:#888; font-size:0.9em;", "Keine Daten."))
sortiert = score_items[order(sapply(score_items, function(x)
if (!x$zutreffend || is.na(x$allein_num)) Inf else -x$allein_num
))]
delta_style = function(d) {
if (is.na(d)) return("color:#aaa;")
if (d >= 1.5) return("color:#B71C1C; font-weight:700;")
if (d >= 0.5) return("color:#E65100; font-weight:600;")
"color:#555;"
}
badge = function(wert, css) {
txt = if (is.na(wert)) "" else sprintf("%.1f", wert)
tags$span(style = paste0("border-radius:3px; padding:1px 6px; font-weight:700; ",
"font-size:0.82em; ", css), txt)
}
reihen = lapply(sortiert, function(item) {
sit_txt = if (is.na(item$text)) paste0("Situation ", item$nr) else item$text
if (!item$zutreffend) {
return(tags$tr(style = "background:#F5F5F5;",
tags$td(paste0(item$nr, ". ", sit_txt),
style = "padding:3px 8px; font-size:0.87em; color:#BDBDBD; font-style:italic;"),
tags$td("", style = "padding:3px 8px; text-align:center; color:#BDBDBD; font-size:0.87em;"),
tags$td("", style = "padding:3px 8px; text-align:center; color:#BDBDBD; font-size:0.87em;"),
tags$td("", style = "padding:3px 8px; text-align:center; color:#BDBDBD; font-size:0.87em;")
))
}
delta = if (!is.na(item$allein_num) && !is.na(item$begl_num))
item$allein_num - item$begl_num else NA_real_
tags$tr(
tags$td(paste0(item$nr, ". ", sit_txt),
style = "padding:3px 8px; font-size:0.87em; color:#333;"),
tags$td(badge(item$allein_num, acq_bsq_badge_css(item$allein_num)),
style = "padding:3px 8px; text-align:center;"),
tags$td(badge(item$begl_num, acq_bsq_badge_css(item$begl_num)),
style = "padding:3px 8px; text-align:center;"),
tags$td(if (is.na(delta)) "" else sprintf("%+.1f", delta),
style = paste0("padding:3px 8px; font-size:0.88em; text-align:center; ",
delta_style(delta)))
)
})
tags$table(style = "width:100%; border-collapse:collapse;",
tags$thead(tags$tr(
tags$th("Situation",
style = "text-align:left; padding:3px 8px; font-size:0.8em; color:#888; border-bottom:1px solid #eee;"),
tags$th("Allein",
style = "text-align:center; padding:3px 8px; font-size:0.8em; color:#888; border-bottom:1px solid #eee;"),
tags$th("Begl.",
style = "text-align:center; padding:3px 8px; font-size:0.8em; color:#888; border-bottom:1px solid #eee;"),
tags$th("Δ (A-B)",
style = "text-align:center; padding:3px 8px; font-size:0.8em; color:#888; border-bottom:1px solid #eee;")
)),
tags$tbody(reihen)
)
}
normen_text_word = function(score, skala_key) {
gruppen = c(
"Paniksyndrom",
"Andere Angststoerungen",
"Psychosomat. Patienten ohne Angststoerung",
"Kontrollpersonen ohne psychische Stoerung"
)
paste(sapply(gruppen, function(g) {
p_txt = berechne_perzentil(score, skala_key, g)
s_txt = berechne_stanine(score, skala_key, g)
paste0(" ", g, ": Pz. ",
if (is.na(p_txt)) "-" else p_txt,
" | Stanine ", if (is.na(s_txt)) "-" else s_txt)
}), collapse = "\n")
}
# Datenaufbereitung ####
MI_SITUATIONEN = c(
"Kinos oder Theater",
"Supermaerkte",
"Schul- oder Ausbildungsraeume",
"Kaufhaeuser",
"Gaststaetten",
"Museen",
"Fahrstuehle",
"Saele oder Stadien",
"Parkhaeuser oder -garagen",
"Hohe Plaetze",
"Geschlossene Raeume (z. B. Tunnel)",
"Offene Plaetze - aussen (z. B. Strassen, Hoefe)",
"Offene Plaetze - innen (z. B. grosse Raeume, Hallen)",
"Fahren mit Bussen",
"Fahren mit Zuegen",
"Fahren mit Untergrundbahnen",
"Fahren mit Flugzeugen",
"Fahren mit Schiffen",
"Fahren mit Autos - ueberall",
"Fahren mit Autos - auf Autobahnen/Landstrassen",
"Schlange stehen",
"Bruecken ueberqueren",
"Parties, Feste oder Zusammenkuenfte",
"Auf der Strasse gehen",
"Zu Hause allein sein",
"Weit weg von zu Hause sein",
"Menschenmengen",
"Andere"
)
referenz_acq_bsq_mi = data.frame(
skala = c("BSQ","BSQ","BSQ","BSQ",
"ACQ_gesamt","ACQ_gesamt","ACQ_gesamt","ACQ_gesamt",
"ACQ_koerperliche_krise","ACQ_koerperliche_krise","ACQ_koerperliche_krise","ACQ_koerperliche_krise",
"ACQ_kontrollverlust","ACQ_kontrollverlust","ACQ_kontrollverlust","ACQ_kontrollverlust",
"MIA","MIA","MIA","MIA",
"MIB","MIB","MIB","MIB"),
gruppe = rep(c("Paniksyndrom","Andere Angststoerungen",
"Psychosomat. Patienten ohne Angststoerung",
"Kontrollpersonen ohne psychische Stoerung"), times = 6),
n = c(356,135,127,208,
355,139,132,208,
295,139,132,208,
295,139,132,208,
291,73,55,206,
229,72,54,207),
mittelwert = c(2.60,2.05,1.66,1.65,
2.02,1.64,1.31,1.32,
2.11,1.33,1.24,1.12,
1.95,1.91,1.38,1.49,
2.70,1.69,1.43,1.45,
1.97,1.40,1.29,1.22),
sd = c(0.72,0.65,0.64,0.51,
0.61,0.48,0.33,0.32,
0.85,0.43,0.31,0.26,
0.71,0.75,0.47,0.50,
1.04,0.69,0.65,0.48,
0.84,0.49,0.50,0.35),
median = c(2.59,2.00,1.53,1.59,
1.93,1.57,1.21,1.29,
2.00,1.20,1.00,1.00,
1.86,1.71,1.14,1.43,
2.65,1.46,1.15,1.30,
1.85,1.21,1.12,1.08),
min = c(1.00,1.00,1.00,1.00,
1.00,1.00,1.00,1.00,
1.00,1.00,1.00,1.00,
1.00,1.00,1.00,1.00,
1.00,1.00,1.00,1.00,
1.00,1.00,1.00,1.00),
max = c(4.50,3.77,3.82,3.29,
4.07,3.21,2.64,2.86,
4.80,3.00,2.40,2.80,
4.14,4.29,3.14,3.71,
5.00,5.00,4.00,3.63,
4.64,3.50,3.52,2.89),
cronbachs_alpha = c(0.87,0.87,0.93,0.88,
0.80,0.81,0.82,0.82,
0.75,0.69,0.61,0.66,
0.78,0.83,0.82,0.82,
0.96,0.88,0.91,0.90,
0.95,0.67,0.91,0.90),
stringsAsFactors = FALSE
)
perzentile_acq_bsq_mi = data.frame(
skala = rep(c("BSQ","ACQ_gesamt","ACQ_koerperliche_krise","ACQ_kontrollverlust","MIA","MIB"),
each = 19 * 4),
perzentil = rep(rep(seq(5, 95, 5), each = 4), times = 6),
gruppe = rep(rep(c("Paniksyndrom","Andere Angststoerungen",
"Psychosomat. Patienten ohne Angststoerung",
"Kontrollpersonen ohne psychische Stoerung"), times = 19), times = 6),
wert = c(
1.41,1.17,1.00,1.00, 1.65,1.29,1.00,1.00, 1.82,1.35,1.06,1.12, 2.00,1.47,1.12,1.18,
2.06,1.53,1.18,1.24, 2.18,1.59,1.24,1.29, 2.29,1.65,1.28,1.35, 2.41,1.77,1.31,1.41,
2.47,1.82,1.39,1.47, 2.59,2.00,1.53,1.59, 2.67,2.06,1.53,1.65, 2.77,2.12,1.59,1.71,
2.82,2.29,1.71,1.77, 2.94,2.35,1.82,1.89, 3.12,2.47,1.94,2.00, 3.29,2.59,2.08,2.19,
3.44,2.72,2.35,2.24, 3.59,3.06,2.62,2.42, 3.80,3.24,3.07,2.53,
1.14,1.07,1.00,1.00, 1.29,1.07,1.00,1.00, 1.37,1.14,1.00,1.07, 1.46,1.14,1.02,1.07,
1.57,1.21,1.07,1.07, 1.60,1.36,1.07,1.14, 1.71,1.43,1.07,1.14, 1.79,1.43,1.14,1.14,
1.86,1.50,1.14,1.21, 1.93,1.57,1.21,1.29, 2.00,1.57,1.29,1.29, 2.07,1.71,1.29,1.29,
2.14,1.71,1.36,1.36, 2.29,1.86,1.50,1.36, 2.43,1.93,1.50,1.43, 2.57,2.00,1.64,1.50,
2.64,2.14,1.71,1.62, 2.86,2.29,1.79,1.86, 3.23,2.64,1.93,2.00,
1.0,1.0,1.0,1.0, 1.0,1.0,1.0,1.0, 1.2,1.0,1.0,1.0, 1.4,1.0,1.0,1.0,
1.4,1.0,1.0,1.0, 1.6,1.0,1.0,1.0, 1.6,1.0,1.0,1.0, 1.8,1.0,1.0,1.0,
1.8,1.2,1.0,1.0, 2.0,1.2,1.0,1.0, 2.0,1.2,1.2,1.0, 2.2,1.2,1.2,1.0,
2.4,1.4,1.2,1.0, 2.4,1.4,1.4,1.0, 2.6,1.6,1.4,1.2, 2.8,1.8,1.6,1.2,
3.0,1.8,1.6,1.4, 3.4,2.0,1.8,1.4, 3.8,2.2,2.0,1.6,
1.00,1.00,1.00,1.00, 1.14,1.14,1.00,1.00, 1.14,1.14,1.00,1.00, 1.29,1.29,1.00,1.00,
1.43,1.29,1.00,1.14, 1.50,1.43,1.00,1.14, 1.57,1.57,1.00,1.29, 1.71,1.71,1.14,1.29,
1.71,1.71,1.14,1.29, 1.86,1.71,1.14,1.43, 1.86,1.86,1.29,1.43, 2.00,1.86,1.29,1.43,
2.14,2.00,1.43,1.57, 2.29,2.14,1.44,1.57, 2.43,2.29,1.57,1.71, 2.57,2.57,1.71,1.71,
2.71,2.71,1.86,1.95, 3.00,3.00,2.14,2.29, 3.29,3.43,2.43,2.57,
1.10,1.00,1.00,1.00, 1.25,1.03,1.00,1.00, 1.50,1.11,1.00,1.00, 1.66,1.15,1.00,1.04,
1.82,1.20,1.04,1.08, 2.04,1.26,1.07,1.11, 2.19,1.33,1.10,1.15, 2.33,1.38,1.11,1.19,
2.48,1.41,1.15,1.26, 2.65,1.46,1.15,1.30, 2.78,1.55,1.18,1.33, 2.97,1.62,1.25,1.41,
3.15,1.71,1.29,1.48, 3.34,1.84,1.37,1.56, 3.54,1.90,1.48,1.67, 3.70,2.27,1.67,1.75,
3.91,2.33,2.10,1.93, 4.10,2.71,2.37,2.15, 4.52,3.06,3.01,2.54,
1.00,1.00,1.00,1.00, 1.04,1.00,1.00,1.00, 1.12,1.00,1.00,1.00, 1.17,1.04,1.00,1.00,
1.27,1.04,1.00,1.00, 1.31,1.08,1.00,1.00, 1.43,1.08,1.01,1.04, 1.58,1.12,1.04,1.04,
1.73,1.15,1.08,1.07, 1.85,1.21,1.12,1.08, 1.92,1.28,1.12,1.08, 2.06,1.34,1.14,1.15,
2.12,1.37,1.15,1.19, 2.31,1.44,1.29,1.23, 2.47,1.57,1.35,1.27, 2.60,1.75,1.60,1.35,
2.81,1.90,1.68,1.46, 3.04,2.19,1.93,1.65, 3.67,2.47,2.56,2.12
),
stringsAsFactors = FALSE
)
stanine_acq_bsq_mi = data.frame(
skala = rep(c("BSQ","ACQ_gesamt","ACQ_koerperliche_krise",
"ACQ_kontrollverlust","MIA","MIB"), each = 9 * 4),
stanine = rep(rep(1:9, each = 4), times = 6),
gruppe = rep(rep(c("Paniksyndrom","Andere Angststoerungen",
"Psychosomat. Patienten ohne Angststoerung",
"Kontrollpersonen ohne psychische Stoerung"), times = 9), times = 6),
untergrenze = c(
1.000,1.000,1.000,1.000, 1.370,1.119,1.000,1.000, 1.707,1.295,1.000,1.000,
2.007,1.488,1.149,1.182, 2.413,1.766,1.307,1.413, 2.766,2.123,1.589,1.707,
3.198,2.514,2.001,2.060, 3.530,2.947,2.585,2.413, 3.867,3.302,3.170,2.589,
1.000,1.000,1.000,1.000, 1.144,1.000,1.000,1.000, 1.287,1.072,1.000,1.000,
1.501,1.215,1.000,1.072, 1.787,1.430,1.144,1.215, 2.072,1.715,1.287,1.287,
2.501,1.930,1.572,1.430, 2.799,2.258,1.787,1.787, 3.344,2.715,1.978,2.118,
1.00,1.00,1.00,1.00, 1.00,1.00,1.00,1.00, 1.21,1.00,1.00,1.00,
1.41,1.00,1.00,1.00, 1.81,1.00,1.00,1.00, 2.21,1.21,1.21,1.00,
2.61,1.61,1.41,1.21, 3.41,2.01,1.61,1.41, 3.81,2.21,2.01,1.81,
1.000,1.000,1.000,1.000, 1.000,1.000,1.000,1.000, 1.144,1.144,1.000,1.000,
1.342,1.287,1.000,1.144, 1.715,1.715,1.144,1.287, 2.001,1.858,1.287,1.430,
2.572,2.430,1.715,1.715, 2.921,2.944,2.144,2.145, 3.287,3.487,2.430,2.664,
1.000,1.000,1.000,1.000, 1.026,1.000,1.000,1.000, 1.305,1.080,1.000,1.000,
1.801,1.186,1.000,1.075, 2.334,1.380,1.112,1.190, 2.971,1.623,1.249,1.408,
3.588,1.963,1.496,1.685, 4.045,2.691,2.171,2.149, 4.619,3.077,3.263,2.601,
1.000,1.000,1.000,1.000, 1.000,1.000,1.000,1.000, 1.039,1.000,1.000,1.000,
1.229,1.039,1.000,1.000, 1.584,1.116,1.041,1.039, 2.061,1.342,1.137,1.151,
2.544,1.660,1.370,1.270, 3.001,2.076,1.913,1.616, 3.726,2.541,2.601,2.158
),
obergrenze = c(
1.369,1.118,5.000,5.000, 1.706,1.294,5.000,5.000, 2.006,1.487,1.148,1.181,
2.412,1.765,1.306,1.412, 2.765,2.122,1.588,1.706, 3.197,2.513,2.000,2.059,
3.529,2.946,2.584,2.412, 3.866,3.301,3.169,2.588, 5.000,5.000,5.000,5.000,
1.143,5.000,5.000,5.000, 1.286,1.071,5.000,5.000, 1.500,1.214,5.000,1.071,
1.786,1.429,1.143,1.214, 2.071,1.714,1.286,1.286, 2.500,1.929,1.571,1.429,
2.798,2.257,1.786,1.786, 3.343,2.714,1.977,2.117, 5.000,5.000,5.000,5.000,
1.00,1.00,1.00,1.00, 1.20,1.00,1.00,1.00, 1.40,1.00,1.00,1.00,
1.80,1.00,1.00,1.00, 2.20,1.20,1.20,1.00, 2.60,1.60,1.40,1.20,
3.40,2.00,1.60,1.40, 3.80,2.20,2.00,1.80, 5.00,5.00,5.00,5.00,
5.000,5.000,5.000,5.000, 1.143,1.143,5.000,5.000, 1.341,1.286,1.000,1.143,
1.714,1.714,1.143,1.286, 2.000,1.857,1.286,1.429, 2.571,2.429,1.714,1.714,
2.920,2.943,2.143,2.144, 3.286,3.486,2.429,2.663, 5.000,5.000,5.000,5.000,
1.025,5.000,5.000,5.000, 1.304,1.079,5.000,5.000, 1.800,1.185,1.000,1.074,
2.333,1.379,1.111,1.189, 2.970,1.622,1.248,1.407, 3.587,1.962,1.495,1.684,
4.044,2.690,2.170,2.148, 4.618,3.076,3.262,2.600, 5.000,5.000,5.000,5.000,
5.000,5.000,5.000,5.000, 1.038,5.000,5.000,5.000, 1.228,1.038,1.000,1.038,
1.583,1.115,1.040,1.038, 2.060,1.341,1.136,1.150, 2.543,1.659,1.369,1.269,
3.000,2.075,1.912,1.615, 3.725,2.540,2.600,2.157, 5.000,5.000,5.000,5.000
),
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;
}
.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: 8px; 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; }
.btn-laden { cursor: pointer; }
.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: 28px; flex-shrink: 0; font-size: 0.92em; }
.item-text { flex: 1; color: #333; font-size: 0.92em; line-height: 1.4; }
.score-zahl { font-size: 2.2rem; font-weight: 800; color: #8B2635; line-height: 1.1; }
.fussnote { font-size: 0.78em; color: #888; font-style: italic; margin-top: 10px; }
html { min-width: 1400px; }
.container-fluid { max-width: 1600px !important; margin: 0 auto !important; }
"
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("ACQ / BSQ / Mobilitaets-Inventar"),
tags$p("Fragebogen zu angstbezogenen Kognitionen, Angst vor koerperlichen Symptomen",
" und Mobilitaets-Inventar | Ehlers & Margraf")
),
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_acqbsqmi_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_weitere = fp_text(font.size = 11, italic = TRUE, bold = TRUE, color = "#666666")
fp_klein = fp_text(font.size = 9.5, color = "#555555")
fp_disc = fp_text(font.size = 9, italic = TRUE, color = "#777777")
fp_warn = fp_text(font.size = 10, color = "#BF360C")
acq_bsq_badge_fp = function(wert_num) {
farben = list(
"1" = list(bg = "#4CAF50", fg = "white"),
"2" = list(bg = "#F48FB1", fg = "#333333"),
"3" = list(bg = "#EF5350", fg = "white"),
"4" = list(bg = "#B71C1C", fg = "white"),
"5" = list(bg = "#4A0000", fg = "white")
)
key = if (is.na(wert_num)) "1" else
as.character(min(5L, max(1L, as.integer(round(wert_num)))))
f = farben[[key]]
fp_text(bold = TRUE, font.size = 10, color = f$fg, shading.color = f$bg)
}
score_und_normen = function(label, score_info, skala_key) {
score_txt = if (is.na(score_info$score)) "k. A." else sprintf("%.2f", score_info$score)
doc <<- body_add_fpar(doc, fpar(
ftext(paste0(label, ": "), fp_label),
ftext(score_txt, fp_normal)
))
if (!is.null(score_info$warnung))
doc <<- body_add_fpar(doc, fpar(ftext(score_info$warnung, fp_warn)))
doc <<- body_add_fpar(doc, fpar(
ftext(normen_text_word(score_info$score, skala_key), fp_klein)))
}
word_rang_acq_bsq = function(items, n_score, kurzlabels, weitere_text) {
alle_items = items[seq_len(min(n_score + 1L, length(items)))]
sortiert = alle_items[order(sapply(alle_items, function(x)
if (is.na(x$wert_num)) Inf else -x$wert_num
))]
make_badge_txt = function(item) {
if (!is.null(kurzlabels) && !is.na(item$wert_num)) {
idx = as.integer(round(item$wert_num))
if (idx >= 1L && idx <= length(kurzlabels)) return(kurzlabels[idx])
}
if (is.na(item$wert_text)) "k.A." else item$wert_text
}
rang_nr = 0L
for (item in sortiert) {
is_w = !item$in_score
if (!is_w) rang_nr = rang_nr + 1L
nr_label = if (is_w) "zus." else paste0(rang_nr, ".")
item_txt = if (is_w) {
if (!is.null(weitere_text)) paste0("Weitere: ", weitere_text)
else if (!is.na(item$text)) item$text else "Weitere"
} else {
paste0("(", item$nr, ") ",
if (is.na(item$text)) paste0("Item ", item$nr) else item$text)
}
fp_item = if (is_w) fp_weitere else fp_normal
if (!is.na(item$wert_num)) {
doc <<- body_add_fpar(doc, fpar(
ftext(paste0(nr_label, " ", item_txt, " "), fp_item),
ftext(paste0(" ", make_badge_txt(item), " "), acq_bsq_badge_fp(item$wert_num))
))
} else {
doc <<- body_add_fpar(doc, fpar(
ftext(paste0(nr_label, " ", item_txt), fp_item)))
}
}
}
word_rang_mi = function(mi_items) {
score_items = Filter(function(x) x$in_score, mi_items)
sortiert = score_items[order(sapply(score_items, function(x)
if (!x$zutreffend || is.na(x$allein_num)) Inf else -x$allein_num
))]
for (item in sortiert) {
sit_txt = if (is.na(item$text)) paste0("Situation ", item$nr) else item$text
if (!item$zutreffend) {
doc <<- body_add_fpar(doc, fpar(
ftext(paste0(item$nr, ". ", sit_txt, " betrifft nicht"), fp_weitere)))
} else {
delta = if (!is.na(item$allein_num) && !is.na(item$begl_num))
item$allein_num - item$begl_num else NA_real_
delta_s = if (is.na(delta)) "-" else sprintf("%+.1f", delta)
fp_delta = if (!is.na(delta) && delta >= 1.5)
fp_text(font.size = 10, bold = TRUE, color = "#B71C1C")
else if (!is.na(delta) && delta >= 0.5)
fp_text(font.size = 10, bold = TRUE, color = "#E65100")
else fp_klein
doc <<- body_add_fpar(doc, fpar(
ftext(paste0(item$nr, ". ", sit_txt, " "), fp_normal),
ftext(paste0("Allein: ", sprintf("%.1f", item$allein_num),
" | Begl: ", sprintf("%.1f", item$begl_num),
" | Delta: ", delta_s), fp_delta)
))
}
}
}
PLOT_W = 14 / 2.54
PLOT_H = 6 / 2.54
# Titel + Metadaten
doc = body_add_fpar(doc, fpar(
ftext("ACQ / BSQ / Mobilitaets-Inventar - Einzelauswertung", fp_titel)))
doc = body_add_fpar(doc, fpar(
ftext("Chiffre: ", fp_label),
ftext(erg$chiffre, fp_normal),
ftext(" Datum: ", fp_label),
ftext(erg$ausfuelldatum, fp_normal)
))
if (!is.null(erg$warnung_mehrere))
doc = body_add_fpar(doc, fpar(ftext(erg$warnung_mehrere, fp_klein)))
doc = body_add_par(doc, "", style = "Normal")
# ACQ Gesamt
doc = body_add_fpar(doc, fpar(ftext("ACQ Gesamtmittelwert", fp_abschnitt)))
score_und_normen("ACQ Gesamt", erg$acq_gesamt, "ACQ_gesamt")
doc = body_add_gg(doc,
value = make_vergleich_plot(erg$acq_gesamt$score, "ACQ_gesamt", "ACQ Gesamt"),
width = PLOT_W, height = PLOT_H)
word_rang_acq_bsq(erg$acq_items, 14,
c("nie", "selten", "~Haelfte", "gewoehnlich", "immer"),
erg$acq_15_text)
doc = body_add_par(doc, "", style = "Normal")
# ACQ Faktoren
doc = body_add_fpar(doc, fpar(ftext("ACQ Faktor: Koerperliche Krise", fp_abschnitt)))
score_und_normen("Koerperliche Krise", erg$acq_koerper, "ACQ_koerperliche_krise")
doc = body_add_gg(doc,
value = make_vergleich_plot(erg$acq_koerper$score, "ACQ_koerperliche_krise",
"ACQ Koerperliche Krise"),
width = PLOT_W, height = PLOT_H)
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("ACQ Faktor: Kontrollverlust", fp_abschnitt)))
score_und_normen("Kontrollverlust", erg$acq_kontroll, "ACQ_kontrollverlust")
doc = body_add_gg(doc,
value = make_vergleich_plot(erg$acq_kontroll$score, "ACQ_kontrollverlust",
"ACQ Kontrollverlust"),
width = PLOT_W, height = PLOT_H)
doc = body_add_par(doc, "", style = "Normal")
# BSQ
doc = body_add_fpar(doc, fpar(ftext("BSQ Gesamtmittelwert", fp_abschnitt)))
score_und_normen("BSQ Gesamt", erg$bsq_gesamt, "BSQ")
doc = body_add_gg(doc,
value = make_vergleich_plot(erg$bsq_gesamt$score, "BSQ", "BSQ Gesamt"),
width = PLOT_W, height = PLOT_H)
word_rang_acq_bsq(erg$bsq_items, 17,
c("nicht", "ein wenig", "mittelmaessig", "sehr", "extrem"),
erg$bsq_18_text)
doc = body_add_par(doc, "", style = "Normal")
# MI
doc = body_add_fpar(doc, fpar(ftext("Mobilitaets-Inventar", fp_abschnitt)))
score_und_normen("MIA (Vermeidung allein)", erg$mia, "MIA")
doc = body_add_gg(doc,
value = make_vergleich_plot(erg$mia$score, "MIA", "MI - Allein"),
width = PLOT_W, height = PLOT_H)
score_und_normen("MIB (Vermeidung in Begleitung)", erg$mib, "MIB")
doc = body_add_gg(doc,
value = make_vergleich_plot(erg$mib$score, "MIB", "MI - Begleitung"),
width = PLOT_W, height = PLOT_H)
word_rang_mi(erg$mi_items)
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(ACQBSQMI_DISCLAIMER, fp_disc)))
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)))
}
})
ergebnis_r = eventReactive(input$btn_suchen, {
chiffre = toupper(trimws(input$chiffre))
if ((nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0))
return(list(typ = "format_fehler",
meldung = "Bitte eine Patientenchiffre eingeben."))
if (!(nchar(trimws(input$pseudonym)) > 0 || grepl("^[A-Z][0-9]{6}$", chiffre)))
return(list(typ = "format_fehler",
meldung = paste0("Ungueltige Chiffre '", chiffre,
"'. Erwartet: ein Grossbuchstabe + 6 Ziffern (z.B. P000123).")))
if (!file.exists(PFAD_DOWNLOAD_SKRIPT))
return(list(typ = "skript_fehler",
meldung = paste0("Download-Skript nicht gefunden:\n", PFAD_DOWNLOAD_SKRIPT)))
if (!file.exists(PFAD_PSEUDONYM_SKRIPT))
return(list(typ = "skript_fehler",
meldung = paste0("Pseudonym-Skript nicht gefunden:\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
})
alter_wd = getwd()
on.exit(setwd(alter_wd), add = TRUE)
wd_ziel = if (!is.null(db_ordner)) db_ordner else
dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE))
setwd(wd_ziel)
ok2 = 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 (!ok2$ok)
return(list(typ = "skript_fehler",
meldung = paste0("Fehler im Pseudonym-Skript: ", ok2$msg)))
if (!exists("daten_acqbsqmi", envir = .GlobalEnv))
return(list(typ = "skript_fehler",
meldung = paste0("Objekt 'daten_acqbsqmi' nach Sourcen nicht gefunden. ",
"Bitte Download-Skript pruefen.")))
if (!exists("pseudo", envir = .GlobalEnv))
return(list(typ = "skript_fehler",
meldung = paste0("Objekt 'pseudo' nach Sourcen nicht gefunden. ",
"Bitte Pseudonym-Skript pruefen.")))
daten = get("daten_acqbsqmi", envir = .GlobalEnv)
pseudo_df = get("pseudo", envir = .GlobalEnv)
treffer_ps = pseudo_df[pseudo_df$chiffre == chiffre, ]
if (nrow(treffer_ps) == 0)
return(list(typ = "chiffre_fehler",
meldung = 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(typ = "chiffre_fehler",
meldung = paste0("Bogen fuer Chiffre '", chiffre,
"' noch nicht ausgefuellt. ",
"(", length(alle_session_ids), " Session(s) 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]
ausfuelldatum_str = tryCatch(
format(as.POSIXct(zeile[["created"]][1]), "%d.%m.%Y"),
error = function(e) format(Sys.Date(), "%d.%m.%Y")
)
acq_items = lapply(1:15, function(i) {
var = paste0("acq_", sprintf("%02d", i))
w = get_numeric_wert(zeile[[var]])
list(
nr = i,
nr_label = if (i <= 14) paste0(i, ".") else "",
text = clean_label(attr(daten[[var]], "label")),
wert_num = w,
wert_text = get_label_text(daten[[var]], zeile[[var]]),
in_score = i <= 14
)
})
acq_werte_gesamt = sapply(1:14, function(i)
get_numeric_wert(zeile[[paste0("acq_", sprintf("%02d", i))]]))
acq_gesamt = berechne_mittelwert_mit_warnung(acq_werte_gesamt, max_fehlend = 3)
acq_werte_koerper = sapply(c(2, 3, 4, 5, 10), function(i)
get_numeric_wert(zeile[[paste0("acq_", sprintf("%02d", i))]]))
acq_koerper = berechne_mittelwert_mit_warnung(acq_werte_koerper, max_fehlend = 1)
acq_werte_kontroll = sapply(c(6, 8, 9, 11, 12, 13, 14), function(i)
get_numeric_wert(zeile[[paste0("acq_", sprintf("%02d", i))]]))
acq_kontroll = berechne_mittelwert_mit_warnung(acq_werte_kontroll, max_fehlend = 1)
bsq_items = lapply(1:18, function(i) {
var = paste0("bsq_", sprintf("%02d", i))
w = get_numeric_wert(zeile[[var]])
list(
nr = i,
nr_label = if (i <= 17) paste0(i, ".") else "",
text = clean_label(attr(daten[[var]], "label")),
wert_num = w,
wert_text = get_label_text(daten[[var]], zeile[[var]]),
in_score = i <= 17
)
})
bsq_werte = sapply(1:17, function(i)
get_numeric_wert(zeile[[paste0("bsq_", sprintf("%02d", i))]]))
bsq_gesamt = berechne_mittelwert_mit_warnung(bsq_werte, max_fehlend = 3)
mi_items = lapply(1:28, function(i) {
var_z = paste0("mi_", sprintf("%02d", i), "_zutreffend")
var_b = paste0("mi_", sprintf("%02d", i), "_begl")
var_a = paste0("mi_", sprintf("%02d", i), "_allein")
ztref = mi_ist_zutreffend(daten[[var_z]], zeile[[var_z]])
begl_n = if (ztref) get_numeric_wert(zeile[[var_b]]) else NA_real_
allein_n = if (ztref) get_numeric_wert(zeile[[var_a]]) else NA_real_
list(
nr = i,
nr_label = if (i <= 27) paste0(i, ".") else "",
text = if (i <= length(MI_SITUATIONEN)) MI_SITUATIONEN[i] else NA_character_,
zutreffend = ztref,
begl_num = begl_n,
allein_num = allein_n,
in_score = i <= 27
)
})
werte_allein = sapply(1:27, function(i) mi_items[[i]]$allein_num)
werte_begl = sapply(1:27, function(i) mi_items[[i]]$begl_num)
n_valid_allein = sum(!is.na(werte_allein))
n_valid_begl = sum(!is.na(werte_begl))
mia_score = if (n_valid_allein == 0) NA_real_ else mean(werte_allein, na.rm = TRUE)
mib_score = if (n_valid_begl == 0) NA_real_ else mean(werte_begl, na.rm = TRUE)
mia_warnung = if (!is.na(mia_score) && n_valid_allein < 14)
paste0("Auswertung auf Basis von nur ", n_valid_allein,
" von 27 Situationen. Vorsicht bei der Interpretation.")
else NULL
mib_warnung = if (!is.na(mib_score) && n_valid_begl < 14)
paste0("Auswertung auf Basis von nur ", n_valid_begl,
" von 27 Situationen. Vorsicht bei der Interpretation.")
else NULL
mia = list(score = mia_score, n_vorhanden = n_valid_allein, warnung = mia_warnung)
mib = list(score = mib_score, n_vorhanden = n_valid_begl, warnung = mib_warnung)
list(
typ = "ok",
chiffre = chiffre,
ausfuelldatum = ausfuelldatum_str,
warnung_mehrere = info_mehrere,
acq_gesamt = acq_gesamt,
acq_koerper = acq_koerper,
acq_kontroll = acq_kontroll,
bsq_gesamt = bsq_gesamt,
mia = mia,
mib = mib,
acq_items = acq_items,
acq_15_text = raw_to_char_or_null(zeile[["acq_15_text"]]),
acq_top3 = raw_to_char_or_null(zeile[["acq_top3"]]),
bsq_items = bsq_items,
bsq_18_text = raw_to_char_or_null(zeile[["bsq_18_text"]]),
bsq_top3 = raw_to_char_or_null(zeile[["bsq_top3"]]),
mi_items = mi_items,
mi_28_text = raw_to_char_or_null(zeile[["mi_28_text"]])
)
})
output$fehler_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (!is.null(d$typ) && d$typ != "ok")
div(class = "alert-fehler", d$meldung)
else NULL
})
output$warnung_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (is.null(d$typ) || d$typ != "ok" || is.null(d$warnung_mehrere)) return(NULL)
div(class = "alert-warnung", d$warnung_mehrere)
})
output$ergebnis_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (is.null(d$typ) || d$typ != "ok") return(NULL)
div(
div(class = "abschnitt-karte",
div(class = "meta-block",
tags$strong("Chiffre: "), d$chiffre,
tags$span(" | ", style = "color:#ddd;"),
tags$strong("Ausfuelldatum: "), d$ausfuelldatum
),
div(class = "abschnitt-titel", "Scores - Uebersicht"),
fluidRow(
column(6, score_block_ui(d$acq_gesamt, "ACQ_gesamt", "ACQ Gesamt", "plot_acq_gesamt")),
column(6, score_block_ui(d$bsq_gesamt, "BSQ", "BSQ Gesamt", "plot_bsq_gesamt"))
),
tags$hr(style = "margin:14px 0;"),
div(class = "abschnitt-titel", style = "font-size:1rem; margin-bottom:8px;",
"ACQ Faktoren"),
fluidRow(
column(6, score_block_ui(d$acq_koerper, "ACQ_koerperliche_krise",
"Koerperliche Krise", "plot_acq_koerper")),
column(6, score_block_ui(d$acq_kontroll, "ACQ_kontrollverlust",
"Kontrollverlust", "plot_acq_kontroll"))
),
tags$hr(style = "margin:14px 0;"),
div(class = "abschnitt-titel", style = "font-size:1rem; margin-bottom:8px;",
"Mobilitaets-Inventar"),
{
mi_warns = unique(Filter(Negate(is.null), list(d$mia$warnung, d$mib$warnung)))
lapply(mi_warns, function(w) div(class = "alert-warnung", w))
},
fluidRow(
column(6,
div(class = "score-zahl",
if (is.na(d$mia$score)) "k.A." else sprintf("%.2f", d$mia$score)),
div("MIA (Allein)", style = "color:#555; font-size:0.82em;"),
normen_tabelle_html(d$mia$score, "MIA"),
plotOutput("plot_mia", height = "155px")
),
column(6,
div(class = "score-zahl",
if (is.na(d$mib$score)) "k.A." else sprintf("%.2f", d$mib$score)),
div("MIB (Begleitung)", style = "color:#555; font-size:0.82em;"),
normen_tabelle_html(d$mib$score, "MIB"),
plotOutput("plot_mib", height = "155px")
)
)
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Inhaltliche Rangfolge"),
fluidRow(
column(4,
tags$h6(style = "color:#555; margin-bottom:6px;",
"ACQ - Gedanken nach Haeufigkeit"),
div(render_rang_acq_bsq(d$acq_items, 14,
c("nie", "selten", "~Haelfte", "gewoehnlich", "immer"),
weitere_text = d$acq_15_text))
),
column(4,
tags$h6(style = "color:#555; margin-bottom:6px;",
"BSQ - Empfindungen nach Belastung"),
div(render_rang_acq_bsq(d$bsq_items, 17,
c("nicht", "ein wenig", "mittelmaessig", "sehr", "extrem"),
weitere_text = d$bsq_18_text))
),
column(4,
tags$h6(style = "color:#555; margin-bottom:6px;",
"MI - Allein absteigend | Delta = Allein minus Begl."),
div(render_rang_mi(d$mi_items))
)
)
),
)
})
output$plot_acq_gesamt = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(!is.null(d$typ) && d$typ == "ok")
make_vergleich_plot(d$acq_gesamt$score, "ACQ_gesamt", "ACQ Gesamt")
}, bg = "transparent")
output$plot_bsq_gesamt = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(!is.null(d$typ) && d$typ == "ok")
make_vergleich_plot(d$bsq_gesamt$score, "BSQ", "BSQ Gesamt")
}, bg = "transparent")
output$plot_mia = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(!is.null(d$typ) && d$typ == "ok")
make_vergleich_plot(d$mia$score, "MIA", "MIA (Vermeidung allein)")
}, bg = "transparent")
output$plot_mib = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(!is.null(d$typ) && d$typ == "ok")
make_vergleich_plot(d$mib$score, "MIB", "MIB (Vermeidung in Begleitung)")
}, bg = "transparent")
output$plot_acq_koerper = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(!is.null(d$typ) && d$typ == "ok")
make_vergleich_plot(d$acq_koerper$score, "ACQ_koerperliche_krise", "Koerperliche Krise")
}, bg = "transparent")
output$plot_acq_kontroll = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(!is.null(d$typ) && d$typ == "ok")
make_vergleich_plot(d$acq_kontroll$score, "ACQ_kontrollverlust", "Kontrollverlust")
}, 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$typ) && d$typ == "ok")
d$chiffre else "export"
ausfuelldatum_fn = if (is.list(d) && !is.null(d$typ) && d$typ == "ok")
tryCatch(
format(as.Date(d$ausfuelldatum, "%d.%m.%Y"), "%Y%m%d"),
error = function(e) format(Sys.Date(), "%Y%m%d")
)
else format(Sys.Date(), "%Y%m%d")
paste0("ACQBSQMI_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
},
content = function(file) {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
if (is.null(d) || is.null(d$typ) || d$typ != "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_acqbsqmi_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)