1209 lines
47 KiB
R
1209 lines
47 KiB
R
# Präambel ####
|
|
|
|
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_staxi2.R"
|
|
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
|
|
PFAD_NORMTABELLEN = "normtabellen"
|
|
AKZENT_FARBE = "#8B2635"
|
|
|
|
STAXI2_DISCLAIMER = paste0(
|
|
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
|
|
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person."
|
|
)
|
|
|
|
# 5 Klassifikationsstufen fuer T-Werte (Abschnitt 9): <30, 30-39, 40-60, 61-70, >70.
|
|
STAXI2_STUFEN_FARBEN = c(
|
|
"0" = "#1B5E20",
|
|
"1" = "#81C784",
|
|
"2" = "#9E9E9E",
|
|
"3" = "#FFB74D",
|
|
"4" = "#C62828"
|
|
)
|
|
STAXI2_STUFEN_TEXT_FARBEN = c(
|
|
"0" = "white", "1" = "#222222", "2" = "white", "3" = "#222222", "4" = "white"
|
|
)
|
|
|
|
# Farben fuer Einzelitem-Antwortbadges (Rohcode 1-4, unabhaengig von der
|
|
# jeweiligen Antwortskala aus Teil 1 bzw. Teil 2/3).
|
|
STAXI2_ANTWORT_FARBEN = c(
|
|
"1" = "#4CAF50", "2" = "#F48FB1", "3" = "#EF5350", "4" = "#B71C1C"
|
|
)
|
|
STAXI2_ANTWORT_TEXT_FARBEN = c(
|
|
"1" = "white", "2" = "#333333", "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 ####
|
|
|
|
labels_teil1 = c("ueberhaupt nicht" = 1, "ein wenig" = 2, "ziemlich" = 3, "sehr" = 4)
|
|
labels_teil23 = c("fast nie" = 1, "manchmal" = 2, "oft" = 3, "fast immer" = 4)
|
|
|
|
# Normalisiert Labeltext fuer den Vergleich: Markdown-Sternchen und Umlaute
|
|
# (formr liefert echte Umlaute wie "ueberhaupt", waehrend hier aus
|
|
# Kodierungssicherheitsgruenden ASCII-Text hinterlegt ist) sowie
|
|
# Interpunktion/Gross-Kleinschreibung/Mehrfach-Leerzeichen vereinheitlichen.
|
|
staxi2_normalisiere_label = function(x) {
|
|
x = gsub("\\*\\*", "", x)
|
|
x = tolower(trimws(x))
|
|
x = gsub("[[:punct:]]", "", x)
|
|
x = gsub("\\s+", " ", x)
|
|
x = trimws(x)
|
|
x = gsub("ä", "ae", x, fixed = TRUE)
|
|
x = gsub("ö", "oe", x, fixed = TRUE)
|
|
x = gsub("ü", "ue", x, fixed = TRUE)
|
|
x = gsub("ß", "ss", x, fixed = TRUE)
|
|
x
|
|
}
|
|
|
|
# Validiert das labels-Attribut der ORIGINAL-Spalte gegen die erwartete Kodierung,
|
|
# bevor der numerische Rohwert uebernommen wird. Nie den Antwortcode ungeprueft
|
|
# als Positionsnummer annehmen.
|
|
item_wert = function(spalte, erwartete_labels) {
|
|
labels_attr = attr(spalte, "labels")
|
|
if (is.null(labels_attr)) {
|
|
stop("Kein labels-Attribut gefunden, Itemkodierung kann nicht validiert werden.")
|
|
}
|
|
namen_normalisiert = sort(sapply(names(labels_attr), staxi2_normalisiere_label, USE.NAMES = FALSE))
|
|
namen_erwartet = sort(sapply(names(erwartete_labels), staxi2_normalisiere_label, USE.NAMES = FALSE))
|
|
passt = identical(namen_normalisiert, namen_erwartet)
|
|
if (!passt) {
|
|
stop(paste0(
|
|
"Itemlabels weichen von der erwarteten Kodierung ab, Rohwertberechnung abgebrochen. ",
|
|
"Gefunden: ", paste(namen_normalisiert, collapse = " | "),
|
|
" Erwartet: ", paste(namen_erwartet, collapse = " | ")))
|
|
}
|
|
as.numeric(spalte)
|
|
}
|
|
|
|
# Loest den Antworttext einer labelled Spalte ueber deren labels-Attribut auf,
|
|
# nie ueber den Rohwert direkt (z.B. bei staxi2_geschlecht, dessen 1/2-Kodierung
|
|
# nicht hartkodiert angenommen werden darf).
|
|
staxi2_label_text = function(spalte_original, wert) {
|
|
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_character_)
|
|
labels_attr = attr(spalte_original, "labels")
|
|
if (is.null(labels_attr) || length(labels_attr) == 0) return(NA_character_)
|
|
pos = which(as.vector(labels_attr) == suppressWarnings(as.numeric(wert[1])))
|
|
if (length(pos) == 0) return(NA_character_)
|
|
trimws(names(labels_attr)[pos[1]])
|
|
}
|
|
|
|
# Entfernt Markdown-Reste (Fettschrift-Sternchen, escapte Punkte) und die
|
|
# fuehrende Itemnummer aus Item-/Antworttexten fuer die Anzeige (formr
|
|
# liefert z.B. "3\\. Es aergert mich..." statt "Es aergert mich...";
|
|
# die Itemnummer wird ohnehin separat als eigenes Badge angezeigt).
|
|
staxi2_bereinige_text = function(x) {
|
|
if (is.null(x) || length(x) == 0 || is.na(x[1])) return(NA_character_)
|
|
text = as.character(x[1])
|
|
text = gsub("\\*\\*", "", text)
|
|
text = gsub("\\.", ".", text, fixed = TRUE)
|
|
text = sub("^\\s*\\d+\\.\\s*", "", text)
|
|
trimws(text)
|
|
}
|
|
|
|
altersgruppe_von = function(alter) {
|
|
alter = as.numeric(alter)
|
|
if (is.na(alter)) return(NA_character_)
|
|
if (alter < 16) return(NA_character_)
|
|
if (alter <= 39) return("16_39")
|
|
if (alter <= 59) return("40_59")
|
|
return("60plus")
|
|
}
|
|
|
|
# Missing-Value-Regel je Skala: >= 2 fehlende Items -> nicht auswertbar;
|
|
# 1 fehlendes Item -> Ersatzwert aus dem gerundeten Mittelwert der uebrigen
|
|
# Items derselben Skala; 0 fehlende Items -> normale Summe.
|
|
staxi2_score_skala = function(werte) {
|
|
n_missing = sum(is.na(werte))
|
|
if (n_missing >= 2) {
|
|
return(list(rohwert = NA_real_, missing_n = n_missing, auswertbar = FALSE))
|
|
}
|
|
if (n_missing == 1) {
|
|
ersatz = round(mean(werte, na.rm = TRUE))
|
|
werte[is.na(werte)] = ersatz
|
|
}
|
|
list(rohwert = sum(werte), missing_n = n_missing, auswertbar = TRUE)
|
|
}
|
|
|
|
# Exakter Rohwert-Lookup in einer Normtabelle. Kein Treffer oder leeres Feld
|
|
# (Rohwert ausserhalb der Eichstichprobe) -> naechstgelegenen verfuegbaren Wert
|
|
# verwenden und das sichtbar als Notloesung kennzeichnen.
|
|
norm_lookup = function(tabelle, rohwert) {
|
|
zeile = tabelle[tabelle$rohwert == rohwert, ]
|
|
if (nrow(zeile) == 1 && !is.na(zeile$t_wert)) {
|
|
return(list(t_wert = zeile$t_wert, prozentrang = zeile$prozentrang, ausserhalb_eichstichprobe = FALSE))
|
|
}
|
|
gueltig = tabelle[!is.na(tabelle$t_wert), ]
|
|
if (nrow(gueltig) == 0) stop("Keine gueltigen Normwerte in dieser Tabelle.")
|
|
index_naechster = which.min(abs(gueltig$rohwert - rohwert))
|
|
list(
|
|
t_wert = gueltig$t_wert[index_naechster],
|
|
prozentrang = gueltig$prozentrang[index_naechster],
|
|
ausserhalb_eichstichprobe = TRUE
|
|
)
|
|
}
|
|
|
|
staxi2_klassifiziere = function(t_wert) {
|
|
if (is.null(t_wert) || length(t_wert) == 0 || is.na(t_wert)) {
|
|
return(list(stufe = NA_integer_, text = "nicht bestimmbar", farbe = "#9E9E9E"))
|
|
}
|
|
if (t_wert < 30) return(list(stufe = 0L, text = "stark unterdurchschnittlich", farbe = unname(STAXI2_STUFEN_FARBEN["0"])))
|
|
if (t_wert <= 39) return(list(stufe = 1L, text = "unterdurchschnittlich", farbe = unname(STAXI2_STUFEN_FARBEN["1"])))
|
|
if (t_wert <= 60) return(list(stufe = 2L, text = "durchschnittlich", farbe = unname(STAXI2_STUFEN_FARBEN["2"])))
|
|
if (t_wert <= 70) return(list(stufe = 3L, text = "ueberdurchschnittlich", farbe = unname(STAXI2_STUFEN_FARBEN["3"])))
|
|
list(stufe = 4L, text = "stark ueberdurchschnittlich", farbe = unname(STAXI2_STUFEN_FARBEN["4"]))
|
|
}
|
|
|
|
# Zeile aus Tabelle 6 (Standardmessfehler/Konfidenzintervalle/kritische Differenzen)
|
|
# nachschlagen. Die bekannte Luecke AC-I/frauen/40_59 wird explizit als solche
|
|
# markiert (kein Ersatzwert, keine Nachbarzeile), siehe Abschnitt 8.
|
|
tabelle6_lookup = function(tabelle6, skala, geschlecht, altersgruppe) {
|
|
zeile = tabelle6[
|
|
tabelle6$skala == skala &
|
|
tabelle6$geschlecht == geschlecht &
|
|
tabelle6$altersgruppe == altersgruppe, , drop = FALSE
|
|
]
|
|
if (nrow(zeile) == 0) {
|
|
return(list(gefunden = FALSE, luecke = FALSE))
|
|
}
|
|
if (identical(trimws(as.character(zeile$alpha[1])), "FEHLT_IM_SCAN")) {
|
|
return(list(gefunden = FALSE, luecke = TRUE))
|
|
}
|
|
list(
|
|
gefunden = TRUE,
|
|
luecke = FALSE,
|
|
alpha = suppressWarnings(as.numeric(zeile$alpha[1])),
|
|
se = suppressWarnings(as.numeric(zeile$se[1])),
|
|
ci90 = suppressWarnings(as.numeric(zeile$ci90[1])),
|
|
ci95 = suppressWarnings(as.numeric(zeile$ci95[1])),
|
|
ci99 = suppressWarnings(as.numeric(zeile$ci99[1])),
|
|
kritdiff_zweiseitig_5 = suppressWarnings(as.numeric(zeile$kritdiff_zweiseitig_5[1]))
|
|
)
|
|
}
|
|
|
|
# Optionale, sichtbar gekennzeichnete Notloesung fuer AC-I/frauen/40_59, nur
|
|
# auf explizite Nutzeranforderung eingeblendet (siehe Abschnitt 8).
|
|
STAXI2_ACI_NOTLOESUNG = list(
|
|
list(bezeichnung = "AC-I, Frauen, 60+", alpha = 0.79, se = 4.58),
|
|
list(bezeichnung = "AC-I, Gesamt, 40-59", alpha = 0.80, se = 4.47)
|
|
)
|
|
|
|
make_gauge_staxi2 = function(t_wert) {
|
|
zonen = data.frame(
|
|
xmin = c(20, 30, 40, 60, 70),
|
|
xmax = c(30, 40, 60, 70, 80),
|
|
farbe = c(unname(STAXI2_STUFEN_FARBEN["0"]), unname(STAXI2_STUFEN_FARBEN["1"]),
|
|
unname(STAXI2_STUFEN_FARBEN["2"]), unname(STAXI2_STUFEN_FARBEN["3"]),
|
|
unname(STAXI2_STUFEN_FARBEN["4"])),
|
|
stringsAsFactors = FALSE
|
|
)
|
|
|
|
p = ggplot() +
|
|
geom_rect(data = zonen, aes(xmin = xmin, xmax = xmax, ymin = 0, ymax = 1, fill = farbe),
|
|
color = "white", linewidth = 0.6) +
|
|
scale_fill_identity() +
|
|
scale_x_continuous(limits = c(20, 80), breaks = c(20, 30, 40, 50, 60, 70, 80)) +
|
|
scale_y_continuous(limits = c(-0.35, 1.35)) +
|
|
labs(x = "T-Wert", y = NULL) +
|
|
theme_minimal(base_size = 11) +
|
|
theme(
|
|
axis.text.y = element_blank(),
|
|
axis.ticks.y = element_blank(),
|
|
panel.grid = element_blank(),
|
|
plot.background = element_rect(fill = "white", colour = NA),
|
|
panel.background = element_rect(fill = "white", colour = NA),
|
|
plot.margin = margin(t = 14, r = 8, b = 4, l = 8)
|
|
)
|
|
|
|
if (!is.na(t_wert)) {
|
|
t_geklemmt = max(20, min(80, t_wert))
|
|
p = p +
|
|
geom_segment(aes(x = t_geklemmt, xend = t_geklemmt, y = -0.15, yend = 1.15),
|
|
color = AKZENT_FARBE, linewidth = 2.2, lineend = "round") +
|
|
annotate("text", x = t_geklemmt, y = 1.27, label = paste0("T = ", round(t_wert)),
|
|
color = AKZENT_FARBE, fontface = "bold", size = 3.6)
|
|
}
|
|
p
|
|
}
|
|
|
|
make_profil_plot_staxi2 = function(werte) {
|
|
skalen = names(werte)
|
|
n = length(skalen)
|
|
df_punkte = data.frame(x = seq_len(n), t_wert = as.numeric(werte))
|
|
|
|
zonen = data.frame(
|
|
ymin = c(20, 30, 40, 60, 70),
|
|
ymax = c(30, 40, 60, 70, 80),
|
|
farbe = c(unname(STAXI2_STUFEN_FARBEN["0"]), unname(STAXI2_STUFEN_FARBEN["1"]),
|
|
unname(STAXI2_STUFEN_FARBEN["2"]), unname(STAXI2_STUFEN_FARBEN["3"]),
|
|
unname(STAXI2_STUFEN_FARBEN["4"])),
|
|
stringsAsFactors = FALSE
|
|
)
|
|
|
|
ggplot() +
|
|
geom_rect(data = zonen,
|
|
aes(xmin = 0.5, xmax = n + 0.5, ymin = ymin, ymax = ymax, fill = farbe),
|
|
alpha = 0.55) +
|
|
scale_fill_identity() +
|
|
geom_line(data = df_punkte, aes(x = x, y = t_wert), color = AKZENT_FARBE,
|
|
linewidth = 1.1, na.rm = TRUE) +
|
|
geom_point(data = df_punkte, aes(x = x, y = t_wert), color = AKZENT_FARBE,
|
|
size = 3.2, na.rm = TRUE) +
|
|
geom_text(data = df_punkte,
|
|
aes(x = x, y = t_wert, label = ifelse(is.na(t_wert), "", as.character(round(t_wert)))),
|
|
vjust = -1.1, color = AKZENT_FARBE, fontface = "bold", size = 3.6) +
|
|
scale_x_continuous(breaks = seq_len(n), labels = skalen, limits = c(0.5, n + 0.5)) +
|
|
scale_y_continuous(limits = c(18, 82), breaks = c(20, 30, 40, 50, 60, 70, 80)) +
|
|
labs(x = NULL, y = "T-Wert") +
|
|
theme_minimal(base_size = 12) +
|
|
theme(
|
|
panel.grid.minor = element_blank(),
|
|
plot.background = element_rect(fill = "white", colour = NA),
|
|
panel.background = element_rect(fill = "white", colour = NA),
|
|
axis.text.x = element_text(face = "bold", color = "#333333")
|
|
)
|
|
}
|
|
|
|
|
|
# Datenaufbereitung ####
|
|
|
|
alle_s_cols = sprintf("staxi2_s_%02d", 1:15)
|
|
alle_t_cols = sprintf("staxi2_t_%02d", 1:10)
|
|
alle_e_cols = sprintf("staxi2_e_%02d", 1:26)
|
|
|
|
STAXI2_SKALEN = list(
|
|
"S-Ang/F" = paste0("staxi2_s_", sprintf("%02d", c(1, 4, 6, 9, 11))),
|
|
"S-Ang/V" = paste0("staxi2_s_", sprintf("%02d", c(2, 5, 8, 13, 15))),
|
|
"S-Ang/P" = paste0("staxi2_s_", sprintf("%02d", c(3, 7, 10, 12, 14))),
|
|
"T-Ang/T" = paste0("staxi2_t_", sprintf("%02d", c(1, 2, 5, 8, 10))),
|
|
"T-Ang/R" = paste0("staxi2_t_", sprintf("%02d", c(3, 4, 6, 7))),
|
|
"AX-O" = paste0("staxi2_e_", sprintf("%02d", c(3, 6, 12, 14, 16, 18, 24, 25))),
|
|
"AX-I" = paste0("staxi2_e_", sprintf("%02d", c(2, 8, 11, 13, 15, 19, 22, 26))),
|
|
"AC-O" = paste0("staxi2_e_", sprintf("%02d", c(1, 5, 9, 20, 23))),
|
|
"AC-I" = paste0("staxi2_e_", sprintf("%02d", c(4, 7, 10, 17, 21)))
|
|
)
|
|
STAXI2_SKALEN[["S-Ang"]] = c(STAXI2_SKALEN[["S-Ang/F"]], STAXI2_SKALEN[["S-Ang/V"]], STAXI2_SKALEN[["S-Ang/P"]])
|
|
STAXI2_SKALEN[["T-Ang"]] = c(STAXI2_SKALEN[["T-Ang/T"]], STAXI2_SKALEN[["T-Ang/R"]], "staxi2_t_09")
|
|
STAXI2_SKALEN[["AC"]] = c(STAXI2_SKALEN[["AC-O"]], STAXI2_SKALEN[["AC-I"]])
|
|
|
|
STAXI2_WERTEBEREICH = list(
|
|
"S-Ang/F" = c(5, 20), "S-Ang/V" = c(5, 20), "S-Ang/P" = c(5, 20), "S-Ang" = c(15, 60),
|
|
"T-Ang/T" = c(5, 20), "T-Ang/R" = c(4, 16), "T-Ang" = c(10, 40),
|
|
"AX-O" = c(8, 32), "AX-I" = c(8, 32),
|
|
"AC-O" = c(5, 20), "AC-I" = c(5, 20), "AC" = c(10, 40)
|
|
)
|
|
|
|
STAXI2_STATE_SKALEN = c("S-Ang", "S-Ang/F", "S-Ang/V", "S-Ang/P")
|
|
STAXI2_NORMIERTE_SKALEN = c("T-Ang", "T-Ang/T", "T-Ang/R", "AX-O", "AX-I", "AC", "AC-O", "AC-I")
|
|
STAXI2_HAUPTSKALEN_PROFIL = c("T-Ang", "AX-O", "AX-I", "AC")
|
|
|
|
STAXI2_SKALA_DATEIPRAEFIX = c(
|
|
"T-Ang" = "t_ang",
|
|
"T-Ang/T" = "t_ang_t",
|
|
"T-Ang/R" = "t_ang_r",
|
|
"AX-O" = "ax_o",
|
|
"AX-I" = "ax_i",
|
|
"AC" = "ac",
|
|
"AC-O" = "ac_o",
|
|
"AC-I" = "ac_i"
|
|
)
|
|
|
|
STAXI2_ALTERSGRUPPEN = c("16_39", "40_59", "60plus")
|
|
STAXI2_ALTERSGRUPPEN_LABEL = c("16_39" = "16-39 Jahre", "40_59" = "40-59 Jahre", "60plus" = "60+ Jahre")
|
|
STAXI2_GESCHLECHTER = c("gesamt", "maenner", "frauen")
|
|
|
|
if (!dir.exists(PFAD_NORMTABELLEN)) {
|
|
stop(paste0("Normtabellen-Ordner nicht gefunden: ", PFAD_NORMTABELLEN,
|
|
". Bitte den Ordner 'normtabellen/' mit den 73 CSV-Dateien neben app.R ablegen."))
|
|
}
|
|
|
|
staxi2_normtabellen = list()
|
|
for (praefix in STAXI2_SKALA_DATEIPRAEFIX) {
|
|
staxi2_normtabellen[[praefix]] = list()
|
|
for (ag in STAXI2_ALTERSGRUPPEN) {
|
|
staxi2_normtabellen[[praefix]][[ag]] = list()
|
|
for (gs in STAXI2_GESCHLECHTER) {
|
|
dateiname = paste0(praefix, "_", ag, "_", gs, ".csv")
|
|
pfad = file.path(PFAD_NORMTABELLEN, dateiname)
|
|
if (!file.exists(pfad)) {
|
|
stop(paste0("Normtabelle nicht gefunden: ", pfad))
|
|
}
|
|
tab = tryCatch(
|
|
read.csv(pfad, stringsAsFactors = FALSE, na.strings = c("", "NA")),
|
|
error = function(e) stop(paste0("Fehler beim Einlesen von '", dateiname, "': ", e$message))
|
|
)
|
|
for (spalte in c("rohwert", "t_wert", "prozentrang")) {
|
|
if (!(spalte %in% names(tab))) {
|
|
stop(paste0("Normtabelle '", dateiname, "' hat keine Spalte '", spalte, "'."))
|
|
}
|
|
}
|
|
staxi2_normtabellen[[praefix]][[ag]][[gs]] = tab
|
|
}
|
|
}
|
|
}
|
|
|
|
PFAD_TABELLE6 = file.path(PFAD_NORMTABELLEN, "tabelle6_standardmessfehler_konfidenzintervalle.csv")
|
|
if (!file.exists(PFAD_TABELLE6)) {
|
|
stop(paste0("Tabelle 6 (Standardmessfehler/Konfidenzintervalle) nicht gefunden: ", PFAD_TABELLE6))
|
|
}
|
|
staxi2_tabelle6 = tryCatch(
|
|
read.csv(PFAD_TABELLE6, stringsAsFactors = FALSE, na.strings = c("", "NA")),
|
|
error = function(e) stop(paste0("Fehler beim Einlesen von Tabelle 6: ", e$message))
|
|
)
|
|
|
|
|
|
# UI ####
|
|
|
|
app_css = "
|
|
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; }
|
|
.container-fluid { max-width: 1150px; }
|
|
.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; }
|
|
.hinweis-block {
|
|
font-size: 0.86em; color: #777; font-style: italic; margin-bottom: 12px;
|
|
}
|
|
.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: #1B5E20; color: white; }
|
|
.stufe-badge-1 { background: #81C784; color: #222222; }
|
|
.stufe-badge-2 { background: #9E9E9E; color: white; }
|
|
.stufe-badge-3 { background: #FFB74D; color: #222222; }
|
|
.stufe-badge-4 { background: #C62828; color: white; }
|
|
.skalen-grid { display: flex; gap: 16px; flex-wrap: wrap; }
|
|
.skala-block {
|
|
flex: 1; min-width: 300px; border: 1px solid #eee; border-radius: 6px;
|
|
padding: 12px 14px; margin-bottom: 12px;
|
|
}
|
|
.skala-titel { font-weight: 700; color: #333; margin-bottom: 6px; }
|
|
.rohwert-anzeige { font-size: 1.7rem; font-weight: 800; color: #222; }
|
|
.rohwert-hinweis { color: #777; font-size: 0.86em; margin-top: 2px; }
|
|
.ci-info { color: #555; font-size: 0.88em; margin-top: 6px; }
|
|
.state-grid { display: flex; gap: 14px; flex-wrap: wrap; margin-bottom: 10px; }
|
|
.state-block { flex: 1; min-width: 160px; text-align: center; padding: 8px; }
|
|
.state-label { color: #777; font-size: 0.85em; }
|
|
.item-liste { margin-top: 10px; border-top: 1px solid #eee; padding-top: 4px; }
|
|
.antwort-badge {
|
|
border-radius: 3px; padding: 2px 8px; font-weight: 700;
|
|
font-size: 0.8em; white-space: nowrap; display: inline-block;
|
|
flex-shrink: 0; min-width: 70px; text-align: center;
|
|
}
|
|
.antwort-badge-1 { background: #4CAF50; color: white; }
|
|
.antwort-badge-2 { background: #F48FB1; color: #333333; }
|
|
.antwort-badge-3 { background: #EF5350; color: white; }
|
|
.antwort-badge-4 { background: #B71C1C; color: white; }
|
|
.antwort-badge-fehlend { background: #BDBDBD; 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("STAXI-2 - State-Trait-Aergerausdrucks-Inventar 2"),
|
|
tags$p("Deutsche Version, Verlag Hans Huber/Hogrefe | Einzelfall-Auswertung")
|
|
),
|
|
|
|
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_staxi2_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_warnung = fp_text(font.size = 10, italic = TRUE, color = "#BF360C")
|
|
fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
|
|
|
|
# Einzelitems einer Skala als eigene Zeilen mit farbigem Antwortbadge,
|
|
# gleiche Reihenfolge/Aufbereitung wie in der UI (e$items ist bereits
|
|
# nach Rohwert absteigend sortiert, Markdown/Nummer bereits bereinigt).
|
|
fuege_item_liste_hinzu = function(doc, items) {
|
|
if (is.null(items) || length(items) == 0) return(doc)
|
|
for (it in items) {
|
|
item_text = if (is.na(it$text) || nchar(it$text) == 0) paste0("Item ", it$nr) else it$text
|
|
if (is.na(it$wert)) {
|
|
badge_farbe = "#BDBDBD"
|
|
badge_text_farbe = "white"
|
|
badge_text = "fehlend"
|
|
} else {
|
|
wert_key = as.character(it$wert)
|
|
badge_farbe = unname(STAXI2_ANTWORT_FARBEN[wert_key])
|
|
badge_text_farbe = unname(STAXI2_ANTWORT_TEXT_FARBEN[wert_key])
|
|
badge_text = if (!is.na(it$antwort_text) && nchar(it$antwort_text) > 0) {
|
|
paste0(it$wert, " - ", it$antwort_text)
|
|
} else {
|
|
as.character(it$wert)
|
|
}
|
|
}
|
|
doc = body_add_fpar(doc, fpar(
|
|
ftext(sprintf(" %2d. ", it$nr), fp_text(bold = TRUE, font.size = 9, color = "#888888")),
|
|
ftext(paste0(item_text, " "), fp_text(font.size = 9, color = "#333333")),
|
|
ftext(paste0(" ", badge_text, " "),
|
|
fp_text(color = badge_text_farbe, bold = TRUE, font.size = 9, shading.color = badge_farbe))
|
|
))
|
|
}
|
|
doc
|
|
}
|
|
|
|
doc = body_add_fpar(doc, fpar(ftext("STAXI-2", fp_titel)))
|
|
doc = body_add_fpar(doc, fpar(
|
|
ftext("Chiffre: ", fp_label), ftext(erg$chiffre, fp_normal),
|
|
ftext(" Ausfuelldatum: ", fp_label), ftext(erg$ausfuelldatum, fp_normal),
|
|
ftext(" Alter: ", fp_label),
|
|
ftext(if (is.na(erg$alter)) "k. A." else as.character(erg$alter), fp_normal),
|
|
ftext(" Geschlecht: ", fp_label),
|
|
ftext(if (is.na(erg$geschlecht_gruppe)) "nicht zuordenbar" else erg$geschlecht_gruppe, fp_normal)
|
|
))
|
|
if (!is.null(erg$mehrfach_warnung)) {
|
|
doc = body_add_fpar(doc, fpar(ftext(
|
|
paste0("Mehrere Ausfuellungen gefunden (", erg$mehrfach_warnung$n,
|
|
" Eintraege), es wird die neueste angezeigt."), fp_warnung
|
|
)))
|
|
}
|
|
if (isTRUE(erg$altersgruppe_zu_jung)) {
|
|
doc = body_add_fpar(doc, fpar(ftext(
|
|
"Alter unter 16 Jahren, das Instrument ist ab 16 Jahren normiert. Keine Normwerte.",
|
|
fp_warnung
|
|
)))
|
|
}
|
|
if (isTRUE(erg$geschlecht_unbekannt)) {
|
|
doc = body_add_fpar(doc, fpar(ftext(
|
|
"Geschlecht nicht eindeutig zuordenbar, Normwerte konnten nicht berechnet werden.",
|
|
fp_warnung
|
|
)))
|
|
}
|
|
doc = body_add_par(doc, "", style = "Normal")
|
|
|
|
doc = body_add_fpar(doc, fpar(ftext("Teil 1 - State-Aerger (S-Ang)", fp_abschnitt)))
|
|
doc = body_add_fpar(doc, fpar(ftext(
|
|
"Fuer diese Skala werden laut Testmanual keine Normwerte ausgewiesen (nur Rohwerte).",
|
|
fp_disclaimer
|
|
)))
|
|
for (sk in STAXI2_STATE_SKALEN) {
|
|
e = erg$skalen[[sk]]
|
|
txt = if (isTRUE(e$auswertbar)) paste0(sk, ": ", e$rohwert) else paste0(sk, ": nicht auswertbar (zu viele fehlende Werte)")
|
|
doc = body_add_fpar(doc, fpar(ftext(txt, fp_normal)))
|
|
doc = fuege_item_liste_hinzu(doc, e$items)
|
|
}
|
|
doc = body_add_par(doc, "", style = "Normal")
|
|
|
|
fuege_normierte_skala_hinzu = function(doc, sk) {
|
|
e = erg$skalen[[sk]]
|
|
if (!isTRUE(e$auswertbar)) {
|
|
doc = body_add_fpar(doc, fpar(
|
|
ftext(paste0(sk, ": "), fp_label),
|
|
ftext("nicht auswertbar (zu viele fehlende Werte)", fp_normal)
|
|
))
|
|
doc = fuege_item_liste_hinzu(doc, e$items)
|
|
return(doc)
|
|
}
|
|
if (!isTRUE(e$normierbar)) {
|
|
doc = body_add_fpar(doc, fpar(
|
|
ftext(paste0(sk, ": Rohwert ", e$rohwert, " - "), fp_normal),
|
|
ftext(paste0("kein Normwert (", e$norm_grund, ")"), fp_warnung)
|
|
))
|
|
doc = fuege_item_liste_hinzu(doc, e$items)
|
|
return(doc)
|
|
}
|
|
klass_farbe = STAXI2_STUFEN_FARBEN[[as.character(e$klass$stufe)]]
|
|
klass_text_farbe = STAXI2_STUFEN_TEXT_FARBEN[[as.character(e$klass$stufe)]]
|
|
fp_badge = fp_text(color = klass_text_farbe, bold = TRUE, font.size = 10, shading.color = klass_farbe)
|
|
|
|
aussen_txt = if (isTRUE(e$ausserhalb_eichstichprobe)) " (ausserhalb Eichstichprobe, naechstgelegener Wert)" else ""
|
|
doc = body_add_fpar(doc, fpar(
|
|
ftext(paste0(sk, ": Rohwert ", e$rohwert, " T-Wert ", round(e$t_wert),
|
|
" PR ", e$prozentrang, aussen_txt, " "), fp_normal),
|
|
ftext(paste0(" ", e$klass$text, " "), fp_badge)
|
|
))
|
|
|
|
if (!is.null(e$tabelle6) && isTRUE(e$tabelle6$gefunden)) {
|
|
doc = body_add_fpar(doc, fpar(ftext(
|
|
sprintf(" 95%%-Konfidenzintervall: T = %s +/- %s (%.1f - %.1f)",
|
|
round(e$t_wert), round(e$tabelle6$ci95, 1),
|
|
e$t_wert - e$tabelle6$ci95, e$t_wert + e$tabelle6$ci95),
|
|
fp_text(font.size = 10, color = "#555555")
|
|
)))
|
|
} else if (!is.null(e$tabelle6) && isTRUE(e$tabelle6$luecke)) {
|
|
doc = body_add_fpar(doc, fpar(ftext(
|
|
paste0(" Fuer ", sk, ", ", erg$geschlecht_gruppe, ", ",
|
|
STAXI2_ALTERSGRUPPEN_LABEL[[erg$altersgruppe]],
|
|
" liegen keine Werte fuer Standardmessfehler und Konfidenzintervall vor (Luecke im Quellscan des Manuals)."),
|
|
fp_warnung
|
|
)))
|
|
}
|
|
doc = fuege_item_liste_hinzu(doc, e$items)
|
|
doc
|
|
}
|
|
|
|
doc = body_add_fpar(doc, fpar(ftext("Teil 2 - Trait-Aerger (T-Ang)", fp_abschnitt)))
|
|
for (sk in c("T-Ang", "T-Ang/T", "T-Ang/R")) doc = fuege_normierte_skala_hinzu(doc, sk)
|
|
doc = body_add_par(doc, "", style = "Normal")
|
|
|
|
doc = body_add_fpar(doc, fpar(ftext("Teil 3 - Aergerausdruck und -kontrolle", fp_abschnitt)))
|
|
for (sk in c("AX-O", "AX-I", "AC", "AC-O", "AC-I")) doc = fuege_normierte_skala_hinzu(doc, sk)
|
|
doc = body_add_par(doc, "", style = "Normal")
|
|
|
|
doc = body_add_fpar(doc, fpar(ftext(STAXI2_DISCLAIMER, fp_disclaimer)))
|
|
|
|
doc
|
|
}
|
|
|
|
|
|
# Server ####
|
|
|
|
server = function(input, output, session) {
|
|
|
|
observe({
|
|
query = parseQueryString(session$clientData$url_search)
|
|
if (!is.null(query$pseudonym) && nchar(trimws(query$pseudonym)) > 0) {
|
|
updateTextInput(session, "pseudonym", value = trimws(query$pseudonym))
|
|
}
|
|
})
|
|
|
|
observe({
|
|
query = parseQueryString(session$clientData$url_search)
|
|
if (!is.null(query$chiffre) && nchar(trimws(query$chiffre)) > 0) {
|
|
updateTextInput(session, "chiffre", value = toupper(trimws(query$chiffre)))
|
|
}
|
|
})
|
|
|
|
ergebnis_r = eventReactive(input$btn_suchen, {
|
|
|
|
chiffre = toupper(trimws(input$chiffre))
|
|
pseudonym_eingabe = trimws(input$pseudonym)
|
|
|
|
if (nchar(pseudonym_eingabe) == 0 && nchar(chiffre) == 0) {
|
|
return(list(typ = "format_fehler",
|
|
meldung = "Bitte eine Patientenchiffre eingeben."))
|
|
}
|
|
if (!(nchar(pseudonym_eingabe) > 0 || grepl("^[A-Z][0-9]{6}$", chiffre))) {
|
|
return(list(typ = "format_fehler",
|
|
meldung = "Ungueltige Chiffre. Erwartet: ein Grossbuchstabe + 6 Ziffern (z.B. P000123)."))
|
|
}
|
|
|
|
fehlende_skripte = c(
|
|
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) PFAD_DOWNLOAD_SKRIPT,
|
|
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) PFAD_PSEUDONYM_SKRIPT
|
|
)
|
|
if (length(fehlende_skripte) > 0) {
|
|
return(list(typ = "pfad_fehler",
|
|
meldung = paste0("Skript(e) nicht gefunden:\n", paste(fehlende_skripte, collapse = "\n"))))
|
|
}
|
|
|
|
ok_dl = tryCatch({
|
|
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
|
|
list(ok = TRUE)
|
|
}, error = function(e) list(ok = FALSE, msg = e$message))
|
|
if (!ok_dl$ok) {
|
|
return(list(typ = "skript_fehler",
|
|
meldung = paste0("Fehler im Download-Skript: ", ok_dl$msg)))
|
|
}
|
|
|
|
if (!exists("daten_staxi2", envir = .GlobalEnv) ||
|
|
!is.data.frame(get("daten_staxi2", envir = .GlobalEnv))) {
|
|
return(list(typ = "daten_fehler",
|
|
meldung = "Objekt 'daten_staxi2' nach dem Sourcen nicht gefunden oder kein Dataframe."))
|
|
}
|
|
daten_staxi2 = get("daten_staxi2", envir = .GlobalEnv)
|
|
|
|
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 = "db_fehler",
|
|
meldung = paste0("pseudonyme.db nicht gefunden (bis 5 Ebenen oberhalb von ",
|
|
dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE)), " gesucht).")))
|
|
}
|
|
|
|
alter_wd = getwd()
|
|
setwd(db_ordner)
|
|
on.exit(setwd(alter_wd), add = TRUE)
|
|
|
|
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 = "db_fehler",
|
|
meldung = paste0("Fehler im Pseudonym-Skript: ", ok_ps$msg)))
|
|
}
|
|
if (!exists("pseudo", envir = .GlobalEnv) || !is.data.frame(get("pseudo", envir = .GlobalEnv))) {
|
|
return(list(typ = "db_fehler",
|
|
meldung = "Objekt 'pseudo' nach dem Sourcen nicht gefunden oder kein Dataframe."))
|
|
}
|
|
pseudo = get("pseudo", envir = .GlobalEnv)
|
|
|
|
if (nchar(pseudonym_eingabe) > 0) {
|
|
treffer_pw = pseudo[trimws(as.character(pseudo$pseudonym)) == pseudonym_eingabe, , drop = FALSE]
|
|
if (nrow(treffer_pw) > 0) chiffre = toupper(trimws(as.character(treffer_pw$chiffre[1])))
|
|
}
|
|
|
|
treffer_ps = pseudo[toupper(trimws(as.character(pseudo$chiffre))) == chiffre, , drop = FALSE]
|
|
if (nrow(treffer_ps) == 0) {
|
|
meldung = if (nchar(chiffre) == 0) {
|
|
paste0("Pseudonym '", pseudonym_eingabe, "' wurde in der Pseudonym-Datenbank nicht gefunden.")
|
|
} else {
|
|
paste0("Chiffre '", chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden.")
|
|
}
|
|
return(list(typ = "chiffre_nicht_gefunden", meldung = meldung))
|
|
}
|
|
|
|
session_ids = unique(as.character(treffer_ps$pseudonym))
|
|
if (nchar(pseudonym_eingabe) > 0) session_ids = pseudonym_eingabe
|
|
idx_kandidaten = which(as.character(daten_staxi2$session) %in% session_ids)
|
|
if (length(idx_kandidaten) == 0) {
|
|
return(list(typ = "session_nicht_gefunden",
|
|
meldung = paste0("Kein STAXI-2-Datensatz fuer Chiffre '", chiffre, "' gefunden. (",
|
|
length(session_ids), " Pseudonym(e) geprueft)")))
|
|
}
|
|
|
|
mehrfach_warnung = NULL
|
|
if (length(idx_kandidaten) > 1) {
|
|
zeitstempel = suppressWarnings(as.POSIXct(daten_staxi2$created[idx_kandidaten]))
|
|
idx_final = idx_kandidaten[which.max(zeitstempel)]
|
|
mehrfach_warnung = list(n = length(idx_kandidaten))
|
|
} else {
|
|
idx_final = idx_kandidaten[1]
|
|
}
|
|
zeile = daten_staxi2[idx_final, , drop = FALSE]
|
|
|
|
ausfuelldatum = tryCatch(
|
|
format(as.POSIXct(zeile[["created"]][1]), "%d.%m.%Y"),
|
|
error = function(e) "unbekannt"
|
|
)
|
|
|
|
item_extraktion = tryCatch({
|
|
werte_liste = list()
|
|
for (col in alle_s_cols) {
|
|
werte_liste[[col]] = item_wert(daten_staxi2[[col]], labels_teil1)
|
|
}
|
|
for (col in c(alle_t_cols, alle_e_cols)) {
|
|
werte_liste[[col]] = item_wert(daten_staxi2[[col]], labels_teil23)
|
|
}
|
|
list(ok = TRUE, werte_liste = werte_liste)
|
|
}, error = function(e) list(ok = FALSE, msg = e$message))
|
|
|
|
if (!item_extraktion$ok) {
|
|
return(list(typ = "itemfehler",
|
|
meldung = paste0(
|
|
"Fehler bei der Itemkodierung: ", item_extraktion$msg,
|
|
" Die gesamte Auswertung wird abgebrochen, da ein Kodierungsfehler alle Items ",
|
|
"derselben Antwortskala betreffen kann.")))
|
|
}
|
|
werte_liste = item_extraktion$werte_liste
|
|
item_wert_person = function(col) unname(werte_liste[[col]][idx_final])
|
|
|
|
alter_roh = suppressWarnings(as.numeric(trimws(as.character(zeile[["staxi2_alter"]][1]))))
|
|
alter = if (!is.na(alter_roh) && alter_roh > 0) alter_roh else NA_real_
|
|
|
|
geschlecht_text = staxi2_label_text(daten_staxi2[["staxi2_geschlecht"]], zeile[["staxi2_geschlecht"]])
|
|
geschlecht_gruppe = if (!is.na(geschlecht_text) && grepl("weiblich", geschlecht_text, ignore.case = TRUE)) {
|
|
"frauen"
|
|
} else if (!is.na(geschlecht_text) && grepl("nnlich", geschlecht_text, ignore.case = TRUE)) {
|
|
"maenner"
|
|
} else {
|
|
NA_character_
|
|
}
|
|
geschlecht_unbekannt = is.na(geschlecht_gruppe)
|
|
|
|
altersgruppe = altersgruppe_von(alter)
|
|
altersgruppe_zu_jung = !is.na(alter) && alter < 16
|
|
|
|
skalen_ergebnisse = list()
|
|
for (sk in names(STAXI2_SKALEN)) {
|
|
cols = STAXI2_SKALEN[[sk]]
|
|
werte = sapply(cols, item_wert_person)
|
|
sc = staxi2_score_skala(werte)
|
|
bereich = STAXI2_WERTEBEREICH[[sk]]
|
|
unplausibel = isTRUE(sc$auswertbar) && !is.na(sc$rohwert) &&
|
|
(sc$rohwert < bereich[1] || sc$rohwert > bereich[2])
|
|
|
|
items = lapply(seq_along(cols), function(i) {
|
|
col = cols[i]
|
|
list(
|
|
nr = as.integer(sub(".*_(\\d+)$", "\\1", col)),
|
|
text = staxi2_bereinige_text(attr(daten_staxi2[[col]], "label")),
|
|
wert = unname(werte[i]),
|
|
antwort_text = staxi2_bereinige_text(staxi2_label_text(daten_staxi2[[col]], zeile[[col]]))
|
|
)
|
|
})
|
|
# Sortierung nach Rohwert absteigend (hoechste Auspraegung zuerst),
|
|
# fehlende Werte ans Ende, bei Gleichstand nach Itemnummer aufsteigend.
|
|
item_werte = sapply(items, function(x) x$wert)
|
|
item_nrn = sapply(items, function(x) x$nr)
|
|
reihenfolge = order(is.na(item_werte), -ifelse(is.na(item_werte), 0, item_werte), item_nrn)
|
|
items = items[reihenfolge]
|
|
|
|
skalen_ergebnisse[[sk]] = c(sc, list(unplausibel = unplausibel, items = items))
|
|
}
|
|
|
|
for (sk in STAXI2_NORMIERTE_SKALEN) {
|
|
e = skalen_ergebnisse[[sk]]
|
|
if (!isTRUE(e$auswertbar)) {
|
|
e$normierbar = FALSE
|
|
e$norm_grund = "Skala nicht auswertbar (zu viele fehlende Werte)"
|
|
} else if (is.na(altersgruppe) || is.na(geschlecht_gruppe)) {
|
|
e$normierbar = FALSE
|
|
e$norm_grund = if (is.na(altersgruppe)) {
|
|
"Alter nicht auswertbar oder unter 16 Jahren"
|
|
} else {
|
|
"Geschlecht nicht eindeutig zuordenbar"
|
|
}
|
|
} else {
|
|
praefix = STAXI2_SKALA_DATEIPRAEFIX[[sk]]
|
|
tab = staxi2_normtabellen[[praefix]][[altersgruppe]][[geschlecht_gruppe]]
|
|
lk = norm_lookup(tab, e$rohwert)
|
|
e$normierbar = TRUE
|
|
e$t_wert = lk$t_wert
|
|
e$prozentrang = lk$prozentrang
|
|
e$ausserhalb_eichstichprobe = lk$ausserhalb_eichstichprobe
|
|
e$klass = staxi2_klassifiziere(lk$t_wert)
|
|
e$tabelle6 = tabelle6_lookup(staxi2_tabelle6, sk, geschlecht_gruppe, altersgruppe)
|
|
}
|
|
skalen_ergebnisse[[sk]] = e
|
|
}
|
|
|
|
list(
|
|
typ = "ok",
|
|
chiffre = chiffre,
|
|
ausfuelldatum = ausfuelldatum,
|
|
alter = alter,
|
|
geschlecht_gruppe = geschlecht_gruppe,
|
|
geschlecht_unbekannt = geschlecht_unbekannt,
|
|
altersgruppe = altersgruppe,
|
|
altersgruppe_zu_jung = altersgruppe_zu_jung,
|
|
mehrfach_warnung = mehrfach_warnung,
|
|
skalen = skalen_ergebnisse
|
|
)
|
|
})
|
|
|
|
notloesung_sichtbar = reactiveVal(FALSE)
|
|
observeEvent(input$btn_notloesung, {
|
|
notloesung_sichtbar(!notloesung_sichtbar())
|
|
})
|
|
|
|
output$fehler_ui = renderUI({
|
|
req(input$btn_suchen)
|
|
d = ergebnis_r()
|
|
if (!identical(d$typ, "ok")) div(class = "alert-fehler", d$meldung)
|
|
})
|
|
|
|
output$warnung_ui = renderUI({
|
|
req(input$btn_suchen)
|
|
d = ergebnis_r()
|
|
if (!identical(d$typ, "ok")) return(NULL)
|
|
|
|
meldungen = list()
|
|
if (!is.null(d$mehrfach_warnung)) {
|
|
meldungen = c(meldungen, paste0(
|
|
"Mehrere Ausfuellungen gefunden (", d$mehrfach_warnung$n,
|
|
" Eintraege). Angezeigt wird die neueste."))
|
|
}
|
|
if (isTRUE(d$altersgruppe_zu_jung)) {
|
|
meldungen = c(meldungen,
|
|
"Alter unter 16 Jahren: Das Instrument ist ab 16 Jahren normiert, es koennen keine Normwerte berechnet werden.")
|
|
}
|
|
if (isTRUE(d$geschlecht_unbekannt)) {
|
|
meldungen = c(meldungen,
|
|
"Geschlecht nicht eindeutig zuordenbar: Normwerte konnten nicht berechnet werden.")
|
|
}
|
|
unplausibel_skalen = names(Filter(function(x) isTRUE(x$unplausibel), d$skalen))
|
|
if (length(unplausibel_skalen) > 0) {
|
|
meldungen = c(meldungen, paste0(
|
|
"Rohwert ausserhalb des erwarteten Wertebereichs bei: ",
|
|
paste(unplausibel_skalen, collapse = ", "), "."))
|
|
}
|
|
if (length(meldungen) == 0) return(NULL)
|
|
tagList(lapply(meldungen, function(m) div(class = "alert-warnung", m)))
|
|
})
|
|
|
|
# Einzelitems einer Skala, absteigend nach Rohwert sortiert (Aufbereitung
|
|
# bereits im eventReactive erfolgt), mit farbigem Antwortbadge je Item.
|
|
item_liste_div = function(items) {
|
|
if (is.null(items) || length(items) == 0) return(NULL)
|
|
div(class = "item-liste",
|
|
lapply(items, function(it) {
|
|
wert_key = if (is.na(it$wert)) "fehlend" else as.character(it$wert)
|
|
item_text = if (is.na(it$text) || nchar(it$text) == 0) paste0("Item ", it$nr) else it$text
|
|
badge_text = if (is.na(it$wert)) {
|
|
"fehlend"
|
|
} else if (!is.na(it$antwort_text) && nchar(it$antwort_text) > 0) {
|
|
paste0(it$wert, " - ", it$antwort_text)
|
|
} else {
|
|
as.character(it$wert)
|
|
}
|
|
div(class = "item-zeile",
|
|
span(class = "item-nr", it$nr),
|
|
span(class = "item-text", item_text),
|
|
span(class = paste0("antwort-badge antwort-badge-", wert_key), badge_text)
|
|
)
|
|
})
|
|
)
|
|
}
|
|
|
|
skala_block_ui = function(sk, e, geschlecht_gruppe, altersgruppe) {
|
|
if (!isTRUE(e$auswertbar)) {
|
|
return(div(class = "skala-block",
|
|
div(class = "skala-titel", sk),
|
|
div(class = "rohwert-anzeige", "n. a."),
|
|
div(class = "rohwert-hinweis", "nicht auswertbar (zu viele fehlende Werte)"),
|
|
item_liste_div(e$items)
|
|
))
|
|
}
|
|
if (!isTRUE(e$normierbar)) {
|
|
return(div(class = "skala-block",
|
|
div(class = "skala-titel", sk),
|
|
div(class = "rohwert-anzeige", e$rohwert),
|
|
div(class = "rohwert-hinweis", paste0("kein Normwert: ", e$norm_grund)),
|
|
item_liste_div(e$items)
|
|
))
|
|
}
|
|
klass = e$klass
|
|
plot_id = paste0("gauge_", gsub("[^A-Za-z0-9]", "_", sk))
|
|
|
|
ci_block = if (!is.null(e$tabelle6) && isTRUE(e$tabelle6$gefunden)) {
|
|
div(class = "ci-info",
|
|
sprintf("95%%-KI: %.0f +/- %.1f (%.1f - %.1f)",
|
|
round(e$t_wert), e$tabelle6$ci95,
|
|
e$t_wert - e$tabelle6$ci95, e$t_wert + e$tabelle6$ci95)
|
|
)
|
|
} else if (!is.null(e$tabelle6) && isTRUE(e$tabelle6$luecke)) {
|
|
tagList(
|
|
div(class = "alert-warnung",
|
|
paste0("Fuer ", sk, ", ",
|
|
if (identical(geschlecht_gruppe, "frauen")) "Frauen" else "Maenner", ", ",
|
|
STAXI2_ALTERSGRUPPEN_LABEL[[altersgruppe]],
|
|
" liegen keine Werte fuer Standardmessfehler und Konfidenzintervall vor ",
|
|
"(Luecke im Quellscan des Manuals).")
|
|
),
|
|
actionLink("btn_notloesung", "Notloesungs-Vergleichswerte anzeigen/ausblenden"),
|
|
if (isTRUE(notloesung_sichtbar())) {
|
|
tagList(lapply(STAXI2_ACI_NOTLOESUNG, function(nl) {
|
|
div(style = "font-size:0.85em; color:#777; margin-top:4px;",
|
|
paste0(nl$bezeichnung, ": alpha = ", nl$alpha, " S_e = ", nl$se,
|
|
" (Notloesung, nicht die eigentlich fehlende Zelle)")
|
|
)
|
|
}))
|
|
}
|
|
)
|
|
} else NULL
|
|
|
|
div(class = "skala-block",
|
|
div(class = "skala-titel", sk),
|
|
div(class = "rohwert-anzeige", e$rohwert),
|
|
div(class = "rohwert-hinweis",
|
|
paste0("T = ", round(e$t_wert), " PR = ", e$prozentrang,
|
|
if (isTRUE(e$ausserhalb_eichstichprobe)) " (ausserhalb Eichstichprobe, naechstgelegener Wert)" else "")
|
|
),
|
|
span(class = paste0("stufe-badge stufe-badge-", klass$stufe), klass$text),
|
|
ci_block,
|
|
plotOutput(plot_id, height = "70px"),
|
|
item_liste_div(e$items)
|
|
)
|
|
}
|
|
|
|
output$ergebnis_ui = renderUI({
|
|
req(input$btn_suchen)
|
|
d = ergebnis_r()
|
|
if (!identical(d$typ, "ok")) return(NULL)
|
|
|
|
kopfzeile = div(class = "meta-block",
|
|
tags$strong("Chiffre: "), d$chiffre,
|
|
tags$span(" | ", style = "color:#ccc;"),
|
|
tags$strong("Ausfuelldatum: "), d$ausfuelldatum,
|
|
tags$span(" | ", style = "color:#ccc;"),
|
|
tags$strong("Alter: "), if (is.na(d$alter)) "k. A." else d$alter,
|
|
tags$span(" | ", style = "color:#ccc;"),
|
|
tags$strong("Geschlecht: "), if (is.na(d$geschlecht_gruppe)) "nicht zuordenbar" else d$geschlecht_gruppe
|
|
)
|
|
|
|
teil1_karte = div(class = "abschnitt-karte",
|
|
div(class = "abschnitt-titel", "Teil 1 - State-Aerger (S-Ang)"),
|
|
div(class = "hinweis-block",
|
|
"Fuer diese Skala werden laut Testmanual keine Normwerte ausgewiesen (nur Rohwerte, keine T-Werte, keine Klassifikation)."),
|
|
div(class = "state-grid",
|
|
lapply(STAXI2_STATE_SKALEN, function(sk) {
|
|
e = d$skalen[[sk]]
|
|
div(class = "state-block",
|
|
div(class = "state-label", sk),
|
|
div(class = "rohwert-anzeige",
|
|
if (isTRUE(e$auswertbar)) e$rohwert else "n. a."
|
|
)
|
|
)
|
|
})
|
|
),
|
|
div(class = "skalen-grid",
|
|
lapply(STAXI2_STATE_SKALEN, function(sk) {
|
|
e = d$skalen[[sk]]
|
|
div(class = "skala-block",
|
|
div(class = "skala-titel", sk),
|
|
item_liste_div(e$items)
|
|
)
|
|
})
|
|
)
|
|
)
|
|
|
|
profil_karte = div(class = "abschnitt-karte",
|
|
div(class = "abschnitt-titel", "Profil (T-Werte)"),
|
|
plotOutput("profil_plot", height = "220px")
|
|
)
|
|
|
|
teil2_karte = div(class = "abschnitt-karte",
|
|
div(class = "abschnitt-titel", "Teil 2 - Trait-Aerger (T-Ang)"),
|
|
div(class = "skalen-grid",
|
|
lapply(c("T-Ang", "T-Ang/T", "T-Ang/R"), function(sk) {
|
|
skala_block_ui(sk, d$skalen[[sk]], d$geschlecht_gruppe, d$altersgruppe)
|
|
})
|
|
)
|
|
)
|
|
|
|
teil3_karte = div(class = "abschnitt-karte",
|
|
div(class = "abschnitt-titel", "Teil 3 - Aergerausdruck und -kontrolle"),
|
|
div(class = "skalen-grid",
|
|
lapply(c("AX-O", "AX-I", "AC", "AC-O", "AC-I"), function(sk) {
|
|
skala_block_ui(sk, d$skalen[[sk]], d$geschlecht_gruppe, d$altersgruppe)
|
|
})
|
|
)
|
|
)
|
|
|
|
tagList(
|
|
kopfzeile,
|
|
teil1_karte,
|
|
profil_karte,
|
|
teil2_karte,
|
|
teil3_karte,
|
|
uiOutput("vergleich_ui")
|
|
)
|
|
})
|
|
|
|
output$profil_plot = renderPlot({
|
|
d = ergebnis_r()
|
|
req(identical(d$typ, "ok"))
|
|
werte = sapply(STAXI2_HAUPTSKALEN_PROFIL, function(sk) {
|
|
e = d$skalen[[sk]]
|
|
if (isTRUE(e$normierbar)) e$t_wert else NA_real_
|
|
})
|
|
names(werte) = STAXI2_HAUPTSKALEN_PROFIL
|
|
make_profil_plot_staxi2(werte)
|
|
}, bg = "transparent")
|
|
|
|
for (sk in STAXI2_NORMIERTE_SKALEN) {
|
|
local({
|
|
sk_lokal = sk
|
|
plot_id = paste0("gauge_", gsub("[^A-Za-z0-9]", "_", sk_lokal))
|
|
output[[plot_id]] = renderPlot({
|
|
d = ergebnis_r()
|
|
req(identical(d$typ, "ok"))
|
|
e = d$skalen[[sk_lokal]]
|
|
req(isTRUE(e$normierbar))
|
|
make_gauge_staxi2(e$t_wert)
|
|
}, bg = "transparent")
|
|
})
|
|
}
|
|
|
|
output$vergleich_ui = renderUI({
|
|
d = ergebnis_r()
|
|
req(identical(d$typ, "ok"))
|
|
verfuegbar = names(Filter(function(x) isTRUE(x$normierbar) && !is.na(x$t_wert), d$skalen[STAXI2_NORMIERTE_SKALEN]))
|
|
if (length(verfuegbar) < 2) return(NULL)
|
|
|
|
div(class = "abschnitt-karte",
|
|
div(class = "abschnitt-titel", "Vergleich zweier Skalen (optional)"),
|
|
div(class = "hinweis-block",
|
|
"Beide Skalen stammen aus derselben Alters-/Geschlechtsgruppe dieser Person; kritische Differenz auf Basis Tabelle 6, zweiseitig, alpha = .05."),
|
|
fluidRow(
|
|
column(5, selectInput("vergleich_skala1", "Skala 1", choices = verfuegbar, selected = verfuegbar[1])),
|
|
column(5, selectInput("vergleich_skala2", "Skala 2", choices = verfuegbar,
|
|
selected = verfuegbar[min(2, length(verfuegbar))]))
|
|
),
|
|
uiOutput("vergleich_ergebnis_ui")
|
|
)
|
|
})
|
|
|
|
output$vergleich_ergebnis_ui = renderUI({
|
|
d = ergebnis_r()
|
|
req(identical(d$typ, "ok"))
|
|
req(input$vergleich_skala1, input$vergleich_skala2)
|
|
|
|
if (identical(input$vergleich_skala1, input$vergleich_skala2)) {
|
|
return(div(class = "alert-warnung", "Bitte zwei unterschiedliche Skalen waehlen."))
|
|
}
|
|
|
|
e1 = d$skalen[[input$vergleich_skala1]]
|
|
e2 = d$skalen[[input$vergleich_skala2]]
|
|
if (is.null(e1$tabelle6) || is.null(e2$tabelle6) ||
|
|
!isTRUE(e1$tabelle6$gefunden) || !isTRUE(e2$tabelle6$gefunden)) {
|
|
return(div(class = "alert-warnung",
|
|
"Fuer mindestens eine der beiden Skalen liegt keine kritische Differenz vor (siehe Luecken-Hinweis oben)."))
|
|
}
|
|
|
|
kritdiff = e1$tabelle6$kritdiff_zweiseitig_5
|
|
diff = abs(e1$t_wert - e2$t_wert)
|
|
signifikant = !is.na(kritdiff) && diff >= kritdiff
|
|
|
|
div(
|
|
div(paste0("Differenz der T-Werte: ", round(diff, 1))),
|
|
div(paste0("Kritische Differenz (zweiseitig, alpha = .05): ", round(kritdiff, 1))),
|
|
div(style = paste0("font-weight:700; margin-top:6px; color:",
|
|
if (isTRUE(signifikant)) "#B71C1C" else "#2E7D32", ";"),
|
|
if (isTRUE(signifikant)) "Unterschied statistisch bedeutsam" else "Unterschied nicht statistisch bedeutsam")
|
|
)
|
|
})
|
|
|
|
output$download_word = downloadHandler(
|
|
filename = function() {
|
|
d = tryCatch(ergebnis_r(), error = function(e) NULL)
|
|
chiffre_esc = if (is.list(d) && identical(d$typ, "ok") && nchar(d$chiffre) > 0) {
|
|
gsub("[^A-Za-z0-9_-]", "_", d$chiffre)
|
|
} else {
|
|
"export"
|
|
}
|
|
ausfuelldatum_fn = tryCatch(
|
|
format(as.Date(d$ausfuelldatum, "%d.%m.%Y"), "%Y%m%d"),
|
|
error = function(e) format(Sys.Date(), "%Y%m%d")
|
|
)
|
|
if (is.na(ausfuelldatum_fn) || length(ausfuelldatum_fn) == 0) {
|
|
ausfuelldatum_fn = format(Sys.Date(), "%Y%m%d")
|
|
}
|
|
paste0("STAXI2_", 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 eingeben und 'Auswerten' klicken.",
|
|
style = "Normal")
|
|
print(doc, target = file)
|
|
return()
|
|
}
|
|
|
|
doc = tryCatch(
|
|
erstelle_staxi2_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)
|