1139 lines
47 KiB
R
1139 lines
47 KiB
R
# Präambel ####
|
||
|
||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_vds32.R" # liefert: daten_vds32
|
||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo
|
||
AKZENT_FARBE = "#8B2635"
|
||
|
||
VDS32_DISCLAIMER = paste0(
|
||
"Diese Auswertung ist ein Hilfsmittel für klinisches Fachpersonal und ersetzt ",
|
||
"keine klinische Diagnose. Alle Kennzahlen sind ipsativ zu interpretieren (Vergleich ",
|
||
"der Person mit sich selbst), es existieren keine Normwerte oder klinischen Cutoffs ",
|
||
"für dieses Instrument. Die Interpretation obliegt der behandelnden Person."
|
||
)
|
||
|
||
VDS32_IPSATIV_HINWEIS = paste0(
|
||
"Der VDS32 hat keine Normwerte, keine Cutoffs und keine diagnostische Klassifikation. ",
|
||
"Alle Kennzahlen sind rein ipsativ zu interpretieren (Selbstvergleich der Person), ",
|
||
"nicht gegen eine externe Referenzgruppe."
|
||
)
|
||
|
||
library(shiny)
|
||
library(dplyr)
|
||
library(ggplot2)
|
||
library(haven)
|
||
library(officer)
|
||
|
||
|
||
# Infrastruktur ####
|
||
|
||
APP_VERZEICHNIS = normalizePath(getwd())
|
||
|
||
absPath = function(pfad) {
|
||
if (grepl("^([A-Za-z]:[/\\\\]|/)", pfad)) return(pfad)
|
||
file.path(APP_VERZEICHNIS, pfad)
|
||
}
|
||
|
||
PFAD_DOWNLOAD_SKRIPT = normalizePath(absPath(PFAD_DOWNLOAD_SKRIPT), mustWork = FALSE)
|
||
PFAD_PSEUDONYM_SKRIPT = normalizePath(absPath(PFAD_PSEUDONYM_SKRIPT), mustWork = FALSE)
|
||
|
||
|
||
# Helper ####
|
||
|
||
# Sucht den Rohwert sowohl auf der Werte- als auch auf der Namen-Seite des
|
||
# labels-Attributs (formr exportiert je nach Feldtyp mal die uebliche Richtung
|
||
# NAME = Klartext / WERT = Code, mal vertauscht) und liefert den jeweils
|
||
# GEGENUEBERLIEGENDEN Text zurueck - Ansatz uebernommen aus vds29/app.R
|
||
# (match_in_labels), dort an dieser formr-Instanz bereits verifiziert.
|
||
vds32_match_in_labels = function(labs, roh) {
|
||
roh_chr = as.character(roh)
|
||
idx = which(as.character(unclass(labs)) == roh_chr)
|
||
if (length(idx) > 0) return(list(text = names(labs)[idx[1]]))
|
||
idx = which(names(labs) == roh_chr)
|
||
if (length(idx) > 0) return(list(text = as.character(unclass(labs))[idx[1]]))
|
||
NULL
|
||
}
|
||
|
||
# Klartext eines 'mc'-Werts ueber das labels-Attribut der ORIGINAL-Spalte,
|
||
# mit Rohtext-Fallback falls kein Attribut vorliegt (Abschnitt 4.6 der
|
||
# Spezifikation: nie hartkodierte Zahlenwerte annehmen).
|
||
vds32_resolve_label = function(original_spalte, wert) {
|
||
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_character_)
|
||
roh = unclass(wert)[1]
|
||
labs = attr(original_spalte, "labels")
|
||
if (!is.null(labs) && length(labs) > 0) {
|
||
treffer = vds32_match_in_labels(labs, roh)
|
||
if (!is.null(treffer)) return(trimws(as.character(treffer$text)))
|
||
}
|
||
roh_chr = trimws(as.character(roh))
|
||
if (nchar(roh_chr) > 0) return(roh_chr)
|
||
NA_character_
|
||
}
|
||
|
||
# Recodierung "habe ich"-Haeufigkeit (Abschnitt 5.1): Choice-Label "0/1/2 = ..."
|
||
# per Regex auf die fuehrende Ziffer, dann +1 (Scoring-Werte 1-3). Numerischer
|
||
# Fallback nur falls kein Label-Text auflösbar ist.
|
||
vds32_haeufigkeit_scoring = function(original_spalte, wert, feldname) {
|
||
text = vds32_resolve_label(original_spalte, wert)
|
||
if (is.na(text)) stop("Feld '", feldname, "': kein Wert vorhanden.")
|
||
if (grepl("^\\s*[0-2]\\s*=", text)) {
|
||
stufe = as.integer(sub("^\\s*([0-2])\\s*=.*$", "\\1", text))
|
||
return(stufe + 1L)
|
||
}
|
||
stufe_num = suppressWarnings(as.integer(text))
|
||
if (!is.na(stufe_num) && stufe_num >= 0 && stufe_num <= 2) return(stufe_num + 1L)
|
||
stop("Feld '", feldname, "': Wert '", text,
|
||
"' konnte nicht als 0/1/2-Haeufigkeitsstufe erkannt werden.")
|
||
}
|
||
|
||
# Akzeptanz-Item (Abschnitt 5.2): 2-Choice-Feld ohne Zahlenpraefix, daher ueber
|
||
# den Wortlaut ("akzeptiere ich" vs. "lehne ich ab") entschieden.
|
||
vds32_akzeptanz_ist_akzeptiert = function(original_spalte, wert, feldname) {
|
||
text = tolower(vds32_resolve_label(original_spalte, wert))
|
||
if (is.na(text)) stop("Feld '", feldname, "': kein Wert vorhanden.")
|
||
if (grepl("akzeptiere", text)) return(TRUE)
|
||
if (grepl("lehne", text) && grepl("ab", text)) return(FALSE)
|
||
stop("Feld '", feldname, "': Wert '", text,
|
||
"' konnte weder 'akzeptiere ich' noch 'lehne ich ab' zugeordnet werden.")
|
||
}
|
||
|
||
# GUG-Item (Abschnitt 5.5): Choice-Label "0/1/2/3 = ...", Rohwert 0-3 OHNE
|
||
# Recodierung (anders als 5.1 - siehe Spezifikation).
|
||
vds32_umgang_stufe = function(original_spalte, wert, feldname) {
|
||
text = vds32_resolve_label(original_spalte, wert)
|
||
if (is.na(text)) stop("Feld '", feldname, "': kein Wert vorhanden.")
|
||
if (grepl("^\\s*[0-3]\\s*=", text)) {
|
||
return(as.integer(sub("^\\s*([0-3])\\s*=.*$", "\\1", text)))
|
||
}
|
||
stufe_num = suppressWarnings(as.integer(text))
|
||
if (!is.na(stufe_num) && stufe_num >= 0 && stufe_num <= 3) return(stufe_num)
|
||
stop("Feld '", feldname, "': Wert '", text, "' konnte nicht als 0-3-Stufe erkannt werden.")
|
||
}
|
||
|
||
# check-Feld (Abschnitt 4.6): Exportformat nicht verifiziert, daher defensiv
|
||
# logical/character/numeric abgedeckt. NA bzw. fehlendes Feld = nicht
|
||
# angekreuzt (die beiden check-Felder sind optionale formr-Felder).
|
||
vds32_ist_angekreuzt = function(wert) {
|
||
if (is.null(wert) || length(wert) == 0) return(FALSE)
|
||
w = wert[1]
|
||
if (is.na(w)) return(FALSE)
|
||
if (is.logical(w)) return(isTRUE(w))
|
||
w_chr = trimws(tolower(as.character(unclass(w))))
|
||
w_chr %in% c("true", "1", "ja", "wahr", "checked")
|
||
}
|
||
|
||
# Freitextfeld lesen, leere/NA-Werte einheitlich als NA_character_. Feldname
|
||
# darf fehlen (z.B. abweichender Spaltenname) - dann NA statt Fehler.
|
||
vds32_text_feld = function(zeile, feldname) {
|
||
if (!(feldname %in% names(zeile))) return(NA_character_)
|
||
roh = zeile[[feldname]][1]
|
||
if (is.null(roh) || is.na(roh)) return(NA_character_)
|
||
txt = trimws(as.character(roh))
|
||
if (nchar(txt) == 0) NA_character_ else txt
|
||
}
|
||
|
||
# Aufloesung eines select_one-Wahlfelds mit externer Choice-Liste (wichtigstes
|
||
# Gefuehl, Rangfolge, Reaktionsauswahl): formr exportiert solche Felder in
|
||
# dieser Instanz haeufig als internen Choice-NAMEN (z.B. "f03"), nicht als
|
||
# Klartext (verifiziertes Verhalten, siehe vds24/app.R). Deshalb zuerst
|
||
# direkter Code-Abgleich, danach labels-Attribut in beide Richtungen, danach
|
||
# Text-Abgleich. Nicht aufloesbare Werte werden transparent zurückgegeben
|
||
# statt verworfen.
|
||
vds32_code_text = function(original_spalte, wert, code_tabelle) {
|
||
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_character_)
|
||
roh = trimws(as.character(unclass(wert)[1]))
|
||
if (nchar(roh) == 0) return(NA_character_)
|
||
|
||
if (tolower(roh) %in% names(code_tabelle)) return(unname(code_tabelle[tolower(roh)]))
|
||
|
||
labs = attr(original_spalte, "labels")
|
||
if (!is.null(labs) && length(labs) > 0) {
|
||
treffer = vds32_match_in_labels(labs, roh)
|
||
if (!is.null(treffer)) {
|
||
kandidat = trimws(as.character(treffer$text))
|
||
if (tolower(kandidat) %in% names(code_tabelle)) return(unname(code_tabelle[tolower(kandidat)]))
|
||
m = which(tolower(code_tabelle) == tolower(kandidat))
|
||
if (length(m) == 1) return(unname(code_tabelle[m]))
|
||
if (nchar(kandidat) > 0) return(kandidat)
|
||
}
|
||
}
|
||
|
||
m = which(tolower(code_tabelle) == tolower(roh))
|
||
if (length(m) == 1) return(unname(code_tabelle[m]))
|
||
|
||
roh
|
||
}
|
||
|
||
# vds32_reaktion_auswahl (Abschnitt 4.3): Exportformat nicht verifiziert.
|
||
# Deckt defensiv zwei plausible Formate ab: mehrere Dummy-Spalten je Choice
|
||
# (vds32_reaktion_auswahl_r01, ...) oder eine Einzelspalte mit komma-/
|
||
# semikolongetrennter Codeliste. Trifft keines zu: klarer Fehler statt
|
||
# Rateannahme (Abschnitt 4.3/7 der Spezifikation).
|
||
vds32_extrahiere_reaktionen = function(daten, zeile) {
|
||
feld = "vds32_reaktion_auswahl"
|
||
dummy_namen = grep(paste0("^", feld, "_(r[0-9]{2})$"), names(daten), value = TRUE)
|
||
|
||
if (length(dummy_namen) > 0) {
|
||
codes = character(0)
|
||
for (spalte in dummy_namen) {
|
||
code = sub(paste0("^", feld, "_"), "", spalte)
|
||
if (vds32_ist_angekreuzt(zeile[[spalte]])) codes = c(codes, code)
|
||
}
|
||
return(list(ok = TRUE, codes = codes))
|
||
}
|
||
|
||
if (!(feld %in% names(daten))) {
|
||
return(list(ok = FALSE, meldung = paste0(
|
||
"Feld '", feld, "' (bzw. zugehörige Dummy-Spalten je Choice) nicht in ",
|
||
"'daten_vds32' gefunden.")))
|
||
}
|
||
|
||
roh = zeile[[feld]][1]
|
||
if (is.null(roh) || (length(roh) == 1 && is.na(roh))) return(list(ok = TRUE, codes = character(0)))
|
||
|
||
roh_chr = trimws(as.character(unclass(roh)))
|
||
if (nchar(roh_chr) == 0) return(list(ok = TRUE, codes = character(0)))
|
||
|
||
teile = trimws(strsplit(roh_chr, "[,;]")[[1]])
|
||
teile = teile[nchar(teile) > 0]
|
||
|
||
if (all(grepl("^[Rr][0-9]{1,2}$", teile))) {
|
||
codes = sprintf("r%02d", as.integer(sub("^[Rr]", "", teile)))
|
||
return(list(ok = TRUE, codes = codes))
|
||
}
|
||
|
||
aufgeloest = vapply(teile, function(t) {
|
||
treffer = which(tolower(VDS32_REAKTIONEN_TEXTE) == tolower(t))
|
||
if (length(treffer) == 1) names(VDS32_REAKTIONEN_TEXTE)[treffer] else NA_character_
|
||
}, character(1))
|
||
if (length(aufgeloest) > 0 && !any(is.na(aufgeloest))) return(list(ok = TRUE, codes = unname(aufgeloest)))
|
||
|
||
list(ok = FALSE, meldung = paste0(
|
||
"Format von '", feld, "' konnte nicht automatisch erkannt werden (weder ",
|
||
"Dummy-Spalten je Choice noch eine erkennbare Code-/Klartextliste in der ",
|
||
"Einzelspalte: '", roh_chr, "')."))
|
||
}
|
||
|
||
# vds32_therapieziele (Abschnitt 4.4): rein deskriptiv, daher best-effort statt
|
||
# hartem Fehler - nicht aufloesbare Rohwerte werden trotzdem angezeigt.
|
||
vds32_extrahiere_therapieziele = function(daten, zeile) {
|
||
feld = "vds32_therapieziele"
|
||
dummy_namen = grep(paste0("^", feld, "_[0-9]+$"), names(daten), value = TRUE)
|
||
|
||
if (length(dummy_namen) > 0) {
|
||
ausgewaehlt = rep(FALSE, length(VDS32_THERAPIEZIELE_TEXTE))
|
||
for (spalte in dummy_namen) {
|
||
idx = suppressWarnings(as.integer(sub(paste0("^", feld, "_"), "", spalte)))
|
||
if (!is.na(idx) && idx >= 1 && idx <= length(ausgewaehlt) && vds32_ist_angekreuzt(zeile[[spalte]])) {
|
||
ausgewaehlt[idx] = TRUE
|
||
}
|
||
}
|
||
return(VDS32_THERAPIEZIELE_TEXTE[ausgewaehlt])
|
||
}
|
||
|
||
if (!(feld %in% names(daten))) return(character(0))
|
||
original_spalte = daten[[feld]]
|
||
roh = zeile[[feld]][1]
|
||
if (is.null(roh) || (length(roh) == 1 && is.na(roh))) return(character(0))
|
||
roh_chr = trimws(as.character(unclass(roh)))
|
||
if (nchar(roh_chr) == 0) return(character(0))
|
||
|
||
teile = trimws(strsplit(roh_chr, "[,;]")[[1]])
|
||
teile = teile[nchar(teile) > 0]
|
||
|
||
vapply(teile, function(t) {
|
||
idx = suppressWarnings(as.integer(t))
|
||
if (!is.na(idx) && idx >= 1 && idx <= length(VDS32_THERAPIEZIELE_TEXTE)) {
|
||
return(VDS32_THERAPIEZIELE_TEXTE[idx])
|
||
}
|
||
labs = attr(original_spalte, "labels")
|
||
if (!is.null(labs) && length(labs) > 0) {
|
||
treffer = vds32_match_in_labels(labs, t)
|
||
if (!is.null(treffer)) {
|
||
kandidat = trimws(as.character(treffer$text))
|
||
m = which(tolower(VDS32_THERAPIEZIELE_TEXTE) == tolower(kandidat))
|
||
if (length(m) == 1) return(VDS32_THERAPIEZIELE_TEXTE[m])
|
||
}
|
||
}
|
||
m = which(tolower(VDS32_THERAPIEZIELE_TEXTE) == tolower(t))
|
||
if (length(m) == 1) return(VDS32_THERAPIEZIELE_TEXTE[m])
|
||
t
|
||
}, character(1), USE.NAMES = FALSE)
|
||
}
|
||
|
||
make_vds32_profil_plot = function(gruppen_ergebnisse) {
|
||
df = data.frame(
|
||
gruppe = sapply(gruppen_ergebnisse, function(g) g$name),
|
||
wert = sapply(gruppen_ergebnisse, function(g) g$habeich_mw),
|
||
stringsAsFactors = FALSE
|
||
)
|
||
df$gruppe = factor(df$gruppe, levels = df$gruppe)
|
||
|
||
ggplot(df, aes(x = gruppe, y = wert)) +
|
||
geom_col(fill = AKZENT_FARBE, width = 0.55) +
|
||
geom_text(aes(label = sprintf("%.2f", wert)), vjust = -0.6, size = 3.6, color = "#333333") +
|
||
scale_y_continuous(limits = c(0, 3.4), breaks = 1:3) +
|
||
theme_minimal(base_size = 12) +
|
||
theme(
|
||
axis.title = element_blank(),
|
||
panel.grid.minor = element_blank(),
|
||
panel.grid.major.x = element_blank(),
|
||
plot.margin = margin(t = 10, r = 15, b = 5, l = 5)
|
||
) +
|
||
labs(y = "\"Habe ich\"-Mittelwert (1-3)")
|
||
}
|
||
|
||
|
||
# Datenaufbereitung ####
|
||
|
||
VDS32_GRUPPEN = list(
|
||
list(code = "f", feldname = "freude", name = "Freude", n = 15),
|
||
list(code = "t", feldname = "trauer", name = "Trauer", n = 8),
|
||
list(code = "a", feldname = "angst", name = "Angst", n = 11),
|
||
list(code = "w", feldname = "wut", name = "Wut", n = 9)
|
||
)
|
||
|
||
VDS32_GEFUEHL_NAMEN = c(
|
||
f01 = "Freude", f02 = "Begeisterung", f03 = "Glück", f04 = "Übermut",
|
||
f05 = "Leidenschaft", f06 = "Lust", f07 = "Zufriedenheit", f08 = "Stolz",
|
||
f09 = "Selbstvertrauen", f10 = "Gelassenheit", f11 = "Überlegenheit",
|
||
f12 = "Dankbarkeit", f13 = "Vertrauen", f14 = "Zuneigung, Liebe", f15 = "Rührung",
|
||
t01 = "Traurigkeit", t02 = "Verzweiflung", t03 = "Sehnsucht", t04 = "Einsamkeit",
|
||
t05 = "Leere, Langeweile", t06 = "Enttäuschung", t07 = "Beleidigtsein", t08 = "Mitgefühl",
|
||
a01 = "Angst, Furcht", a02 = "Anspannung und Nervosität", a03 = "Verlegenheit",
|
||
a04 = "Selbstunsicherheit", a05 = "Unterlegenheit", a06 = "Scham", a07 = "Schuldgefühl",
|
||
a08 = "Reue", a09 = "Sorge", a10 = "Ekel", a11 = "Schreck",
|
||
w01 = "Ärger, Wut, Zorn", w02 = "Missmut", w03 = "Ungeduld", w04 = "Widerwille, Trotz",
|
||
w05 = "Abneigung, Hass", w06 = "Verachtung", w07 = "Misstrauen", w08 = "Neid", w09 = "Eifersucht"
|
||
)
|
||
|
||
VDS32_ITEM_TABELLE = do.call(rbind, lapply(VDS32_GRUPPEN, function(g) {
|
||
nummern = seq_len(g$n)
|
||
data.frame(
|
||
code = paste0(g$code, sprintf("%02d", nummern)),
|
||
gruppe = g$code,
|
||
gruppe_name = g$name,
|
||
stringsAsFactors = FALSE
|
||
)
|
||
}))
|
||
|
||
# Kontrollsumme: 15+8+11+9 = 43 Gefühle (Abschnitt 4.1).
|
||
if (nrow(VDS32_ITEM_TABELLE) != 43) {
|
||
stop("VDS32: Item-Kontrollsumme stimmt nicht (", nrow(VDS32_ITEM_TABELLE), " statt 43).")
|
||
}
|
||
if (!setequal(VDS32_ITEM_TABELLE$code, names(VDS32_GEFUEHL_NAMEN))) {
|
||
stop("VDS32: 'VDS32_GEFUEHL_NAMEN' stimmt nicht mit 'VDS32_ITEM_TABELLE' überein.")
|
||
}
|
||
|
||
VDS32_UMGANG_TEXTE = c(
|
||
u01 = "Ich kann nichts gegen mein Gefühl tun, es ist so intensiv und beherrscht mich",
|
||
u02 = "Ich nehme einfach kein Gefühl wahr, obwohl ich weiß, dass ich Grund zu diesem Gefühl habe",
|
||
u03 = "Ich habe das Gefühl nur ganz schwach",
|
||
u04 = "Vorsorglich passe ich gut auf, dass keine Situation kommt, in der ich dieses Gefühl habe",
|
||
u05 = "Ich nehme ein ganz anderes Gefühl wahr als das zur Situation eigentlich passende",
|
||
u06 = "Ich reagiere eher körperlich als mit den Gefühlen",
|
||
u07 = "Ich lenke mich ab, sage mir, dass es keinen Grund für dieses Gefühl gibt",
|
||
u08 = "Ich lasse mir nichts anmerken, reagiere eher sachlich oder zurückhaltend",
|
||
u09 = "Mein Gefühl geht in eine Stimmung oder Verstimmung über, die einige Zeit anhält",
|
||
u10 = "Ich bleibe sehr lange in einem starken Gefühl hängen und komme nicht mehr daraus heraus",
|
||
u11 = "Ich empfinde mich selbst fremd oder unwirklich",
|
||
u12 = "Ich verstumme völlig. Man merkt mir nicht an, dass ich alle Ereignisse trotzdem sehr wach wahrnehme",
|
||
u13 = "Ich werde völlig bewegungslos, als ob ich erstarrt wäre"
|
||
)
|
||
|
||
VDS32_REAKTIONEN_TEXTE = c(
|
||
r01 = "Er/sie merkt gar nicht, dass ich dieses Gefühl habe",
|
||
r02 = "Er/sie sagt, es gäbe doch keinen Grund für dieses Gefühl",
|
||
r03 = "Er/sie sagt, ich solle mich doch zusammenreißen",
|
||
r04 = "Er/sie versteht nicht, was ich brauche",
|
||
r05 = "Er/sie sagt Dinge, die das Gefühl noch stärker machen",
|
||
r06 = "Er/sie zeigt keinerlei Gefühle, bleibt kalt",
|
||
r07 = "Er/sie wird ärgerlich, wütend",
|
||
r08 = "Er/sie lehnt mich ab, weist mich ab",
|
||
r09 = "Er/sie bestraft mich mit Liebesentzug",
|
||
r10 = "Er/sie rechtfertigt sich",
|
||
r11 = "Er/sie versucht, sich mit Ausreden rauszureden",
|
||
r12 = "Er/sie sagt nichts mehr, verstummt",
|
||
r13 = "Er/sie rennt einfach weg, raus",
|
||
r14 = "Er/sie ist sehr betroffen",
|
||
r15 = "Er/sie bekommt das gleiche Gefühl wie ich",
|
||
r16 = "Er/sie zeigt Verständnis für mich und mein Gefühl",
|
||
r17 = "Er/sie tut/sagt das, was ich in diesem Moment brauche/will"
|
||
)
|
||
|
||
VDS32_THERAPIEZIELE_TEXTE = c(
|
||
"Wieder Zugang zu einzelnen bislang unterdrückten Gefühlen zu gewinnen",
|
||
"Überbordende Gefühle herunterregulieren zu lernen",
|
||
"Die dysfunktionalen Bewältigungsmechanismen zu reduzieren",
|
||
"Gefühle zu zeigen und auszudrücken",
|
||
"Gefühle anderer Menschen zu erkennen und sich darauf zu beziehen"
|
||
)
|
||
|
||
|
||
# UI ####
|
||
|
||
app_css = "
|
||
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; }
|
||
.app-header {
|
||
background: #8B2635; color: white; padding: 18px 24px 14px;
|
||
margin-bottom: 20px; border-radius: 0 0 6px 6px;
|
||
}
|
||
.app-header h2 { margin: 0; font-size: 1.5rem; font-weight: 600; }
|
||
.app-header p { margin: 4px 0 0; opacity: 0.85; font-size: 0.9rem; }
|
||
.input-panel {
|
||
background: white; border-radius: 6px; padding: 16px 20px;
|
||
margin-bottom: 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
|
||
display: flex; align-items: flex-end; gap: 12px; flex-wrap: wrap;
|
||
}
|
||
.input-panel .form-group { margin-bottom: 0; }
|
||
.input-panel label { font-weight: 600; color: #333; }
|
||
.btn-laden {
|
||
background: #8B2635 !important; color: white !important;
|
||
border: none !important; border-radius: 4px !important;
|
||
padding: 8px 20px !important; font-weight: 600 !important; cursor: pointer;
|
||
}
|
||
.btn-laden:hover { background: #6d1e29 !important; }
|
||
.alert-fehler {
|
||
background: #FFEBEE; border-left: 5px solid #C62828;
|
||
padding: 12px 16px; border-radius: 4px; color: #B71C1C;
|
||
margin-bottom: 12px; font-weight: 500;
|
||
}
|
||
.alert-warnung {
|
||
background: #FFF3E0; border-left: 5px solid #E65100;
|
||
padding: 10px 16px; border-radius: 4px; color: #BF360C;
|
||
margin-bottom: 12px; font-size: 0.93em; font-weight: 500;
|
||
}
|
||
.abschnitt-karte {
|
||
background: white; border-radius: 6px; padding: 20px 24px;
|
||
margin-bottom: 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
|
||
}
|
||
.abschnitt-titel {
|
||
color: #8B2635; font-size: 1.15rem; font-weight: 700;
|
||
border-bottom: 2px solid #8B2635; padding-bottom: 8px; margin-bottom: 14px;
|
||
}
|
||
.abschnitt-untertitel {
|
||
color: #8B2635; font-size: 1.0rem; font-weight: 700; margin: 18px 0 10px;
|
||
}
|
||
.meta-block { margin-bottom: 10px; color: #555; font-size: 0.95em; }
|
||
.meta-block strong { color: #222; }
|
||
.ipsativ-hinweis {
|
||
background: #F5F5F5; border-left: 5px solid #9E9E9E;
|
||
padding: 10px 16px; border-radius: 4px; color: #555555;
|
||
margin-bottom: 16px; font-size: 0.88em; font-style: italic;
|
||
}
|
||
.tabelle-standard { width: 100%; border-collapse: collapse; font-size: 0.92em; }
|
||
.tabelle-standard th, .tabelle-standard td {
|
||
text-align: left; padding: 6px 10px; border-bottom: 1px solid #F0F0F0;
|
||
}
|
||
.tabelle-standard th {
|
||
color: #777; font-size: 0.8em; text-transform: uppercase;
|
||
letter-spacing: 0.03em; font-weight: 700;
|
||
}
|
||
.tabelle-standard tr.gesamt-zeile { font-weight: 700; border-top: 2px solid #8B2635; }
|
||
.kontext-zeile {
|
||
display: flex; gap: 8px; align-items: baseline;
|
||
padding: 4px 0; color: #444; font-size: 0.93em;
|
||
}
|
||
.kontext-label { font-weight: 600; color: #333; min-width: 220px; }
|
||
.item-zeile {
|
||
display: flex; align-items: flex-start; gap: 10px;
|
||
padding: 7px 0; border-bottom: 1px solid #F0F0F0;
|
||
}
|
||
.item-zeile:last-child { border-bottom: none; }
|
||
.item-nr { font-weight: 600; color: #8B2635; min-width: 30px; flex-shrink: 0; }
|
||
.item-text { flex: 1; color: #333; font-size: 0.92em; }
|
||
.stufe-badge {
|
||
border-radius: 4px; padding: 2px 9px; font-weight: 700;
|
||
font-size: 0.82em; white-space: nowrap; display: inline-block; flex-shrink: 0;
|
||
}
|
||
.freitext-zitat {
|
||
background: #FAFAFA; border-left: 3px solid #ccc; padding: 6px 12px;
|
||
margin: 4px 0 4px 30px; font-style: italic; color: #555; font-size: 0.88em;
|
||
}
|
||
.details-block { margin: 10px 0; }
|
||
.details-block summary {
|
||
cursor: pointer; font-weight: 600; color: #8B2635; padding: 6px 0; outline: none;
|
||
}
|
||
.hinweis-klein { font-size: 0.85em; color: #777; font-style: italic; margin: 6px 0 12px; }
|
||
.disclaimer-zeile {
|
||
font-size: 0.82em; color: #777; font-style: italic;
|
||
margin-top: 10px; border-top: 1px solid rgba(0,0,0,.1); padding-top: 8px;
|
||
}
|
||
"
|
||
|
||
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("VDS32 – Emotionsanalyse"),
|
||
tags$p("Verhaltensdiagnostiksystem – Analyse von Freude, Trauer, Angst und Wut, dysfunktionaler Umgang und Reaktion Anderer")
|
||
),
|
||
|
||
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_vds32_docx = function(erg) {
|
||
doc = read_docx()
|
||
|
||
fp_titel = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18)
|
||
fp_abschnitt = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 13)
|
||
fp_label = fp_text(bold = TRUE, font.size = 11)
|
||
fp_normal = fp_text(font.size = 11)
|
||
fp_klein = fp_text(font.size = 9.5, italic = TRUE, color = "#666666")
|
||
fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("VDS32 – Emotionsanalyse", fp_titel)))
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext("Chiffre: ", fp_label),
|
||
ftext(erg$chiffre, fp_normal),
|
||
ftext(" Ausfülldatum: ", fp_label),
|
||
ftext(format(erg$ausfuelldatum, "%d.%m.%Y"), fp_normal)
|
||
))
|
||
if (!is.null(erg$mehrfach_warnung)) {
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext(erg$mehrfach_warnung, fp_text(font.size = 10, italic = TRUE, color = "#555555"))
|
||
))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
doc = body_add_fpar(doc, fpar(ftext(VDS32_IPSATIV_HINWEIS, fp_klein)))
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Emotionsanalyse I – Profil", fp_abschnitt)))
|
||
|
||
profil_df = data.frame(
|
||
"Gruppe" = c(sapply(erg$gruppen_ergebnisse, function(g) g$name), "Gesamt"),
|
||
"Habe ich (MW)" = c(sapply(erg$gruppen_ergebnisse, function(g) sprintf("%.2f", g$habeich_mw)),
|
||
sprintf("%.2f", erg$gesamt$habeich_mw)),
|
||
"Akzeptanz (MW)" = c(sapply(erg$gruppen_ergebnisse, function(g) sprintf("%.2f", g$akzeptanz_mw)),
|
||
sprintf("%.2f", erg$gesamt$akzeptanz_mw)),
|
||
"Ablehnung (MW)" = c(sapply(erg$gruppen_ergebnisse, function(g) sprintf("%.2f", g$ablehnung_mw)),
|
||
sprintf("%.2f", erg$gesamt$ablehnung_mw)),
|
||
"Hält kaum aus (MW)" = c(sapply(erg$gruppen_ergebnisse, function(g) sprintf("%.2f", g$haelt_kaum_aus_mw)),
|
||
sprintf("%.2f", erg$gesamt$haelt_kaum_aus_mw)),
|
||
"Traut sich kaum (MW)" = c(sapply(erg$gruppen_ergebnisse, function(g) sprintf("%.2f", g$traut_sich_kaum_mw)),
|
||
sprintf("%.2f", erg$gesamt$traut_sich_kaum_mw)),
|
||
check.names = FALSE, stringsAsFactors = FALSE
|
||
)
|
||
doc = body_add_table(doc, profil_df)
|
||
doc = body_add_fpar(doc, fpar(ftext(paste0(
|
||
"Hinweis: 'Habe ich (MW)' ist bei den Gruppenzeilen auf die 1-3-Skala bezogen (Divisor = Itemanzahl ",
|
||
"der Gruppe), bei der Gesamtzeile dagegen auf den Wertebereich 0,33-1,0 normiert (Divisor 129 = 43 ",
|
||
"Items × 3, so in der Auswertungsquelle vorgegeben) - beide Zahlen stehen bewusst in derselben ",
|
||
"Spalte, sind aber nicht direkt vergleichbar."), fp_klein)))
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
for (g in erg$gruppen_ergebnisse) {
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext(paste0(g$name, " – wichtigstes Gefühl: "), fp_label),
|
||
ftext(if (is.na(g$wichtigstes)) "k. A." else g$wichtigstes, fp_normal),
|
||
ftext(" zweitwichtigstes: ", fp_label),
|
||
ftext(if (is.na(g$zweitwichtigstes)) "k. A." else g$zweitwichtigstes, fp_normal)
|
||
))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Emotionsanalyse II – Dysfunktionaler Umgang (GUG)", fp_abschnitt)))
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext("GUG-Summe: ", fp_label), ftext(paste0(erg$gug_summe, " / 39"), fp_normal),
|
||
ftext(" GUG-Mittelwert: ", fp_label), ftext(sprintf("%.2f / 3", erg$gug_mw), fp_normal)
|
||
))
|
||
for (r in erg$rang_umgang) {
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext(paste0(r$rang, ". häufigster Umgang: "), fp_label),
|
||
ftext(if (is.na(r$text_gewaehlt)) "k. A." else r$text_gewaehlt, fp_normal)
|
||
))
|
||
if (!is.na(r$freitext)) {
|
||
doc = body_add_fpar(doc, fpar(ftext(paste0(" Beschreibung: ", r$freitext), fp_klein)))
|
||
}
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Emotionsanalyse III – Reaktion Anderer", fp_abschnitt)))
|
||
if (length(erg$reaktion_codes) == 0) {
|
||
doc = body_add_fpar(doc, fpar(ftext("Keine Reaktionen ausgewählt.", fp_normal)))
|
||
} else {
|
||
for (code in erg$reaktion_codes) {
|
||
doc = body_add_fpar(doc, fpar(ftext(paste0(toupper(code), ": ", VDS32_REAKTIONEN_TEXTE[[code]]), fp_normal)))
|
||
}
|
||
}
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext("Anzahl belasteter Reaktionsmuster (r01–r15): ", fp_label),
|
||
ftext(as.character(erg$reaktion_summe), fp_normal)
|
||
))
|
||
doc = body_add_fpar(doc, fpar(ftext(
|
||
"r16/r17 (positive Reaktionen) sind nicht in dieser Anzahl enthalten. Kein offiziell validierter Summenscore.",
|
||
fp_klein)))
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
for (block in erg$reaktions_bloecke) {
|
||
doc = body_add_fpar(doc, fpar(ftext(block$titel, fp_text(bold = TRUE, font.size = 11, color = "#333333"))))
|
||
for (eintrag in block$eintraege) {
|
||
zeile_text = paste0(
|
||
eintrag$rang, ". ",
|
||
if (is.na(eintrag$text_gewaehlt)) "k. A." else eintrag$text_gewaehlt,
|
||
if (!is.na(eintrag$wer)) paste0(" (", eintrag$wer, ")") else ""
|
||
)
|
||
doc = body_add_fpar(doc, fpar(ftext(zeile_text, fp_normal)))
|
||
}
|
||
}
|
||
if (!is.na(erg$abschluss_text)) {
|
||
doc = body_add_fpar(doc, fpar(ftext("Abschlussfließtext: ", fp_label)))
|
||
doc = body_add_fpar(doc, fpar(ftext(erg$abschluss_text, fp_normal)))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Therapieziele", fp_abschnitt)))
|
||
if (length(erg$therapieziele) == 0) {
|
||
doc = body_add_fpar(doc, fpar(ftext("Keine Angabe.", fp_normal)))
|
||
} else {
|
||
for (ziel in erg$therapieziele) {
|
||
doc = body_add_fpar(doc, fpar(ftext(paste0("• ", ziel), fp_normal)))
|
||
}
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext(VDS32_DISCLAIMER, fp_disclaimer)))
|
||
|
||
doc
|
||
}
|
||
|
||
|
||
# Server ####
|
||
|
||
server = function(input, output, session) {
|
||
|
||
observe({
|
||
query = parseQueryString(session$clientData$url_search)
|
||
if (!is.null(query$pseudonym) && nchar(trimws(query$pseudonym)) > 0) {
|
||
updateTextInput(session, "pseudonym", value = trimws(query$pseudonym))
|
||
}
|
||
})
|
||
|
||
observe({
|
||
query = parseQueryString(session$clientData$url_search)
|
||
if (!is.null(query$chiffre) && nchar(trimws(query$chiffre)) > 0) {
|
||
updateTextInput(session, "chiffre", value = toupper(trimws(query$chiffre)))
|
||
}
|
||
})
|
||
|
||
# Skripte werden NICHT beim App-Start gesourct, nur beim Klick.
|
||
ergebnis = eventReactive(input$btn_suchen, {
|
||
|
||
chiffre = toupper(trimws(input$chiffre))
|
||
|
||
if (nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0) {
|
||
return(list(typ = "leere_eingabe", meldung = "Bitte Chiffre oder Pseudonym eingeben."))
|
||
}
|
||
if (nchar(trimws(input$pseudonym)) == 0 && !grepl("^[A-Z][0-9]{6}$", chiffre)) {
|
||
return(list(typ = "format_fehler", chiffre = chiffre))
|
||
}
|
||
|
||
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = paste0("Download-Skript nicht gefunden:\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_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 = ok_dl$msg))
|
||
|
||
db_ordner = local({
|
||
ordner = dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE))
|
||
gefunden = NULL
|
||
for (i in 1:5) {
|
||
if (file.exists(file.path(ordner, "pseudonyme.db"))) { gefunden = ordner; break }
|
||
elternteil = dirname(ordner)
|
||
if (elternteil == ordner) break
|
||
ordner = elternteil
|
||
}
|
||
gefunden
|
||
})
|
||
if (is.null(db_ordner)) return(list(typ = "db_nicht_gefunden"))
|
||
|
||
alter_wd = getwd()
|
||
on.exit(setwd(alter_wd), add = TRUE)
|
||
setwd(db_ordner)
|
||
|
||
ok_ps = tryCatch({
|
||
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
|
||
list(ok = TRUE)
|
||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||
if (!ok_ps$ok) return(list(typ = "skript_fehler", meldung = ok_ps$msg))
|
||
|
||
if (!exists("daten_vds32", envir = .GlobalEnv) || !exists("pseudo", envir = .GlobalEnv)) {
|
||
return(list(typ = "daten_fehlen"))
|
||
}
|
||
|
||
daten = get("daten_vds32", envir = .GlobalEnv)
|
||
pseudo_df = get("pseudo", envir = .GlobalEnv)
|
||
|
||
if (!("session" %in% names(daten))) {
|
||
return(list(typ = "daten_fehlen",
|
||
meldung = paste0(
|
||
"Erwartete Spalte 'session' nicht in 'daten_vds32' gefunden. ",
|
||
"Bitte Session-ID-Spaltenname vor Produktiveinsatz prüfen."
|
||
)))
|
||
}
|
||
|
||
if (nchar(trimws(input$pseudonym)) > 0) {
|
||
pw_treffer = pseudo_df[pseudo_df$pseudonym == trimws(input$pseudonym), ]
|
||
if (nrow(pw_treffer) > 0) chiffre = toupper(trimws(pw_treffer$chiffre[1]))
|
||
}
|
||
|
||
treffer_ps = pseudo_df[toupper(trimws(pseudo_df$chiffre)) == chiffre, ]
|
||
if (nrow(treffer_ps) == 0) return(list(typ = "chiffre_nicht_gefunden", chiffre = chiffre))
|
||
|
||
alle_session_ids = unique(treffer_ps$pseudonym)
|
||
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
|
||
|
||
treffer_daten = daten[daten$session %in% alle_session_ids, ]
|
||
if (nrow(treffer_daten) == 0) return(list(typ = "kein_treffer", chiffre = chiffre))
|
||
|
||
mehrfach_warnung = NULL
|
||
if (nrow(treffer_daten) > 1) {
|
||
n = nrow(treffer_daten)
|
||
zeitspalte = intersect(c("created", "ended"), names(treffer_daten))
|
||
if (length(zeitspalte) > 0) {
|
||
treffer_daten = treffer_daten[order(treffer_daten[[zeitspalte[1]]], decreasing = TRUE), ]
|
||
}
|
||
treffer_daten = treffer_daten[1, , drop = FALSE]
|
||
mehrfach_warnung = paste0(
|
||
"Mehrere Ausfüllungen gefunden (", n, " Einträge) — es wird die neueste angezeigt."
|
||
)
|
||
}
|
||
zeile = treffer_daten[1, , drop = FALSE]
|
||
|
||
# Zeitstempel-Spalte fuer Ausfuelldatum/Dateiname nicht verifiziert
|
||
# (kein eigenes Datumsfeld im Bogen, Abschnitt 4.5) - Kandidaten der
|
||
# Reihe nach probiert, kein Rateergebnis erzwungen.
|
||
ausfuelldatum = tryCatch({
|
||
kandidaten = c("ausfuelldatum", "created", "ended")
|
||
spalte = intersect(kandidaten, names(zeile))
|
||
if (length(spalte) > 0) {
|
||
roh = zeile[[spalte[1]]][1]
|
||
as.Date(as.POSIXct(as.character(roh)))
|
||
} else {
|
||
Sys.Date()
|
||
}
|
||
}, error = function(e) Sys.Date())
|
||
|
||
# Emotionsanalyse I: 43 Gefühle x 4 Merkmale (Abschnitt 5.1-5.3).
|
||
roh_i = tryCatch({
|
||
werte_haeufigkeit = setNames(rep(NA_real_, 43), VDS32_ITEM_TABELLE$code)
|
||
werte_akzeptiert = setNames(rep(NA, 43), VDS32_ITEM_TABELLE$code)
|
||
werte_haelt_kaum_aus = setNames(rep(NA, 43), VDS32_ITEM_TABELLE$code)
|
||
werte_traut_sich_kaum = setNames(rep(NA, 43), VDS32_ITEM_TABELLE$code)
|
||
|
||
for (code in VDS32_ITEM_TABELLE$code) {
|
||
feld_h = paste0("vds32_", code, "_haeufigkeit")
|
||
feld_a = paste0("vds32_", code, "_akzeptanz")
|
||
feld_k = paste0("vds32_", code, "_haelt_kaum_aus")
|
||
feld_t = paste0("vds32_", code, "_traut_sich_kaum")
|
||
|
||
if (!(feld_h %in% names(daten))) stop("Erwartetes Feld '", feld_h, "' nicht in 'daten_vds32' gefunden.")
|
||
if (!(feld_a %in% names(daten))) stop("Erwartetes Feld '", feld_a, "' nicht in 'daten_vds32' gefunden.")
|
||
|
||
werte_haeufigkeit[code] = vds32_haeufigkeit_scoring(daten[[feld_h]], zeile[[feld_h]], feld_h)
|
||
werte_akzeptiert[code] = vds32_akzeptanz_ist_akzeptiert(daten[[feld_a]], zeile[[feld_a]], feld_a)
|
||
werte_haelt_kaum_aus[code] = if (feld_k %in% names(daten)) vds32_ist_angekreuzt(zeile[[feld_k]]) else FALSE
|
||
werte_traut_sich_kaum[code] = if (feld_t %in% names(daten)) vds32_ist_angekreuzt(zeile[[feld_t]]) else FALSE
|
||
}
|
||
list(ok = TRUE, h = werte_haeufigkeit, ak = werte_akzeptiert,
|
||
hk = werte_haelt_kaum_aus, ts = werte_traut_sich_kaum)
|
||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||
if (!roh_i$ok) return(list(typ = "extraktion_fehler", meldung = roh_i$msg))
|
||
|
||
gruppen_ergebnisse = lapply(VDS32_GRUPPEN, function(g) {
|
||
codes = VDS32_ITEM_TABELLE$code[VDS32_ITEM_TABELLE$gruppe == g$code]
|
||
n = g$n
|
||
|
||
feld_wichtig = paste0("vds32_", g$feldname, "_wichtigstes")
|
||
feld_zweit = paste0("vds32_", g$feldname, "_zweitwichtigstes")
|
||
wichtigstes = if (feld_wichtig %in% names(daten))
|
||
vds32_code_text(daten[[feld_wichtig]], zeile[[feld_wichtig]][1], VDS32_GEFUEHL_NAMEN) else NA_character_
|
||
zweitwichtigstes = if (feld_zweit %in% names(daten))
|
||
vds32_code_text(daten[[feld_zweit]], zeile[[feld_zweit]][1], VDS32_GEFUEHL_NAMEN) else NA_character_
|
||
|
||
akzeptanz_summe = sum(roh_i$ak[codes])
|
||
list(
|
||
code = g$code, name = g$name, n = n,
|
||
habeich_summe = sum(roh_i$h[codes]), habeich_mw = sum(roh_i$h[codes]) / n,
|
||
akzeptanz_summe = akzeptanz_summe, akzeptanz_mw = akzeptanz_summe / n,
|
||
ablehnung_summe = n - akzeptanz_summe, ablehnung_mw = (n - akzeptanz_summe) / n,
|
||
haelt_kaum_aus_summe = sum(roh_i$hk[codes]), haelt_kaum_aus_mw = sum(roh_i$hk[codes]) / n,
|
||
traut_sich_kaum_summe = sum(roh_i$ts[codes]), traut_sich_kaum_mw = sum(roh_i$ts[codes]) / n,
|
||
wichtigstes = wichtigstes, zweitwichtigstes = zweitwichtigstes
|
||
)
|
||
})
|
||
|
||
akzeptanz_gesamt_summe = sum(roh_i$ak)
|
||
gesamt = list(
|
||
habeich_mw = sum(roh_i$h) / 129,
|
||
akzeptanz_mw = akzeptanz_gesamt_summe / 43,
|
||
ablehnung_mw = (43 - akzeptanz_gesamt_summe) / 43,
|
||
haelt_kaum_aus_mw = sum(roh_i$hk) / 43,
|
||
traut_sich_kaum_mw = sum(roh_i$ts) / 43
|
||
)
|
||
|
||
# Emotionsanalyse II: GUG (Abschnitt 5.5) + Rangfolge (deskriptiv).
|
||
roh_ii = tryCatch({
|
||
werte = sapply(sprintf("%02d", 1:13), function(nr) {
|
||
feld = paste0("vds32_umgang_", nr, "_wert")
|
||
if (!(feld %in% names(daten))) stop("Erwartetes Feld '", feld, "' nicht in 'daten_vds32' gefunden.")
|
||
vds32_umgang_stufe(daten[[feld]], zeile[[feld]], feld)
|
||
})
|
||
list(ok = TRUE, werte = werte)
|
||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||
if (!roh_ii$ok) return(list(typ = "extraktion_fehler", meldung = roh_ii$msg))
|
||
|
||
gug_summe = sum(roh_ii$werte)
|
||
gug_mw = gug_summe / 13
|
||
|
||
umgang_items = lapply(1:13, function(i) {
|
||
nr = sprintf("%02d", i)
|
||
list(
|
||
nr = i, text = unname(VDS32_UMGANG_TEXTE[paste0("u", nr)]),
|
||
wert = roh_ii$werte[[nr]],
|
||
gefuehl = vds32_text_feld(zeile, paste0("vds32_umgang_", nr, "_gefuehl"))
|
||
)
|
||
})
|
||
|
||
rang_umgang = lapply(1:3, function(i) {
|
||
feld_wahl = paste0("vds32_rang_umgang_", i, "_wahl")
|
||
feld_text = paste0("vds32_rang_umgang_", i, "_text")
|
||
list(
|
||
rang = i,
|
||
text_gewaehlt = if (feld_wahl %in% names(daten))
|
||
vds32_code_text(daten[[feld_wahl]], zeile[[feld_wahl]][1], VDS32_UMGANG_TEXTE) else NA_character_,
|
||
freitext = vds32_text_feld(zeile, feld_text)
|
||
)
|
||
})
|
||
|
||
# Emotionsanalyse III: Reaktion Anderer (Abschnitt 4.3 / 5.6).
|
||
reaktion_res = vds32_extrahiere_reaktionen(daten, zeile)
|
||
if (!reaktion_res$ok) return(list(typ = "reaktion_format_fehler", meldung = reaktion_res$meldung))
|
||
reaktion_codes = reaktion_res$codes
|
||
reaktion_summe = sum(reaktion_codes %in% sprintf("r%02d", 1:15))
|
||
|
||
lese_wahl_block = function(titel, praefixe) {
|
||
eintraege = lapply(praefixe, function(p) {
|
||
feld_wahl = paste0(p$feld, "_wahl")
|
||
feld_text = paste0(p$feld, "_text")
|
||
feld_wer = paste0(p$feld, "_wer")
|
||
list(
|
||
rang = p$rang,
|
||
text_gewaehlt = if (feld_wahl %in% names(daten))
|
||
vds32_code_text(daten[[feld_wahl]], zeile[[feld_wahl]][1], VDS32_REAKTIONEN_TEXTE) else NA_character_,
|
||
freitext = vds32_text_feld(zeile, feld_text),
|
||
wer = if (feld_wer %in% names(zeile)) vds32_text_feld(zeile, feld_wer) else NA_character_
|
||
)
|
||
})
|
||
list(titel = titel, eintraege = eintraege)
|
||
}
|
||
|
||
reaktions_bloecke = list(
|
||
lese_wahl_block("Heute – häufigste Reaktionen", list(
|
||
list(feld = "vds32_heute_1", rang = 1),
|
||
list(feld = "vds32_heute_2", rang = 2),
|
||
list(feld = "vds32_heute_3", rang = 3)
|
||
)),
|
||
lese_wahl_block("Kindheit – Mutter", list(
|
||
list(feld = "vds32_kindheit_mutter_1", rang = 1),
|
||
list(feld = "vds32_kindheit_mutter_2", rang = 2)
|
||
)),
|
||
lese_wahl_block("Kindheit – Vater", list(
|
||
list(feld = "vds32_kindheit_vater_1", rang = 1),
|
||
list(feld = "vds32_kindheit_vater_2", rang = 2)
|
||
))
|
||
)
|
||
|
||
abschluss_text = vds32_text_feld(zeile, "vds32_abschluss_text")
|
||
therapieziele = vds32_extrahiere_therapieziele(daten, zeile)
|
||
|
||
list(
|
||
typ = "erfolg",
|
||
chiffre = chiffre,
|
||
ausfuelldatum = ausfuelldatum,
|
||
mehrfach_warnung = mehrfach_warnung,
|
||
gruppen_ergebnisse = gruppen_ergebnisse,
|
||
gesamt = gesamt,
|
||
gug_summe = gug_summe,
|
||
gug_mw = gug_mw,
|
||
umgang_items = umgang_items,
|
||
rang_umgang = rang_umgang,
|
||
reaktion_codes = reaktion_codes,
|
||
reaktion_summe = reaktion_summe,
|
||
reaktions_bloecke = reaktions_bloecke,
|
||
abschluss_text = abschluss_text,
|
||
therapieziele = therapieziele
|
||
)
|
||
})
|
||
|
||
vds32_fehlermeldung = function(d) {
|
||
switch(d$typ,
|
||
"leere_eingabe" = d$meldung,
|
||
"format_fehler" = paste0("Ungültige Chiffre '", d$chiffre, "'. Erwartet: ein Großbuchstabe + 6 Ziffern (z.B. P000123)."),
|
||
"skript_fehler" = paste0("Fehler beim Sourcen eines externen Skripts: ", d$meldung),
|
||
"db_nicht_gefunden" = "Die Datei 'pseudonyme.db' konnte in den übergeordneten Verzeichnissen nicht gefunden werden.",
|
||
"daten_fehlen" = if (!is.null(d$meldung)) d$meldung else "Nach dem Sourcen der Skripte fehlen die erwarteten Objekte 'daten_vds32' oder 'pseudo'.",
|
||
"chiffre_nicht_gefunden" = paste0("Chiffre '", d$chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden."),
|
||
"kein_treffer" = paste0("Kein VDS32-Datensatz für Chiffre '", d$chiffre, "' gefunden."),
|
||
"extraktion_fehler" = paste0("Fehler bei der Auswertung der Item-Rohwerte: ", d$meldung),
|
||
"reaktion_format_fehler" = d$meldung,
|
||
"Unbekannter Fehler."
|
||
)
|
||
}
|
||
|
||
output$fehler_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis()
|
||
if (d$typ != "erfolg") div(class = "alert-fehler", vds32_fehlermeldung(d))
|
||
})
|
||
|
||
output$warnung_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis()
|
||
if (d$typ != "erfolg" || is.null(d$mehrfach_warnung)) return(NULL)
|
||
div(class = "alert-warnung", d$mehrfach_warnung)
|
||
})
|
||
|
||
output$ergebnis_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis()
|
||
if (d$typ != "erfolg") return(NULL)
|
||
|
||
profil_zeilen = lapply(d$gruppen_ergebnisse, function(g) {
|
||
tags$tr(
|
||
tags$td(g$name),
|
||
tags$td(sprintf("%.2f", g$habeich_mw)),
|
||
tags$td(sprintf("%.2f", g$akzeptanz_mw)),
|
||
tags$td(sprintf("%.2f", g$ablehnung_mw)),
|
||
tags$td(sprintf("%.2f", g$haelt_kaum_aus_mw)),
|
||
tags$td(sprintf("%.2f", g$traut_sich_kaum_mw))
|
||
)
|
||
})
|
||
profil_gesamt_zeile = tags$tr(class = "gesamt-zeile",
|
||
tags$td("Gesamt"),
|
||
tags$td(sprintf("%.2f", d$gesamt$habeich_mw)),
|
||
tags$td(sprintf("%.2f", d$gesamt$akzeptanz_mw)),
|
||
tags$td(sprintf("%.2f", d$gesamt$ablehnung_mw)),
|
||
tags$td(sprintf("%.2f", d$gesamt$haelt_kaum_aus_mw)),
|
||
tags$td(sprintf("%.2f", d$gesamt$traut_sich_kaum_mw))
|
||
)
|
||
|
||
wichtigste_ui = lapply(d$gruppen_ergebnisse, function(g) {
|
||
div(class = "kontext-zeile",
|
||
div(class = "kontext-label", paste0(g$name, " – wichtigstes / zweitwichtigstes Gefühl:")),
|
||
div(
|
||
if (is.na(g$wichtigstes)) "k. A." else g$wichtigstes, " / ",
|
||
if (is.na(g$zweitwichtigstes)) "k. A." else g$zweitwichtigstes
|
||
)
|
||
)
|
||
})
|
||
|
||
karte_i = div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Emotionsanalyse I – Profil"),
|
||
div(class = "meta-block",
|
||
tags$strong("Chiffre: "), d$chiffre,
|
||
tags$span(" | ", style = "color:#ccc;"),
|
||
tags$strong("Ausfülldatum: "), format(d$ausfuelldatum, "%d.%m.%Y")
|
||
),
|
||
div(class = "ipsativ-hinweis", VDS32_IPSATIV_HINWEIS),
|
||
tags$table(class = "tabelle-standard",
|
||
tags$thead(tags$tr(
|
||
tags$th("Gruppe"), tags$th("Habe ich (MW)"), tags$th("Akzeptanz (MW)"),
|
||
tags$th("Ablehnung (MW)"), tags$th("Hält kaum aus (MW)"), tags$th("Traut sich kaum (MW)")
|
||
)),
|
||
tags$tbody(profil_zeilen, profil_gesamt_zeile)
|
||
),
|
||
div(class = "hinweis-klein",
|
||
"Hinweis: 'Habe ich (MW)' ist bei den Gruppenzeilen auf die 1-3-Skala bezogen (Divisor = Itemanzahl der Gruppe), ",
|
||
"bei der Gesamtzeile dagegen auf den Wertebereich 0,33-1,0 normiert (Divisor 129 = 43 Items × 3, so in der ",
|
||
"Auswertungsquelle vorgegeben) – beide Zahlen stehen bewusst in derselben Spalte, sind aber nicht direkt vergleichbar."),
|
||
plotOutput("profil_plot", height = "260px"),
|
||
tags$hr(),
|
||
div(wichtigste_ui)
|
||
)
|
||
|
||
umgang_item_zeilen = lapply(d$umgang_items, function(it) {
|
||
tagList(
|
||
div(class = "item-zeile",
|
||
div(class = "item-nr", paste0(it$nr, ".")),
|
||
div(class = "item-text", it$text),
|
||
span(class = "stufe-badge", style = "background:#ECEFF1; color:#37474F;", paste0(it$wert, " / 3"))
|
||
),
|
||
if (!is.na(it$gefuehl)) div(class = "freitext-zitat", paste0("Gefühl: ", it$gefuehl))
|
||
)
|
||
})
|
||
|
||
rang_ui = lapply(d$rang_umgang, function(r) {
|
||
tagList(
|
||
div(class = "item-zeile",
|
||
div(class = "item-nr", paste0(r$rang, ".")),
|
||
div(class = "item-text", if (is.na(r$text_gewaehlt)) "k. A." else r$text_gewaehlt)
|
||
),
|
||
if (!is.na(r$freitext)) div(class = "freitext-zitat", r$freitext)
|
||
)
|
||
})
|
||
|
||
karte_ii = div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Emotionsanalyse II – Dysfunktionaler Umgang (GUG)"),
|
||
div(class = "kontext-zeile",
|
||
div(class = "kontext-label", "GUG-Summe:"), div(paste0(d$gug_summe, " / 39"))
|
||
),
|
||
div(class = "kontext-zeile",
|
||
div(class = "kontext-label", "GUG-Mittelwert:"), div(sprintf("%.2f / 3", d$gug_mw))
|
||
),
|
||
tags$div(class = "abschnitt-untertitel", "Häufigster Umgang (Rangfolge)"),
|
||
div(rang_ui),
|
||
tags$details(class = "details-block",
|
||
tags$summary("Alle 13 Umgangs-Items anzeigen"),
|
||
div(umgang_item_zeilen)
|
||
)
|
||
)
|
||
|
||
reaktion_liste_ui = if (length(d$reaktion_codes) == 0) {
|
||
div(class = "hinweis-klein", "Keine Reaktionen ausgewählt.")
|
||
} else {
|
||
div(lapply(d$reaktion_codes, function(code) {
|
||
div(class = "item-zeile",
|
||
div(class = "item-nr", toupper(code)),
|
||
div(class = "item-text", unname(VDS32_REAKTIONEN_TEXTE[[code]]))
|
||
)
|
||
}))
|
||
}
|
||
|
||
bloecke_ui = lapply(d$reaktions_bloecke, function(block) {
|
||
tagList(
|
||
tags$div(class = "abschnitt-untertitel", block$titel),
|
||
div(lapply(block$eintraege, function(e) {
|
||
tagList(
|
||
div(class = "item-zeile",
|
||
div(class = "item-nr", paste0(e$rang, ".")),
|
||
div(class = "item-text",
|
||
if (is.na(e$text_gewaehlt)) "k. A." else e$text_gewaehlt,
|
||
if (!is.na(e$wer)) paste0(" (", e$wer, ")") else ""
|
||
)
|
||
),
|
||
if (!is.na(e$freitext)) div(class = "freitext-zitat", e$freitext)
|
||
)
|
||
}))
|
||
)
|
||
})
|
||
|
||
karte_iii = div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Emotionsanalyse III – Reaktion Anderer"),
|
||
reaktion_liste_ui,
|
||
div(class = "kontext-zeile",
|
||
div(class = "kontext-label", "Anzahl belasteter Reaktionsmuster (r01–r15):"),
|
||
div(as.character(d$reaktion_summe))
|
||
),
|
||
div(class = "hinweis-klein",
|
||
"r16/r17 (positive Reaktionen) sind nicht in dieser Anzahl enthalten. Kein offiziell validierter Summenscore."),
|
||
tags$hr(),
|
||
bloecke_ui,
|
||
if (!is.na(d$abschluss_text)) tagList(
|
||
tags$div(class = "abschnitt-untertitel", "Abschlussfließtext"),
|
||
div(class = "freitext-zitat", style = "margin-left: 0;", d$abschluss_text)
|
||
)
|
||
)
|
||
|
||
karte_therapieziele = div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Therapieziele"),
|
||
if (length(d$therapieziele) == 0)
|
||
div(class = "hinweis-klein", "Keine Angabe.")
|
||
else
|
||
tags$ul(lapply(d$therapieziele, tags$li)),
|
||
div(class = "disclaimer-zeile", VDS32_DISCLAIMER)
|
||
)
|
||
|
||
tagList(karte_i, karte_ii, karte_iii, karte_therapieziele)
|
||
})
|
||
|
||
output$profil_plot = renderPlot({
|
||
req(input$btn_suchen)
|
||
d = ergebnis()
|
||
req(d$typ == "erfolg")
|
||
make_vds32_profil_plot(d$gruppen_ergebnisse)
|
||
}, bg = "transparent")
|
||
|
||
output$download_word = downloadHandler(
|
||
filename = function() {
|
||
d = tryCatch(ergebnis(), error = function(e) NULL)
|
||
erfolgreich = is.list(d) && identical(d$typ, "erfolg")
|
||
chiffre_esc = if (erfolgreich && nchar(d$chiffre) > 0) gsub("[^A-Za-z0-9_-]", "_", d$chiffre) else "export"
|
||
ausfuelldatum_fn = if (erfolgreich) {
|
||
tryCatch(format(as.Date(d$ausfuelldatum), "%Y%m%d"),
|
||
error = function(e) format(Sys.Date(), "%Y%m%d"))
|
||
} else {
|
||
format(Sys.Date(), "%Y%m%d")
|
||
}
|
||
paste0("VDS32_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
|
||
},
|
||
content = function(file) {
|
||
d = tryCatch(ergebnis(), error = function(e) NULL)
|
||
erfolgreich = is.list(d) && identical(d$typ, "erfolg")
|
||
if (!erfolgreich) {
|
||
doc = read_docx()
|
||
doc = body_add_par(doc,
|
||
"Kein Datensatz geladen. Bitte zuerst Chiffre oder Pseudonym eingeben und 'Auswerten' klicken.",
|
||
style = "Normal")
|
||
print(doc, target = file)
|
||
return()
|
||
}
|
||
doc = tryCatch(
|
||
erstelle_vds32_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)
|