Initial commit

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

BIN
VDS26/.RData Normal file

Binary file not shown.

1
VDS26/.Rprofile Normal file
View file

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

13
VDS26/VDS26.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

800
VDS26/app.R Normal file
View file

@ -0,0 +1,800 @@
# Präambel ####
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_vds26.R" # liefert: daten_vds26
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo
AKZENT_FARBE = "#8B2635"
VDS26_DISCLAIMER = paste0(
"Dieser Fragebogen ist ein ipsatives Selbstexplorations-Instrument ohne Normwerte oder Cutoffs. ",
"Die Prozentwerte sind ausschliesslich im Vergleich der eigenen Bereiche untereinander zu interpretieren, ",
"nicht als Vergleich mit einer Referenzstichprobe oder als klinisches Urteil. ",
"Die Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal; die Interpretation obliegt der behandelnden Person."
)
VDS26_DISCLAIMER = gsub("fuer", "für", VDS26_DISCLAIMER, fixed = TRUE)
VDS26_DISCLAIMER = gsub("ausschliesslich", "ausschließlich", VDS26_DISCLAIMER, fixed = TRUE)
# Fallback-Klartexte, nur falls das labels-Attribut an einer Rating-Spalte
# fehlen sollte (siehe vds26_rating_klartext). Der Regelfall liest den
# Klartext immer aus den echten Daten, nie aus dieser Konstante.
VDS26_STUFEN_TEXTE = c(
"0 = keine Ressource", "1 = geringe Ressource", "2 = mittlere Ressource",
"3 = große Ressource", "4 = sehr große Ressource"
)
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 ####
# Inhaltlicher Rohwert (0-4) einer Rating-Spalte, IMMER aus dem Klartext im
# labels-Attribut der ORIGINAL-Spalte extrahiert (siehe Projekt-Vorgabe:
# der gespeicherte Zahlencode ist nicht zwingend 0-4).
vds26_rohwert = function(voll_spalte, wert_roh) {
if (is.null(wert_roh) || length(wert_roh) == 0 || is.na(wert_roh[1])) return(NA_real_)
lab = attr(voll_spalte, "labels")
if (is.null(lab)) return(suppressWarnings(as.numeric(wert_roh[1])))
namen = names(lab)
ziffer = as.numeric(sub("^\\s*([0-9]+).*", "\\1", namen))
zuordnung = setNames(ziffer, unname(lab))
unname(zuordnung[as.character(unclass(wert_roh[1]))])
}
# Voller Klartext einer Rating-Antwort (z.B. "3 = große Ressource"), fuer
# Anzeige/Export. Getrennt von vds26_rohwert, da hier der ganze Text
# gebraucht wird, nicht nur die fuehrende Ziffer.
vds26_rating_klartext = function(voll_spalte, wert_roh) {
if (is.null(wert_roh) || length(wert_roh) == 0 || is.na(wert_roh[1])) return(NA_character_)
if (is.null(attr(voll_spalte, "labels"))) {
idx = suppressWarnings(as.integer(round(as.numeric(wert_roh[1]))))
if (!is.na(idx) && idx >= 0 && idx <= 4) return(VDS26_STUFEN_TEXTE[idx + 1])
return(NA_character_)
}
vds26_labels_klartext(voll_spalte, wert_roh)
}
# Freitext-Itemtext aus dem "label"-Attribut der Freitext-Spalte (formr
# haelt den Frageklartext dort vor, nicht in einer eigenen Item-Tabelle).
vds26_item_label = function(spalte) {
lbl = attr(spalte, "label")
if (is.null(lbl) || length(lbl) == 0 || is.na(lbl[1]) || trimws(lbl[1]) == "") return(NA_character_)
trimws(lbl[1])
}
vds26_item_kuerzel = function(item) toupper(sub("^vds26_", "", item))
# Generischer Klartext-Dekoder fuer labelled-Spalten in beide moeglichen
# Richtungen: bei den Rating-Feldern (mc, numerisch codiert) stehen die
# Klartexte in den NAMEN von labels und die Codes in den WERTEN
# ("1"->"0 = keine Ressource"); bei den Rang-Feldern (select_one, chr+lbl)
# ist es umgekehrt - der Rohwert ist bereits der Buchstabencode ("E") und
# die NAMEN von labels sind die Codes, die WERTE die Klartexte
# ("E"->"E Beziehungen zu wichtigen Menschen"). Beide Faelle werden aus
# der echten Datenstruktur heraus erkannt, nicht angenommen.
vds26_labels_klartext = function(spalte_voll, wert_roh) {
if (is.null(wert_roh) || length(wert_roh) == 0 || is.na(wert_roh[1])) return(NA_character_)
lab = attr(spalte_voll, "labels")
wert_chr = trimws(as.character(unclass(wert_roh[1])))
if (is.null(lab)) return(wert_chr)
if (!is.null(names(lab)) && wert_chr %in% names(lab)) {
return(unname(lab[[wert_chr]]))
}
pos = which(as.character(unclass(as.vector(lab))) == wert_chr)
if (length(pos) > 0) return(names(lab)[pos[1]])
NA_character_
}
# Bereichs-Score: Divisor passt sich an die Anzahl beantworteter Items an
# (Nutzerentscheid), damit ein teilweise ausgefuellter Bereich nicht durch
# einen kuenstlich niedrigen Divisor verzerrt wird.
vds26_berechne_bereich = function(treffer, items, daten) {
rohwerte = sapply(items, function(feld) {
voll_spalte = daten[[paste0(feld, "_txt")]]
wert_roh = treffer[[paste0(feld, "_txt")]]
if (is.null(voll_spalte) || is.null(wert_roh)) return(NA_real_)
vds26_rohwert(voll_spalte, wert_roh)
})
n_beantwortet = sum(!is.na(rohwerte))
n_gesamt = length(items)
summe = sum(rohwerte, na.rm = TRUE)
divisor = n_beantwortet * 5
prozent = if (divisor == 0) NA_real_ else (summe / divisor) * 100
list(
rohwerte = rohwerte,
n_beantwortet = n_beantwortet,
n_gesamt = n_gesamt,
summe = summe,
prozent = prozent,
vollstaendig = (n_beantwortet == n_gesamt)
)
}
# Farbschema fuer die 5 Rating-Stufen wie in der Referenzimplementierung
# pg13r/app.R (gruen -> dunkelrot). Zeigt die Antwortintensitaet des
# einzelnen Items, keine Klassifikation/Diagnose des Gesamtinstruments -
# entspricht damit demselben Gebrauch wie in pg13r und vds23.
VDS26_BADGE_FARBEN = c(
"0" = "#4CAF50",
"1" = "#F48FB1",
"2" = "#EF5350",
"3" = "#B71C1C",
"4" = "#4A0000"
)
VDS26_BADGE_TEXT_FARBEN = c(
"0" = "white",
"1" = "#333333",
"2" = "white",
"3" = "white",
"4" = "white"
)
vds26_badge_style = function(rohwert) {
if (is.na(rohwert)) return("background-color:#E0E0E0; color:#555555;")
k = as.character(max(0L, min(4L, as.integer(round(rohwert)))))
paste0("background-color:", VDS26_BADGE_FARBEN[[k]], "; color:", VDS26_BADGE_TEXT_FARBEN[[k]], ";")
}
# Profilgrafik: 19 Bereiche, absteigend sortiert, ohne Cutoff/Klassifikationszonen
# (ipsatives Instrument). Bereiche ohne Angabe stehen separat markiert am Ende
# (unten im geflippten Balkendiagramm), niemals als 0%-Balken verwechselbar.
make_vds26_profil_plot = function(bereich_ergebnisse) {
df = data.frame(
code = sapply(bereich_ergebnisse, function(b) b$code),
label_y = sapply(bereich_ergebnisse, function(b) paste0(b$code, " ", b$name)),
prozent = sapply(bereich_ergebnisse, function(b) b$prozent),
stringsAsFactors = FALSE
)
gueltig = df[!is.na(df$prozent), ]
gueltig = gueltig[order(gueltig$prozent), ]
fehlend = df[is.na(df$prozent), ]
fehlend = fehlend[order(fehlend$code, decreasing = TRUE), ]
levels_reihenfolge = c(fehlend$label_y, gueltig$label_y)
df$label_y = factor(df$label_y, levels = levels_reihenfolge)
df$balken = ifelse(is.na(df$prozent), 0, df$prozent)
ggplot(df, aes(x = label_y, y = balken)) +
geom_col(fill = AKZENT_FARBE, width = 0.65) +
geom_text(
data = subset(df, !is.na(prozent)),
aes(label = paste0(round(prozent), " %")),
hjust = -0.15, size = 3.3, color = "#333333"
) +
geom_text(
data = subset(df, is.na(prozent)),
aes(y = 2, label = "keine Angabe"),
hjust = 0, size = 3.0, color = "#888888", fontface = "italic"
) +
coord_flip(clip = "off") +
scale_y_continuous(limits = c(0, 112), breaks = seq(0, 100, 25)) +
theme_minimal(base_size = 12) +
theme(
axis.title = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor = element_blank(),
plot.margin = margin(t = 5, r = 34, b = 5, l = 5)
)
}
# Datenaufbereitung ####
vds26_bereiche = list(
list(code = "A", name = "Lebensbereich", items = paste0("vds26_a", 1:16)),
list(code = "B", name = "Ziele, Pläne, Wünsche, Träume", items = paste0("vds26_b", 1:4)),
list(code = "C", name = "Phantasien", items = paste0("vds26_c", 1:3)),
list(code = "D", name = "Erinnerungsschatz", items = paste0("vds26_d", 1:3)),
list(code = "E", name = "Beziehungen zu wichtigen Menschen", items = paste0("vds26_e", 1:12)),
list(code = "F", name = "Werte in meinem Leben", items = paste0("vds26_f", 1:3)),
list(code = "G", name = "Spiritualität", items = paste0("vds26_g", 1:3)),
list(code = "H", name = "Genuss Lust", items = paste0("vds26_h", 1:3)),
list(code = "I", name = "Spaß-Aktivitäten", items = paste0("vds26_i", 1:3)),
list(code = "J", name = "Interessen", items = paste0("vds26_j", 1:3)),
list(code = "K", name = "Körper", items = paste0("vds26_k", 1:3)),
list(code = "L", name = "Liebenswürdigkeit", items = paste0("vds26_l", 1:3)),
list(code = "M", name = "Persönlichkeit (Vorlieben, Neigungen, Fähigkeiten)",items = paste0("vds26_m", 1:11)),
list(code = "N", name = "Errungenschaften", items = paste0("vds26_n", 1:3)),
list(code = "O", name = "Bedürfnisse", items = paste0("vds26_o", 1:3)),
list(code = "P", name = "Gemeisterte Belastungen", items = paste0("vds26_p", 1:3)),
list(code = "Q", name = "Gute Gefühle", items = paste0("vds26_q", 1:3)),
list(code = "R", name = "Überzeugungen / Erwartungen (Kognition)",
items = c(paste0("vds26_r_ueb_", 1:3), paste0("vds26_r_erw_", 1:3))),
list(code = "S", name = "Motivation", items = paste0("vds26_s", 1:3))
)
# Kontrollsumme 91 Items. Bei Abweichung sofort abbrechen, statt still mit
# einer fehlerhaften Struktur weiterzurechnen (Copy-Paste-Fehler-Schutz).
.vds26_kontrollsumme = sum(sapply(vds26_bereiche, function(b) length(b$items)))
if (.vds26_kontrollsumme != 91) {
stop(
"VDS26: Kontrollsumme der Bereichs-Item-Zuordnung ist ", .vds26_kontrollsumme,
", erwartet 91. Bitte 'vds26_bereiche' prüfen (Copy-Paste-Fehler?)."
)
}
vds26_rang_felder = paste0("vds26_rang_", letters[1:10])
vds26_rang_labels = paste("Rang", 1:10)
# 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; }
.hinweis-ipsativ {
font-size: 0.85em; color: #777; font-style: italic;
margin-bottom: 14px; border-bottom: 1px dashed #ddd; padding-bottom: 10px;
}
.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: 70px; flex-shrink: 0; font-size: 0.85em; }
.item-text-block { flex: 1; }
.item-text { color: #333; font-size: 0.92em; }
.item-freitext-inline { color: #8B2635; font-weight: 600; }
.stufe-badge {
border-radius: 4px; padding: 2px 9px; font-weight: 700;
font-size: 0.8em; white-space: nowrap; display: inline-block; flex-shrink: 0;
}
.rang-tabelle { width: 100%; border-collapse: collapse; }
.rang-tabelle td, .rang-tabelle th {
padding: 6px 10px; border-bottom: 1px solid #F0F0F0; text-align: left; font-size: 0.93em;
}
.rang-tabelle th { color: #8B2635; font-weight: 700; }
.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("VDS26 Ressourcenanalyse"),
tags$p("19 Bereiche, ipsatives Selbstexplorations-Arbeitsblatt, 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_vds26_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_freitext = fp_text(font.size = 11, bold = TRUE, color = AKZENT_FARBE)
fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
# 1. Titel + Metadaten
doc = body_add_fpar(doc, fpar(ftext("VDS26 Ressourcenanalyse", 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$mehrfach_warnung)) {
doc = body_add_fpar(doc, fpar(
ftext(erg$mehrfach_warnung, fp_text(font.size = 10, italic = TRUE, color = "#555555"))
))
}
# 2. Hinweis direkt nach dem Titel (nicht erst am Ende)
doc = body_add_fpar(doc, fpar(ftext(VDS26_DISCLAIMER, fp_disclaimer)))
doc = body_add_par(doc, "", style = "Normal")
# 3. Profil-Tabelle, absteigend, mit Vollstaendigkeitshinweis
doc = body_add_fpar(doc, fpar(ftext("Profil der 19 Bereiche", fp_abschnitt)))
reihenfolge = order(sapply(erg$bereiche, function(b) if (is.na(b$prozent)) -1 else b$prozent),
decreasing = TRUE)
profil_df = data.frame(
Bereich = sapply(erg$bereiche[reihenfolge], function(b) paste0(b$code, " ", b$name)),
"R (%)" = sapply(erg$bereiche[reihenfolge], function(b)
if (is.na(b$prozent)) "keine Angabe" else paste0(round(b$prozent), " %")),
Hinweis = sapply(erg$bereiche[reihenfolge], function(b)
if (is.na(b$prozent)) "" else if (!b$vollstaendig)
paste0("nur ", b$n_beantwortet, " von ", b$n_gesamt, " Items beantwortet") else ""),
check.names = FALSE, stringsAsFactors = FALSE
)
doc = body_add_table(doc, profil_df)
doc = body_add_par(doc, "", style = "Normal")
# 4. Je Bereich ein Abschnitt mit allen Items
for (b in erg$bereiche) {
titel_text = if (b$n_beantwortet == 0) {
paste0("Bereich ", b$code, " ", b$name, " — keine Angabe")
} else if (!b$vollstaendig) {
paste0("Bereich ", b$code, " ", b$name, " — R(", b$code, ") = ",
round(b$prozent), " % (nur ", b$n_beantwortet, " von ", b$n_gesamt, " Items beantwortet)")
} else {
paste0("Bereich ", b$code, " ", b$name, " — R(", b$code, ") = ", round(b$prozent), " %")
}
doc = body_add_fpar(doc, fpar(ftext(titel_text, fp_abschnitt)))
for (r in seq_len(nrow(b$item_tabelle))) {
zeile = b$item_tabelle[r, ]
itemtext = if (is.na(zeile$itemtext)) paste0("Item ", zeile$kuerzel) else zeile$itemtext
badge_key = if (is.na(zeile$rohwert)) NA_character_ else
as.character(max(0L, min(4L, as.integer(round(zeile$rohwert)))))
if (is.na(badge_key)) {
fp_badge = fp_text(color = "#555555", bold = TRUE, shading.color = "#E0E0E0", font.size = 10)
badge_txt = "keine Angabe"
} else {
fp_badge = fp_text(
color = VDS26_BADGE_TEXT_FARBEN[[badge_key]], bold = TRUE,
shading.color = VDS26_BADGE_FARBEN[[badge_key]], font.size = 10
)
badge_txt = if (is.na(zeile$rating_klartext)) badge_key else zeile$rating_klartext
}
doc = body_add_fpar(doc, fpar(
ftext(paste0(zeile$kuerzel, ". ", itemtext, " "), fp_normal),
if (!is.na(zeile$freitext)) ftext(paste0(zeile$freitext, " "), fp_freitext) else ftext("", fp_normal),
ftext(paste0(" ", badge_txt, " "), fp_badge)
))
}
doc = body_add_par(doc, "", style = "Normal")
}
# 5. Rang-Modul
doc = body_add_fpar(doc, fpar(ftext("Rang-Modul", fp_abschnitt)))
if (!is.null(erg$rang_duplikat_warnung)) {
doc = body_add_fpar(doc, fpar(
ftext(erg$rang_duplikat_warnung, fp_text(font.size = 10, italic = TRUE, color = "#BF360C"))
))
}
rang_df = data.frame(
Rangplatz = paste0("Rang ", seq_len(10)),
Bereich = ifelse(is.na(erg$rang_tabelle$bereichsname), "nicht ausgefüllt", erg$rang_tabelle$bereichsname),
stringsAsFactors = FALSE
)
doc = body_add_table(doc, rang_df)
doc = body_add_par(doc, "", style = "Normal")
# 6. Disclaimer als letzter Absatz
doc = body_add_fpar(doc, fpar(ftext(VDS26_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 = 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)))
}
# Schritt 1: Download-Skript sourcen
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))
# Schritt 2: pseudonyme.db suchen (bis zu 5 Ebenen ueber dem Pseudonym-Skript)
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"))
# Schritt 3: Pseudonym-Skript sourcen (relativer DB-Zugriff, daher setwd + on.exit)
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_vds26", envir = .GlobalEnv) || !exists("pseudo", envir = .GlobalEnv)) {
return(list(typ = "daten_fehlen"))
}
daten = get("daten_vds26", 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_vds26' gefunden. ",
"Bitte Abschnitt 'Offene Verifikation' (Session-ID-Spaltenname) pruefen."
)))
}
# Schritt 4: Chiffre-Rueckaufloesung, falls nur Pseudonym eingegeben wurde
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]))
}
# Schritt 5: Chiffre -> moegliche Pseudonyme (Session-IDs)
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)
# Schritt 6: passende Datensaetze in daten_vds26 finden
treffer_daten = daten[daten$session %in% alle_session_ids, ]
if (nrow(treffer_daten) == 0) return(list(typ = "keine_daten", chiffre = chiffre))
mehrfach_warnung = NULL
if (nrow(treffer_daten) > 1) {
n = nrow(treffer_daten)
if ("created" %in% names(treffer_daten)) {
treffer_daten = treffer_daten[order(treffer_daten$created, 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]
ausfuelldatum = tryCatch({
if ("ausfuelldatum" %in% names(zeile) && !is.na(zeile[["ausfuelldatum"]][1]) &&
trimws(as.character(zeile[["ausfuelldatum"]][1])) != "") {
as.character(zeile[["ausfuelldatum"]][1])
} else if ("created" %in% names(zeile)) {
format(as.POSIXct(zeile[["created"]][1]), "%d.%m.%Y")
} else {
format(Sys.Date(), "%d.%m.%Y")
}
}, error = function(e) format(Sys.Date(), "%d.%m.%Y"))
# Schritt 7: Auswertung je Bereich
liste_bereiche = lapply(vds26_bereiche, function(b) {
berechnung = vds26_berechne_bereich(zeile, b$items, daten)
item_tabelle = do.call(rbind, lapply(b$items, function(feld) {
spalte_frei = daten[[feld]]
wert_frei = if (feld %in% names(zeile)) zeile[[feld]][1] else NA
freitext = if (!is.null(wert_frei) && !is.na(wert_frei) &&
trimws(as.character(wert_frei)) != "") {
trimws(as.character(wert_frei))
} else NA_character_
spalte_txt = daten[[paste0(feld, "_txt")]]
wert_txt = if (paste0(feld, "_txt") %in% names(zeile)) zeile[[paste0(feld, "_txt")]][1] else NA
data.frame(
kuerzel = vds26_item_kuerzel(feld),
itemtext = if (!is.null(spalte_frei)) vds26_item_label(spalte_frei) else NA_character_,
freitext = freitext,
rating_klartext = if (!is.null(spalte_txt)) vds26_rating_klartext(spalte_txt, wert_txt) else NA_character_,
rohwert = if (!is.null(spalte_txt)) vds26_rohwert(spalte_txt, wert_txt) else NA_real_,
stringsAsFactors = FALSE
)
}))
c(list(code = b$code, name = b$name, item_tabelle = item_tabelle), berechnung)
})
# Rang-Modul: 10 Rangplaetze -> Bereichsbuchstabe -> Bereichsname
rang_buchstaben = sapply(vds26_rang_felder, function(feld) {
spalte_voll = daten[[feld]]
wert_roh = if (feld %in% names(zeile)) zeile[[feld]][1] else NA
if (is.null(spalte_voll) || is.null(wert_roh)) return(NA_character_)
klartext = vds26_labels_klartext(spalte_voll, wert_roh)
if (is.na(klartext)) return(NA_character_)
buchstabe = sub("^\\s*([A-S]).*", "\\1", trimws(klartext))
if (nchar(buchstabe) == 1) buchstabe else NA_character_
})
rang_bereichsnamen = sapply(rang_buchstaben, function(buchstabe) {
if (is.na(buchstabe)) return(NA_character_)
treffer_b = Filter(function(b) b$code == buchstabe, vds26_bereiche)
if (length(treffer_b) == 0) return(NA_character_)
paste0(treffer_b[[1]]$code, " ", treffer_b[[1]]$name)
})
rang_tabelle = data.frame(
rang = seq_len(10),
buchstabe = unname(rang_buchstaben),
bereichsname = unname(rang_bereichsnamen),
stringsAsFactors = FALSE
)
vorhandene_buchstaben = rang_tabelle$buchstabe[!is.na(rang_tabelle$buchstabe)]
rang_duplikat_warnung = NULL
if (any(duplicated(vorhandene_buchstaben))) {
dupl = unique(vorhandene_buchstaben[duplicated(vorhandene_buchstaben)])
rang_duplikat_warnung = paste0(
"Bereich(e) ", paste(dupl, collapse = ", "),
" wurde(n) auf mehreren Rangplätzen genannt."
)
}
list(
typ = "erfolg",
chiffre = chiffre,
ausfuelldatum = ausfuelldatum,
treffer = zeile,
bereiche = liste_bereiche,
mehrfach_warnung = mehrfach_warnung,
rang_tabelle = rang_tabelle,
rang_duplikat_warnung = rang_duplikat_warnung
)
})
vds26_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_vds26' oder 'pseudo'.",
"chiffre_nicht_gefunden" = paste0("Chiffre '", d$chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden."),
"keine_daten" = paste0("Kein VDS26-Datensatz für Chiffre '", d$chiffre, "' gefunden."),
"Unbekannter Fehler."
)
}
output$fehler_ui = renderUI({
req(input$btn_suchen)
d = ergebnis()
if (d$typ != "erfolg") div(class = "alert-fehler", vds26_fehlermeldung(d))
})
output$warnung_ui = renderUI({
req(input$btn_suchen)
d = ergebnis()
if (d$typ != "erfolg") return(NULL)
tagList(
if (!is.null(d$mehrfach_warnung)) div(class = "alert-warnung", d$mehrfach_warnung),
if (!is.null(d$rang_duplikat_warnung)) div(class = "alert-warnung", d$rang_duplikat_warnung)
)
})
output$ergebnis_ui = renderUI({
req(input$btn_suchen)
d = ergebnis()
if (d$typ != "erfolg") return(NULL)
bereich_karten = lapply(d$bereiche, function(b) {
titel_text = if (b$n_beantwortet == 0) {
paste0("Bereich ", b$code, " ", b$name, " — keine Angabe")
} else if (!b$vollstaendig) {
paste0("Bereich ", b$code, " ", b$name, " — R(", b$code, ") = ",
round(b$prozent), " % (nur ", b$n_beantwortet, " von ", b$n_gesamt, " Items beantwortet)")
} else {
paste0("Bereich ", b$code, " ", b$name, " — R(", b$code, ") = ", round(b$prozent), " %")
}
items_ui = lapply(seq_len(nrow(b$item_tabelle)), function(r) {
zeile = b$item_tabelle[r, ]
div(class = "item-zeile",
div(class = "item-nr", zeile$kuerzel),
div(class = "item-text-block",
div(class = "item-text",
if (is.na(zeile$itemtext)) paste0("Item ", zeile$kuerzel) else zeile$itemtext,
if (!is.na(zeile$freitext)) tags$span(class = "item-freitext-inline", paste0(" ", zeile$freitext))
)
),
span(class = "stufe-badge",
style = vds26_badge_style(zeile$rohwert),
if (is.na(zeile$rating_klartext)) "keine Angabe" else zeile$rating_klartext)
)
})
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", titel_text),
div(items_ui)
)
})
rang_zeilen = lapply(seq_len(10), function(r) {
zeile = d$rang_tabelle[r, ]
tags$tr(
tags$td(paste0("Rang ", zeile$rang)),
tags$td(if (is.na(zeile$bereichsname)) "nicht ausgefüllt" else zeile$bereichsname)
)
})
rang_karte = div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Rang-Modul"),
tags$table(class = "rang-tabelle",
tags$thead(tags$tr(tags$th("Rangplatz"), tags$th("Bereich"))),
tags$tbody(rang_zeilen)
)
)
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 = "hinweis-ipsativ",
"Ipsatives Instrument: Die Prozentwerte sind nur im Vergleich der eigenen Bereiche untereinander interpretierbar, nicht gegen eine Referenzstichprobe."),
plotOutput("profil_plot", height = "560px")
),
bereich_karten,
rang_karte,
div(class = "disclaimer-zeile", VDS26_DISCLAIMER)
)
})
output$profil_plot = renderPlot({
req(input$btn_suchen)
d = ergebnis()
req(d$typ == "erfolg")
make_vds26_profil_plot(d$bereiche)
}, 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, "%d.%m.%Y"), "%Y%m%d"),
error = function(e) format(Sys.Date(), "%Y%m%d"))
} else {
format(Sys.Date(), "%Y%m%d")
}
paste0("VDS26_", 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_vds26_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
VDS26/renv.lock Normal file

File diff suppressed because it is too large Load diff

17
VDS26/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_vds26.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()")