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

Initial commit

Browse source
This commit is contained in:
Jonas Karneboge 2026-09-22 18:35:43 +02:00
commit 3cba772836
1341 changed files with 532924 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

BIN
VDS24/.RData Normal file
View file

Binary file not shown.

1
VDS24/.Rprofile Normal file
View file

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

13
VDS24/VDS24.Rproj Normal file
View file

@ -0,0 +1,13 @@
Version: 1.0
RestoreWorkspace: Default
SaveWorkspace: Default
AlwaysSaveHistory: Default
EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: UTF-8
RnwWeave: Sweave
LaTeX: pdfLaTeX

905
VDS24/app.R Normal file
View file

@ -0,0 +1,905 @@
# Präambel ####
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_vds24.R" # liefert: daten_vds24
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo
AKZENT_FARBE = "#8B2635"
VDS24_DISCLAIMER = paste0(
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
"keine klinische Diagnose. Es liegen keine Normwerte oder Vergleichsstichproben vor; ",
"die Interpretation der Faktorwerte obliegt der behandelnden Person."
)
VDS24_DISCLAIMER = gsub("fuer", "für", VDS24_DISCLAIMER, fixed = TRUE)
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 ####
# Stufenwert (0-5) wird ausschliesslich aus dem Label-Text extrahiert (fuehrende
# Ziffer vor " = "), niemals aus dem Rohcode selbst - der Rohcode ist typischerweise
# 1-indiziert und die genaue Kodierung kann je nach formr-Instanz variieren.
item_score = function(daten, feldname) {
x = daten[[feldname]]
labels_attr = attr(x, "labels")
if (is.null(labels_attr)) return(as.numeric(x))
treffer = match(as.numeric(x), as.numeric(labels_attr))
as.numeric(sub("^(\\d+).*", "\\1", names(labels_attr)[treffer]))
}
# OFFENER PUNKT FUER ERSTEN TESTLAUF (Spezifikation Abschnitt 7.5 / 12.1):
# Exportformat der mc_multiple-Felder (_vm) ist fuer diese formr-Instanz nicht
# durch echte Testdaten verifiziert. Deckt defensiv zwei plausible Formate ab:
# mehrere Boolean-/Label-Spalten je Choice, oder eine Spalte mit
# komma-/semikolongetrennter Werteliste.
vater_mutter_lesen = function(daten, feld_vm) {
einzelspalten = grep(paste0("^", feld_vm, "(_|$)"), names(daten), value = TRUE)
if (length(einzelspalten) > 1) {
treffer = einzelspalten[sapply(daten[einzelspalten], function(x) isTRUE(as.logical(x)) || identical(as.character(x), "1"))]
ergebnis = gsub(paste0("^", feld_vm, "_"), "", treffer)
} else if (feld_vm %in% names(daten)) {
roh = as.character(daten[[feld_vm]])
ergebnis = trimws(strsplit(roh, "[,;]")[[1]])
ergebnis = ergebnis[nchar(ergebnis) > 0]
} else {
ergebnis = character(0)
}
ergebnis
}
# Rohwerte aus vater_mutter_lesen() (Choice-Text oder Spaltensuffix) auf eine
# der vier Anzeigekategorien abbilden. Nicht erkennbare Rohwerte werden
# transparent mitangezeigt statt stillschweigend verworfen.
vds24_vm_anzeige = function(rohwerte) {
rohwerte = trimws(as.character(rohwerte))
rohwerte = rohwerte[!is.na(rohwerte) & nchar(rohwerte) > 0]
hat_vater = any(grepl("vater", rohwerte, ignore.case = TRUE))
hat_mutter = any(grepl("mutter", rohwerte, ignore.case = TRUE))
if (hat_vater && hat_mutter) return("Vater und Mutter")
if (hat_vater) return("Vater")
if (hat_mutter) return("Mutter")
if (length(rohwerte) > 0) return(paste0("keine Angabe (roh: ", paste(rohwerte, collapse = ", "), ")"))
"keine Angabe"
}
# Faktor-Rohwertsumme und -Mittelwert (0-5). NA-Items werden aus Summe UND
# Anzahl-Divisor ausgeschlossen (Abschnitt 7.2) statt stillschweigend mit
# falschem Mittelwert zu rechnen.
vds24_faktor_auswerten = function(werte) {
vorhanden = !is.na(werte)
n_vorhanden = sum(vorhanden)
n_gesamt = length(werte)
rohsumme = if (n_vorhanden > 0) sum(werte[vorhanden]) else NA_real_
mittelwert = if (n_vorhanden > 0) rohsumme / n_vorhanden else NA_real_
list(rohsumme = rohsumme, mittelwert = mittelwert, n_vorhanden = n_vorhanden, n_gesamt = n_gesamt)
}
# Profilwert (0-3-Skala) nur fuer die Diagrammachse, siehe Abschnitt 7.3.
vds24_profilwert = function(mittelwert) mittelwert * 3 / 5
# Freitext lesen, leere/NA-Werte einheitlich als NA_character_.
vds24_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
}
# Die Rangfolge-Wahlfelder sind vom Typ "select_one <listname>" und
# referenzieren eine externe Choice-Liste (blocka/blockb/blockc/blockab/alle
# im choices-Blatt der Formular-xlsx) - anders als die 21 Ratingitems (Typ
# "mc" mit inline definierten Choices), die als numerischer Code + labels-
# Attribut exportiert werden. formr exportiert select_one-Felder mit
# Listenreferenz typischerweise als internen Choice-NAMEN (z.B. "blockc3"),
# nicht als Klartext - eine direkte haven::as_factor()-Umwandlung liefert in
# dem Fall nur den unveraenderten internen Code zurueck. Der interne Name
# kodiert die Item-Nummer nach einem festen, aus der xlsx abgelesenen Schema,
# das hier zur Aufloesung genutzt wird.
VDS24_WAHL_LISTEN = list(
list(prefix = "blockab", zu_nr = function(n) as.character(n)),
list(prefix = "blocka", zu_nr = function(n) as.character(n)),
list(prefix = "blockb", zu_nr = function(n) as.character(n)),
list(prefix = "blockc", zu_nr = function(n) paste0("H", n)),
list(prefix = "a", zu_nr = function(n) if (n <= 14) as.character(n) else paste0("H", n - 14))
)
# Rohwert (interner Choice-Name ODER bereits aufgeloester Klartext) auf
# Item-Nummer + Kurztext abbilden. Prefixe sind absteigend nach Laenge
# geprueft ("blockab" vor "blocka"), damit z.B. "blockab3" nicht faelschlich
# als Praefix "blocka" + Rest "b3" fehlinterpretiert wird.
vds24_wahl_zu_item = function(roh) {
x = trimws(as.character(roh))
if (is.na(x) || nchar(x) == 0) return(NULL)
for (liste in VDS24_WAHL_LISTEN) {
if (grepl(paste0("^", liste$prefix, "[0-9]+$"), x)) {
num = as.integer(sub(paste0("^", liste$prefix), "", x))
nr = liste$zu_nr(num)
treffer = which(VDS24_ITEMS$nr == nr)
if (length(treffer) == 1) {
return(list(nr = nr, kurztext = VDS24_ITEMS$kurztext[treffer]))
}
}
}
# Fallback: Rohwert ist evtl. bereits Klartext (z.B. "3. Zuverlaessiger
# Schutz") - fuehrende Nummerierung entfernen und gegen die bekannten
# Kurztexte matchen, statt den Rohwert unerklaert stehen zu lassen.
x_bereinigt = trimws(sub("^[A-Za-z0-9]+[.\\\\]?\\s*", "", x))
treffer = which(tolower(VDS24_ITEMS$kurztext) == tolower(x_bereinigt))
if (length(treffer) == 1) {
return(list(nr = VDS24_ITEMS$nr[treffer], kurztext = VDS24_ITEMS$kurztext[treffer]))
}
NULL
}
# select_one-Felder zuerst ueber vds24_wahl_zu_item() aufloesen (siehe oben);
# nur falls ein labels-Attribut vorliegt (numerisch kodiertes Feld), zusaetzlich
# haven::as_factor() als Zwischenschritt versuchen. Nicht zuordenbare Rohwerte
# werden transparent mit Hinweis angezeigt statt stillschweigend verworfen
# (Abschnitt 7.6).
vds24_wahl_feld = function(zeile, feldname) {
if (!(feldname %in% names(zeile))) return(NA_character_)
roh = zeile[[feldname]][1]
if (is.null(roh) || (length(roh) == 1 && is.na(roh))) return(NA_character_)
hat_labels = !is.null(attr(zeile[[feldname]], "labels"))
kandidat = if (hat_labels) {
tryCatch(as.character(haven::as_factor(zeile[[feldname]]))[1], error = function(e) as.character(roh))
} else {
as.character(roh)
}
if (is.na(kandidat) || trimws(kandidat) == "" || trimws(kandidat) == "NA") return(NA_character_)
treffer = vds24_wahl_zu_item(kandidat)
if (!is.null(treffer)) {
return(paste0(treffer$nr, ". ", treffer$kurztext))
}
paste0(trimws(kandidat), " (Rohwert nicht zuordenbar)")
}
# Neutrales Profildiagramm ohne Farbzonen/Ampel-Klassifikation (Abschnitt 7.4) -
# fuer VDS24 gibt es keine Normwerte, an denen sich eine Einfaerbung fachlich
# begruenden liesse. Einheitliche Balkenfarbe in AKZENT_FARBE.
vds24_profil_plot = function(faktor_df) {
faktor_df$faktor = factor(faktor_df$faktor, levels = rev(FAKTOR_REIHENFOLGE))
faktor_df$y_balken = ifelse(is.na(faktor_df$profilwert), 0, faktor_df$profilwert)
faktor_df$beschriftung = ifelse(
is.na(faktor_df$mittelwert), "k. A.",
paste0(format(round(faktor_df$mittelwert, 1), nsmall = 1), " / 5")
)
ggplot(faktor_df, aes(x = faktor, y = y_balken)) +
geom_col(fill = AKZENT_FARBE, width = 0.6) +
geom_text(aes(label = beschriftung), hjust = -0.12, size = 4, color = "#333333") +
coord_flip() +
scale_y_continuous(limits = c(0, 3.6), breaks = 0:3) +
labs(x = NULL, y = "Profilwert (0–3), entspricht Faktor-Mittelwert × 3/5") +
theme_minimal(base_size = 12) +
theme(
panel.grid.minor = element_blank(),
axis.text.y = element_text(face = "bold", color = "#333333"),
plot.margin = margin(t = 5, r = 40, b = 5, l = 5)
)
}
# Datenaufbereitung ####
# Faktor-Reihenfolge fuer alle Anzeigen und das Profildiagramm (Abschnitt 5).
FAKTOR_REIHENFOLGE = c("BINDUNG", "SELBSTWERT", "AUTONOMIE", "ORIENTIERUNG", "IDENTITÄT", "HOMÖOSTASE")
# Statische Item-Faktor-Zuordnungstabelle, fest aus der Spezifikation
# uebernommen (nicht aus Item-Labels der Rohdaten zur Laufzeit abgeleitet) -
# vds24_h1..h7 haben in der xlsx kein eigenes Label, der Itemtext steht nur
# im _vm-Feld, daher hier vollstaendig hinterlegt.
VDS24_ITEMS = data.frame(
nr = c("1","2","3","4","5","6","7","8","9","10","11","12","13","14",
"H1","H2","H3","H4","H5","H6","H7"),
feld_rating = c("vds24_01","vds24_02","vds24_03","vds24_04","vds24_05","vds24_06",
"vds24_07","vds24_08","vds24_09","vds24_10","vds24_11","vds24_12",
"vds24_13","vds24_14","vds24_h1","vds24_h2","vds24_h3","vds24_h4",
"vds24_h5","vds24_h6","vds24_h7"),
feld_vm = c("vds24_01_vm","vds24_02_vm","vds24_03_vm","vds24_04_vm","vds24_05_vm",
"vds24_06_vm","vds24_07_vm","vds24_08_vm","vds24_09_vm","vds24_10_vm",
"vds24_11_vm","vds24_12_vm","vds24_13_vm","vds24_14_vm","vds24_h1_vm",
"vds24_h2_vm","vds24_h3_vm","vds24_h4_vm","vds24_h5_vm","vds24_h6_vm",
"vds24_h7_vm"),
itemtext = c(
"Mir fehlte Willkommensein",
"Mir fehlte Geborgenheit",
"Mir fehlte zuverlässiger Schutz",
"Mir fehlte Liebe",
"Mir fehlte Beachtung, Aufmerksamkeit",
"Mir fehlte Verständnis",
"Mir fehlte Wertschätzung, Bewunderung, Lob",
"Mir fehlte Selbst machen, selbst können",
"Mir fehlte Selbstbestimmung",
"Mir fehlte Genügend Grenzen",
"Mir fehlte Gefördert und gefordert werden",
"Mir fehlte ein hilfreiches Vorbild",
"Mir fehlte Intimität, Hingabe, kindliche Erotik",
"Mir fehlte ein Gegenüber",
"Eine ängstliche Bezugsperson war …",
"Eine bedrohliche Bezugsperson war …",
"Eine bedrohliche Außenwelt wurde mir vermittelt von …",
"Extrem wütend machte mich immer wieder …",
"Viel zu schwach als Gegenpol zum anderen Elternteil war …",
"Schuldgefühle machte mir immer wieder …",
"Missbraucht für seine eigenen Bedürfnisse hat mich …"
),
# Kurztexte wie im choices-Blatt der Formular-xlsx hinterlegt (Choice-Label
# der Rangfolge-Auswahlfelder) - kuerzer/anders formuliert als itemtext, wird
# ausschliesslich zur Aufloesung/Anzeige der Rangfolge-Auswahl genutzt
# (Abschnitt 7.6), nicht fuer die Itemliste je Faktor.
kurztext = c(
"Willkommensein",
"Geborgenheit",
"Zuverlässiger Schutz",
"Liebe",
"Beachtung, Aufmerksamkeit",
"Verständnis",
"Wertschätzung, Bewunderung, Lob",
"Selbst machen, selbst können",
"Selbstbestimmung",
"Genügend Grenzen",
"Gefördert und gefordert werden",
"Ein hilfreiches Vorbild",
"Intimität, Hingabe, kindliche Erotik",
"Ein Gegenüber",
"Ängstliche Bezugsperson",
"Bedrohliche Bezugsperson",
"Bedrohliche Außenwelt vermittelt",
"Extrem wütend gemacht",
"Zu schwacher Gegenpol zum anderen Elternteil",
"Schuldgefühle gemacht",
"Missbraucht für elterliche Bedürfnisse"
),
faktor = c("BINDUNG","BINDUNG","BINDUNG","BINDUNG",
"SELBSTWERT","SELBSTWERT","SELBSTWERT",
"AUTONOMIE","AUTONOMIE",
"ORIENTIERUNG","ORIENTIERUNG","ORIENTIERUNG",
"IDENTITÄT","IDENTITÄT",
"HOMÖOSTASE","HOMÖOSTASE","HOMÖOSTASE","HOMÖOSTASE","HOMÖOSTASE","HOMÖOSTASE","HOMÖOSTASE"),
stringsAsFactors = FALSE
)
# Kontrollsumme: 4 + 3 + 2 + 3 + 2 + 7 = 21 Items. Bei Abweichung sofort
# abbrechen statt still mit einer falschen Tabelle weiterzurechnen (das wuerde
# einen Copy-Paste-Fehler in der Struktur oben sonst verschleiern).
.vds24_kontrollsumme = nrow(VDS24_ITEMS)
if (.vds24_kontrollsumme != 21) {
stop("VDS24: Item-Faktor-Tabelle hat ", .vds24_kontrollsumme, " Zeilen, erwartet 21.")
}
.vds24_faktor_counts = table(factor(VDS24_ITEMS$faktor, levels = FAKTOR_REIHENFOLGE))
.vds24_counts_erwartet = setNames(c(4, 3, 2, 3, 2, 7), FAKTOR_REIHENFOLGE)
if (!identical(as.integer(.vds24_faktor_counts[FAKTOR_REIHENFOLGE]), as.integer(.vds24_counts_erwartet))) {
stop("VDS24: Itemanzahl je Faktor weicht von der Spezifikation ab. Bitte VDS24_ITEMS pruefen.")
}
# Rangfolge-/Reflexionsfelder (Abschnitt 7.6), rein qualitativ, fliessen nicht
# in Faktor-Rohwerte, -Mittelwerte oder das Profildiagramm ein. frage_wahl ist
# der tatsaechliche Fragetext aus dem survey-Blatt der Formular-xlsx (Spalte
# "label"), unveraendert bis auf die entfernte Ausfuellinstruktion "Bitte
# waehlen Sie das zutreffende Item aus:" - so liest sich Frage + Auswahl als
# ein zusammenhaengender Satz.
VDS24_RANG_STICHWORT_FRAGE = "Stichwort/kurze Beschreibung dazu:"
VDS24_RANG_GEFUEHL_FRAGE = "Mein Gefühl dabei ist:"
VDS24_RANG_FELDER = list(
list(titel = "Abschnitt A – 1. Priorität", frage_wahl = "Die wichtigste Frustration (Abschnitt A) war:",
wahl = "vds24_rang_a1_wahl", stichwort = "vds24_rang_a1_stichwort", gefuehl = "vds24_rang_a1_gefuehl"),
list(titel = "Abschnitt A – 2. Priorität", frage_wahl = "Die 2.wichtigste Frustration (Abschnitt A) war:",
wahl = "vds24_rang_a2_wahl", stichwort = "vds24_rang_a2_stichwort", gefuehl = "vds24_rang_a2_gefuehl"),
list(titel = "Abschnitt B – 1. Priorität", frage_wahl = "Die wichtigste Frustration (Abschnitt B) war:",
wahl = "vds24_rang_b1_wahl", stichwort = "vds24_rang_b1_stichwort", gefuehl = "vds24_rang_b1_gefuehl"),
list(titel = "Abschnitt B – 2. Priorität", frage_wahl = "Die 2.wichtigste Frustration (Abschnitt B) war:",
wahl = "vds24_rang_b2_wahl", stichwort = "vds24_rang_b2_stichwort", gefuehl = "vds24_rang_b2_gefuehl"),
list(titel = "Gesamt (Items 1–14) – wichtigste Frustration", frage_wahl = "Die wichtigste von Nr. 1 bis 14 war:",
wahl = "vds24_rang_b_gesamt_wahl", stichwort = "vds24_rang_b_gesamt_stichwort", gefuehl = NULL),
list(titel = "Abschnitt C – 1. Priorität", frage_wahl = "Die wichtigste Frustration (Abschnitt C) war:",
wahl = "vds24_rang_c1_wahl", stichwort = "vds24_rang_c1_stichwort", gefuehl = "vds24_rang_c1_gefuehl"),
list(titel = "Abschnitt C – 2. Priorität", frage_wahl = "Die 2.wichtigste Frustration (Abschnitt C) war:",
wahl = "vds24_rang_c2_wahl", stichwort = "vds24_rang_c2_stichwort", gefuehl = "vds24_rang_c2_gefuehl"),
list(titel = "Gesamt (Items 1–14 und H1–H7) – wichtigste Frustration", frage_wahl = "Die wichtigste von Nr. 1 bis 14 und H1 bis H7 war:",
wahl = "vds24_rang_c_gesamt_wahl", stichwort = "vds24_rang_c_gesamt_stichwort", gefuehl = NULL)
)
# UI ####
app_css = "
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; }
.app-header {
background: #8B2635; color: white; padding: 18px 24px 14px;
margin-bottom: 20px; border-radius: 0 0 6px 6px;
}
.app-header h2 { margin: 0; font-size: 1.5rem; font-weight: 600; }
.app-header p { margin: 4px 0 0; opacity: 0.85; font-size: 0.9rem; }
.input-panel {
background: white; border-radius: 6px; padding: 16px 20px;
margin-bottom: 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
display: flex; align-items: flex-end; gap: 12px; flex-wrap: wrap;
}
.input-panel .form-group { margin-bottom: 0; }
.input-panel label { font-weight: 600; color: #333; }
.btn-laden {
background: #8B2635 !important; color: white !important;
border: none !important; border-radius: 4px !important;
padding: 8px 20px !important; font-weight: 600 !important; cursor: pointer;
}
.btn-laden:hover { background: #6d1e29 !important; }
.alert-fehler {
background: #FFEBEE; border-left: 5px solid #C62828;
padding: 12px 16px; border-radius: 4px; color: #B71C1C;
margin-bottom: 12px; font-weight: 500;
}
.alert-warnung {
background: #FFF3E0; border-left: 5px solid #E65100;
padding: 10px 16px; border-radius: 4px; color: #BF360C;
margin-bottom: 12px; font-size: 0.93em; font-weight: 500;
}
.abschnitt-karte {
background: white; border-radius: 6px; padding: 20px 24px;
margin-bottom: 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
}
.abschnitt-titel {
color: #8B2635; font-size: 1.15rem; font-weight: 700;
border-bottom: 2px solid #8B2635; padding-bottom: 8px; margin-bottom: 14px;
}
.meta-block { margin-bottom: 10px; color: #555; font-size: 0.95em; }
.meta-block strong { color: #222; }
.item-zeile {
display: flex; align-items: center; 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; }
.item-vm {
font-size: 0.8em; color: #777; font-style: italic; white-space: nowrap; flex-shrink: 0;
}
.item-wert {
background: #8B2635; color: white; border-radius: 4px;
padding: 2px 9px; font-weight: 700; font-size: 0.82em;
white-space: nowrap; display: inline-block; flex-shrink: 0;
}
.faktor-tabelle { width: 100%; border-collapse: collapse; margin-top: 10px; }
.faktor-tabelle th, .faktor-tabelle td {
text-align: left; padding: 6px 10px; border-bottom: 1px solid #eee; font-size: 0.93em;
}
.faktor-tabelle th { color: #8B2635; border-bottom: 2px solid #8B2635; }
.qualitativ-hinweis {
font-size: 0.82em; color: #777; font-style: italic;
margin-bottom: 12px; border-bottom: 1px dashed #ddd; padding-bottom: 8px;
}
.freitext-block { margin-bottom: 14px; }
.freitext-frage { font-weight: 600; color: #8B2635; font-size: 0.95em; margin-bottom: 3px; }
.freitext-antwort { color: #333; font-size: 0.93em; white-space: pre-wrap; line-height: 1.5; }
.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("VDS24 – Frustrierendes Elternverhalten in Kindheit und Jugend"),
tags$p("21 Ratingitems, 6 Bedürfnisbereiche, kein Summenscore, keine Normwerte")
),
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_vds24_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_wert = fp_text(color = "white", bold = TRUE, shading.color = AKZENT_FARBE, font.size = 10)
fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
doc = body_add_fpar(doc, fpar(ftext("VDS24 – Frustrierendes Elternverhalten in Kindheit und Jugend", fp_titel)))
doc = body_add_fpar(doc, fpar(
ftext("Chiffre: ", fp_label), ftext(erg$chiffre, fp_normal),
ftext(" Ausfülldatum: ", fp_label), ftext(erg$ausfuelldatum, fp_normal)
))
if (!is.null(erg$info_mehrere)) {
doc = body_add_fpar(doc, fpar(
ftext(erg$info_mehrere, fp_text(font.size = 10, italic = TRUE, color = "#555555"))
))
}
if (!is.null(erg$ausfuelldatum_warnung)) {
doc = body_add_fpar(doc, fpar(
ftext(erg$ausfuelldatum_warnung, fp_text(font.size = 10, italic = TRUE, color = "#BF360C"))
))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Profil der 6 Bedürfnisbereiche", fp_abschnitt)))
profil_img = tempfile(fileext = ".png")
ggsave(profil_img, plot = vds24_profil_plot(erg$profil_df), width = 7, height = 4, dpi = 150, bg = "white")
doc = body_add_img(doc, src = profil_img, width = 6, height = 3.4)
file.remove(profil_img)
doc = body_add_par(doc, "", style = "Normal")
faktor_tabelle_df = data.frame(
Faktor = sapply(erg$faktor_ergebnisse, function(fe) fe$faktor),
Itemanzahl = sapply(erg$faktor_ergebnisse, function(fe) fe$n_gesamt),
Rohwertsumme = sapply(erg$faktor_ergebnisse, function(fe) if (is.na(fe$rohsumme)) "–" else fe$rohsumme),
`Mittelwert (0-5)` = sapply(erg$faktor_ergebnisse, function(fe) if (is.na(fe$mittelwert)) "–" else format(round(fe$mittelwert, 2), nsmall = 2)),
check.names = FALSE, stringsAsFactors = FALSE
)
doc = body_add_table(doc, faktor_tabelle_df)
doc = body_add_par(doc, "", style = "Normal")
for (fe in erg$faktor_ergebnisse) {
doc = body_add_fpar(doc, fpar(ftext(fe$faktor, fp_abschnitt)))
if (!is.na(fe$mittelwert) && fe$n_vorhanden < fe$n_gesamt) {
doc = body_add_fpar(doc, fpar(ftext(
paste0("Faktor-Score basiert auf ", fe$n_vorhanden, " von ", fe$n_gesamt, " Items."),
fp_text(font.size = 9.5, italic = TRUE, color = "#BF360C")
)))
}
for (r in seq_len(nrow(fe$items))) {
zeile = fe$items[r, ]
wert_txt = if (is.na(zeile$wert)) "k. A." else paste0(zeile$wert, " / 5")
doc = body_add_fpar(doc, fpar(
ftext(paste0(zeile$nr, ". ", zeile$itemtext, " (", zeile$vm, ") "), fp_normal),
ftext(paste0(" ", wert_txt, " "), fp_wert)
))
}
doc = body_add_par(doc, "", style = "Normal")
}
doc = body_add_break(doc)
doc = body_add_fpar(doc, fpar(ftext("Reflexion und Priorisierung (qualitativ)", fp_abschnitt)))
doc = body_add_fpar(doc, fpar(ftext(
"Durch die Patientin/den Patienten angegeben, qualitative Zusatzinformation, kein Zahlenwert.",
fp_text(font.size = 9.5, italic = TRUE, color = "#777777")
)))
doc = body_add_par(doc, "", style = "Normal")
for (rb in erg$rang_bloecke) {
doc = body_add_fpar(doc, fpar(ftext(rb$titel, fp_label)))
doc = body_add_fpar(doc, fpar(
ftext(paste0(rb$frage_wahl, " "), fp_label),
ftext(if (is.na(rb$wahl)) "keine Angabe" else rb$wahl, fp_normal)
))
if (!is.na(rb$stichwort)) {
doc = body_add_fpar(doc, fpar(
ftext(paste0(VDS24_RANG_STICHWORT_FRAGE, " "), fp_label), ftext(rb$stichwort, fp_normal)
))
}
if (!is.na(rb$gefuehl)) {
doc = body_add_fpar(doc, fpar(
ftext(paste0(VDS24_RANG_GEFUEHL_FRAGE, " "), fp_label), ftext(rb$gefuehl, fp_normal)
))
}
doc = body_add_par(doc, "", style = "Normal")
}
doc = body_add_fpar(doc, fpar(ftext("Abschlusstext", fp_label)))
doc = body_add_fpar(doc, fpar(ftext(
if (is.na(erg$abschluss_text)) "Keine Angabe." else erg$abschluss_text, fp_normal
)))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(VDS24_DISCLAIMER, fp_disclaimer)))
doc
}
# Server ####
server = function(input, output, session) {
observe({
query = parseQueryString(session$clientData$url_search)
if (!is.null(query$pseudonym) && nchar(trimws(query$pseudonym)) > 0) {
updateTextInput(session, "pseudonym", value = trimws(query$pseudonym))
}
})
observe({
query = parseQueryString(session$clientData$url_search)
if (!is.null(query$chiffre) && nchar(trimws(query$chiffre)) > 0) {
updateTextInput(session, "chiffre", value = toupper(trimws(query$chiffre)))
}
})
# Skripte werden NICHT beim App-Start gesourct, nur beim Klick auf "Auswerten".
ergebnis_r = eventReactive(input$btn_suchen, {
chiffre = toupper(trimws(input$chiffre))
if (nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0) {
return(list(error = "Bitte Chiffre oder Pseudonym eingeben."))
}
if (nchar(trimws(input$pseudonym)) == 0 && !grepl("^[A-Z][0-9]{6}$", chiffre)) {
return(list(error = "Ungültige Chiffre. Erwartet: ein Großbuchstabe + 6 Ziffern (z.B. P000123)."))
}
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
return(list(error = paste0("Download-Skript nicht gefunden:\n", PFAD_DOWNLOAD_SKRIPT)))
}
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
return(list(error = paste0("Pseudonym-Skript nicht gefunden:\n", PFAD_PSEUDONYM_SKRIPT)))
}
res_dl = tryCatch(
{ source(PFAD_DOWNLOAD_SKRIPT, local = FALSE); list(ok = TRUE) },
error = function(e) list(ok = FALSE, msg = e$message)
)
if (!res_dl$ok) return(list(error = paste0("Fehler im Download-Skript: ", res_dl$msg)))
db_ordner = local({
ordner = dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE))
gefunden = NULL
for (i in 1:5) {
if (file.exists(file.path(ordner, "pseudonyme.db"))) {
gefunden = ordner
break
}
elternteil = dirname(ordner)
if (elternteil == ordner) break
ordner = elternteil
}
gefunden
})
alter_wd = getwd()
wd_ziel = if (!is.null(db_ordner)) db_ordner else
dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE))
setwd(wd_ziel)
on.exit(setwd(alter_wd), add = TRUE)
res_ps = tryCatch({
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
if (nchar(trimws(input$pseudonym)) > 0) {
pw_treffer = pseudo[pseudo$pseudonym == trimws(input$pseudonym), ]
if (nrow(pw_treffer) > 0) chiffre = toupper(trimws(pw_treffer$chiffre[1]))
}
list(ok = TRUE)
}, error = function(e) list(ok = FALSE, msg = e$message))
if (!res_ps$ok) return(list(error = paste0("Fehler im Pseudonym-Skript: ", res_ps$msg)))
if (!exists("daten_vds24", envir = .GlobalEnv)) {
return(list(error = "Objekt 'daten_vds24' nach dem Sourcen nicht gefunden. Bitte Download-Skript prüfen."))
}
if (!exists("pseudo", envir = .GlobalEnv)) {
return(list(error = "Objekt 'pseudo' nach dem Sourcen nicht gefunden. Bitte Pseudonym-Skript prüfen."))
}
daten = get("daten_vds24", envir = .GlobalEnv)
pseudo_df = get("pseudo", envir = .GlobalEnv)
treffer_ps = pseudo_df[pseudo_df$chiffre == chiffre, ]
if (nrow(treffer_ps) == 0) {
return(list(error = paste0("Chiffre '", chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden.")))
}
alle_session_ids = unique(treffer_ps$pseudonym)
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
zeilen_index = which(daten$session %in% alle_session_ids)
if (length(zeilen_index) == 0) {
return(list(error = paste0(
"Kein VDS24-Datensatz für Chiffre '", chiffre, "' gefunden. ",
"(", length(alle_session_ids), " Pseudonym(e) geprüft)")))
}
# OFFENER PUNKT FUER ERSTEN TESTLAUF (Spezifikation Abschnitt 9 / 12.2):
# Name der Datumsspalte fuer das Ausfuelldatum ist nicht durch echte
# Exportdaten verifiziert. Kandidaten der Reihe nach probieren, sonst
# Sys.Date()-Fallback mit sichtbarer Warnung statt stiller Fehlannahme.
sortier_spalte = intersect(c("created", "ended", "expired"), names(daten))
sortier_spalte = if (length(sortier_spalte) > 0) sortier_spalte[1] else NA_character_
info_mehrere = NULL
if (length(zeilen_index) > 1) {
n = length(zeilen_index)
if (!is.na(sortier_spalte)) {
reihenfolge = order(daten[[sortier_spalte]][zeilen_index], decreasing = TRUE)
zeilen_index = zeilen_index[reihenfolge]
datum_neu = tryCatch(
format(as.POSIXct(daten[[sortier_spalte]][zeilen_index[1]]), "%d.%m.%Y %H:%M"),
error = function(e) "unbekanntes Datum"
)
} else {
datum_neu = "unbekanntes Datum (keine Datumsspalte gefunden)"
}
info_mehrere = paste0(
"Mehrere Ausfüllungen gefunden (", n, " Einträge). ",
"Angezeigt wird die neueste vom ", datum_neu, "."
)
}
zeile_idx = zeilen_index[1]
zeile = daten[zeile_idx, , drop = FALSE]
ausfuelldatum_warnung = NULL
ausfuelldatum = NA_character_
if (!is.na(sortier_spalte)) {
ausfuelldatum = tryCatch({
d = format(as.POSIXct(daten[[sortier_spalte]][zeile_idx]), "%d.%m.%Y")
if (is.na(d)) stop("NA")
d
}, error = function(e) NA_character_)
}
if (is.na(ausfuelldatum)) {
ausfuelldatum = format(Sys.Date(), "%d.%m.%Y")
ausfuelldatum_warnung = "Ausfülldatum konnte nicht aus den Daten ermittelt werden."
}
# --- Itemwerte (0-5) je Ratingfeld: item_score() wird auf die VOLLE Spalte
# angewandt, damit das labels-Attribut immer vom Original-Spaltenobjekt
# gelesen wird (Abschnitt 7.1), danach per Zeilenindex reduziert. ---
item_werte = sapply(VDS24_ITEMS$feld_rating, function(f) {
if (!(f %in% names(daten))) return(NA_real_)
werte_spalte = item_score(daten, f)
werte_spalte[zeile_idx]
})
names(item_werte) = VDS24_ITEMS$feld_rating
vm_werte = sapply(VDS24_ITEMS$feld_vm, function(f) {
vds24_vm_anzeige(vater_mutter_lesen(zeile, f))
})
names(vm_werte) = VDS24_ITEMS$feld_vm
faktor_ergebnisse = lapply(FAKTOR_REIHENFOLGE, function(fname) {
idx_zeilen = which(VDS24_ITEMS$faktor == fname)
werte = item_werte[VDS24_ITEMS$feld_rating[idx_zeilen]]
fs = vds24_faktor_auswerten(werte)
items_df = data.frame(
nr = VDS24_ITEMS$nr[idx_zeilen],
itemtext = VDS24_ITEMS$itemtext[idx_zeilen],
wert = unname(werte),
vm = unname(vm_werte[VDS24_ITEMS$feld_vm[idx_zeilen]]),
stringsAsFactors = FALSE
)
list(
faktor = fname, rohsumme = fs$rohsumme, mittelwert = fs$mittelwert,
n_vorhanden = fs$n_vorhanden, n_gesamt = fs$n_gesamt, items = items_df
)
})
names(faktor_ergebnisse) = FAKTOR_REIHENFOLGE
profil_df = data.frame(
faktor = FAKTOR_REIHENFOLGE,
mittelwert = sapply(faktor_ergebnisse, function(fe) fe$mittelwert),
stringsAsFactors = FALSE
)
profil_df$profilwert = vds24_profilwert(profil_df$mittelwert)
rang_bloecke = lapply(VDS24_RANG_FELDER, function(f) {
list(
titel = f$titel,
frage_wahl = f$frage_wahl,
wahl = vds24_wahl_feld(zeile, f$wahl),
stichwort = vds24_text_feld(zeile, f$stichwort),
gefuehl = if (is.null(f$gefuehl)) NA_character_ else vds24_text_feld(zeile, f$gefuehl)
)
})
abschluss_text = vds24_text_feld(zeile, "vds24_abschluss_text")
list(
chiffre = chiffre,
ausfuelldatum = ausfuelldatum,
ausfuelldatum_warnung = ausfuelldatum_warnung,
info_mehrere = info_mehrere,
faktor_ergebnisse = faktor_ergebnisse,
profil_df = profil_df,
rang_bloecke = rang_bloecke,
abschluss_text = abschluss_text,
error = NULL
)
})
output$fehler_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (!is.null(d$error)) div(class = "alert-fehler", d$error)
})
output$warnung_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (!is.null(d$error)) return(NULL)
tagList(
if (!is.null(d$info_mehrere)) div(class = "alert-warnung", d$info_mehrere),
if (!is.null(d$ausfuelldatum_warnung)) div(class = "alert-warnung", d$ausfuelldatum_warnung)
)
})
output$ergebnis_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (!is.null(d$error)) return(NULL)
faktor_tabelle_zeilen = lapply(d$faktor_ergebnisse, function(fe) {
tags$tr(
tags$td(fe$faktor),
tags$td(fe$n_gesamt),
tags$td(if (is.na(fe$rohsumme)) "–" else fe$rohsumme),
tags$td(if (is.na(fe$mittelwert)) "–" else format(round(fe$mittelwert, 2), nsmall = 2))
)
})
faktor_tabelle = tags$table(class = "faktor-tabelle",
tags$thead(tags$tr(
tags$th("Faktor"), tags$th("Itemanzahl"), tags$th("Rohwertsumme"), tags$th("Mittelwert (0–5)")
)),
tags$tbody(faktor_tabelle_zeilen)
)
item_karten = lapply(d$faktor_ergebnisse, function(fe) {
items_ui = lapply(seq_len(nrow(fe$items)), function(r) {
zeile = fe$items[r, ]
div(class = "item-zeile",
div(class = "item-nr", paste0(zeile$nr, ".")),
div(class = "item-text", zeile$itemtext),
span(class = "item-vm", zeile$vm),
span(class = "item-wert", if (is.na(zeile$wert)) "k. A." else paste0(zeile$wert, " / 5"))
)
})
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", fe$faktor),
if (!is.na(fe$mittelwert) && fe$n_vorhanden < fe$n_gesamt)
div(class = "alert-warnung",
paste0("Unvollständig ausgefüllt: Faktor-Score basiert auf ", fe$n_vorhanden,
" von ", fe$n_gesamt, " Items.")),
div(items_ui)
)
})
rang_ui = lapply(d$rang_bloecke, function(rb) {
div(class = "freitext-block",
div(class = "freitext-frage", rb$titel),
div(class = "freitext-antwort",
tags$div(tags$strong(paste0(rb$frage_wahl, " ")), if (is.na(rb$wahl)) "keine Angabe" else rb$wahl),
if (!is.na(rb$stichwort)) tags$div(tags$strong(paste0(VDS24_RANG_STICHWORT_FRAGE, " ")), rb$stichwort),
if (!is.na(rb$gefuehl)) tags$div(tags$strong(paste0(VDS24_RANG_GEFUEHL_FRAGE, " ")), rb$gefuehl)
)
)
})
reflexion_karte = div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Reflexion und Priorisierung (durch die Patientin/den Patienten, qualitativ)"),
div(class = "qualitativ-hinweis", "Qualitative Zusatzinformation, kein Zahlenwert, fließt nicht in Faktorwerte ein."),
rang_ui,
tags$hr(),
div(class = "freitext-block",
div(class = "freitext-frage", "Abschlusstext (Auswirkung auf Persönlichkeit/Beziehungsgestaltung)"),
div(class = "freitext-antwort",
if (is.na(d$abschluss_text)) "Keine Angabe." else d$abschluss_text)
)
)
tagList(
div(class = "abschnitt-karte",
div(class = "meta-block",
tags$strong("Chiffre: "), d$chiffre,
tags$span(" | ", style = "color:#ccc;"),
tags$strong("Ausfülldatum: "), d$ausfuelldatum
)
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Profil der 6 Bedürfnisbereiche"),
plotOutput("profil_plot", height = "340px"),
tags$hr(),
faktor_tabelle
),
item_karten,
reflexion_karte,
div(class = "disclaimer-zeile", VDS24_DISCLAIMER)
)
})
output$profil_plot = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(is.null(d$error))
vds24_profil_plot(d$profil_df)
}, bg = "transparent")
output$download_word = downloadHandler(
filename = function() {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
chiffre_esc = if (is.list(d) && is.null(d$error) && nchar(d$chiffre) > 0)
gsub("[^A-Za-z0-9_-]", "_", d$chiffre) else "export"
datum_fn = if (is.list(d) && is.null(d$error) && !is.null(d$ausfuelldatum)) {
tryCatch(
format(as.Date(d$ausfuelldatum, "%d.%m.%Y"), "%Y%m%d"),
error = function(e) format(Sys.Date(), "%Y%m%d")
)
} else {
format(Sys.Date(), "%Y%m%d")
}
paste0("VDS24_", chiffre_esc, "_", datum_fn, ".docx")
},
content = function(file) {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
daten_ok = is.list(d) && is.null(d$error)
if (!daten_ok) {
doc = read_docx()
doc = body_add_par(doc,
"Kein Datensatz geladen. Bitte zuerst Chiffre oder Pseudonym eingeben und 'Auswerten' klicken.",
style = "Normal")
print(doc, target = file)
return()
}
doc = tryCatch(
erstelle_vds24_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)

2879
VDS24/renv.lock Normal file
View file

File diff suppressed because it is too large Load diff

17
VDS24/setup_renv.R Normal file
View file

@ -0,0 +1,17 @@
# Einmalig ausfuehren, bevor die App zum ersten Mal gestartet wird.
# Initialisiert renv und installiert alle benoetigten Pakete.
#
# formr wird hier installiert, weil das extern gesourcte Download-Skript
# (get_data_vds24.R) es benoetigt - die App selbst laedt formr nicht per
# library() und spricht nie direkt mit der formr-API.
# DBI und RSQLite werden vom gesourcten Pseudonym-Skript benoetigt,
# nicht direkt von der App selbst.
renv::init()
pkgs = c("shiny", "dplyr", "ggplot2", "haven", "officer", "DBI", "RSQLite", "formr")
install.packages(pkgs)
renv::snapshot()
message("Setup abgeschlossen. App starten mit: shiny::runApp()")