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
VDS34/.RData Normal file
View file

Binary file not shown.

1
VDS34/.Rprofile Normal file
View file

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

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

842
VDS34/app.R Normal file
View file

@ -0,0 +1,842 @@
# Präambel ####
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_vds34.R" # liefert: daten_vds34
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo
AKZENT_FARBE = "#8B2635"
VDS34_DISCLAIMER = paste0(
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ",
"Das Instrument enthaelt keine Normwerte oder Cutoffs; alle Angaben sind rein deskriptiv."
)
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.
vds34_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
# (vor Subsetting), mit haven::as_factor()- und Rohtext-Fallback, falls kein
# passendes labels-Attribut vorliegt. Nie ein hartkodierter Zahlenwert.
vds34_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 = vds34_match_in_labels(labs, roh)
if (!is.null(treffer)) return(trimws(as.character(treffer$text)))
}
txt = tryCatch(as.character(haven::as_factor(wert))[1], error = function(e) NA_character_)
if (!is.na(txt) && nchar(trimws(txt)) > 0) return(trimws(txt))
roh_chr = trimws(as.character(roh))
if (nchar(roh_chr) > 0) return(roh_chr)
NA_character_
}
# Staerke eines Gebots/Verbots (0-3): NIEMALS aus dem rohen numerischen Wert
# abgeleitet (Choice-Index und Inhaltswert stimmen bei 'mc' mit reinen
# Ziffern-Choices nicht zwangslaeufig 1:1 ueberein), sondern aus dem
# Label-Text - der Label-Text selbst ist bereits die Ziffer 0-3.
vds34_staerke_wert = function(original_spalte, wert, feldname) {
text = vds34_resolve_label(original_spalte, wert)
if (is.na(text)) return(NA_integer_)
ziffer = suppressWarnings(as.integer(trimws(text)))
if (!is.na(ziffer) && ziffer >= 0 && ziffer <= 3) return(ziffer)
m = regmatches(text, regexpr("[0-3]", text))
if (length(m) > 0 && nchar(m) > 0) return(as.integer(m))
NA_integer_
}
# "trifft zu" wird ueber den Label-Text entschieden, nicht ueber den
# Rohwert (dbl+lbl-Export, Zuordnung 'trifft zu' = 1 darf nicht hartkodiert
# werden).
vds34_trifft_zu = function(original_spalte, wert) {
text = vds34_resolve_label(original_spalte, wert)
if (is.na(text)) return(NA)
identical(tolower(trimws(text)), "trifft zu")
}
# Freitextfeld lesen, leere/NA-Werte einheitlich als NA_character_.
vds34_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 von vds34_zsf_1_wahl / vds34_zsf_2_wahl (select_one umgang20):
# nicht verifiziert, ob formr den Choice-NAMEN ("u7") oder das Choice-LABEL
# (Volltext) exportiert. Deshalb defensiv: zuerst Codeabgleich gegen die
# u1-u20-Lookup-Tabelle, dann labels-Attribut in beide Richtungen, dann
# direkter Volltextabgleich, sonst Rohwert unveraendert zurueckgeben (nie
# ein Fehler).
vds34_resolve_umgang_wahl = function(original_spalte, wert, lookup) {
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_)
treffer_code = lookup$text[match(tolower(roh), tolower(lookup$code))]
if (length(treffer_code) > 0 && !is.na(treffer_code)) return(treffer_code)
labs = attr(original_spalte, "labels")
if (!is.null(labs) && length(labs) > 0) {
treffer = vds34_match_in_labels(labs, unclass(wert)[1])
if (!is.null(treffer)) {
kandidat = trimws(as.character(treffer$text))
treffer_code2 = lookup$text[match(tolower(kandidat), tolower(lookup$code))]
if (length(treffer_code2) > 0 && !is.na(treffer_code2)) return(treffer_code2)
treffer_text = lookup$text[match(tolower(kandidat), tolower(lookup$text))]
if (length(treffer_text) > 0 && !is.na(treffer_text)) return(treffer_text)
if (nchar(kandidat) > 0) return(kandidat)
}
}
treffer_text2 = lookup$text[match(tolower(roh), tolower(lookup$text))]
if (length(treffer_text2) > 0 && !is.na(treffer_text2)) return(treffer_text2)
roh
}
# Liest die 10 Gebot- bzw. 10 Verbot-Zeilen (Text + Staerke) eines Teils.
vds34_lese_liste = function(daten, zeile, praefix) {
lapply(1:10, function(i) {
nr = sprintf("%02d", i)
feld_text = paste0("vds34_", praefix, "_", nr, "_text")
feld_staerke = paste0("vds34_", praefix, "_", nr, "_staerke")
if (!(feld_text %in% names(daten))) stop("Erwartetes Feld '", feld_text, "' nicht in 'daten_vds34' gefunden.")
if (!(feld_staerke %in% names(daten))) stop("Erwartetes Feld '", feld_staerke, "' nicht in 'daten_vds34' gefunden.")
list(
nr = i,
text = vds34_text_feld(zeile, feld_text),
staerke = vds34_staerke_wert(daten[[feld_staerke]], zeile[[feld_staerke]], feld_staerke)
)
})
}
# Liest die 20 "trifft zu"/"trifft nicht zu"-Ankreuzfelder von Teil c.
vds34_lese_umgang = function(daten, zeile) {
lapply(1:20, function(i) {
nr = sprintf("%02d", i)
feld = paste0("vds34_umgang_", nr)
if (!(feld %in% names(daten))) stop("Erwartetes Feld '", feld, "' nicht in 'daten_vds34' gefunden.")
list(nr = i, trifft_zu = vds34_trifft_zu(daten[[feld]], zeile[[feld]]))
})
}
# Formeln aus der Auswertungsanleitung (Abschnitt 6 der Spezifikation):
# Mittelwert_Gebote / Mittelwert_Verbote = Summe der 10 Staerken / 10 (0-3)
vds34_mittelwert_10 = function(staerken) sum(staerken, na.rm = TRUE) / 10
# Normorientierung_insgesamt = (Mittelwert_Gebote + Mittelwert_Verbote) / 2 (0-3)
vds34_normorientierung_insgesamt = function(mw_gebote, mw_verbote) (mw_gebote + mw_verbote) / 2
# Anti_norm = Anzahl "trifft zu" (Items 1-7) / 7 (0-1)
# Pro_norm = Anzahl "trifft zu" (Items 8-20) / 13 (0-1)
# Bewusst NICHT auf die 0-3-Skala umgerechnet: die 20 Items sind binaere
# Ankreuzfelder, ihr rechnerisch korrekter Wertebereich ist 0-1. Die
# gedruckte Original-Auswertungsdatei zeigt hier faelschlich dieselbe
# 0-3-Profilskala wie fuer a)/b)/c) ab (dokumentierte Anomalie der Quelle,
# Nutzerentscheidung: 0-1-Skala beibehalten statt der Druckvorlage folgen).
vds34_anteil_trifft_zu = function(trifft_zu_vec, n) sum(trifft_zu_vec, na.rm = TRUE) / n
# Normorientierung_gesamt_Umgang = Pro_norm - Anti_norm (kann negativ sein)
vds34_normorientierung_gesamt_umgang = function(pro_norm, anti_norm) pro_norm - anti_norm
make_vds34_mittelwerte_plot = function(mw_gebote, mw_verbote, normorientierung) {
df = data.frame(
kennzahl = c("Mittelwert Gebote", "Mittelwert Verbote", "Normorientierung insgesamt"),
wert = c(mw_gebote, mw_verbote, normorientierung),
stringsAsFactors = FALSE
)
df$kennzahl = factor(df$kennzahl, levels = rev(df$kennzahl))
ggplot(df, aes(x = kennzahl, y = wert)) +
geom_col(fill = AKZENT_FARBE, width = 0.55) +
geom_text(aes(label = sprintf("%.2f", wert)), hjust = -0.25, size = 3.8, color = "#333333") +
scale_y_continuous(limits = c(0, 3.4), breaks = 0:3) +
coord_flip() +
theme_minimal(base_size = 12) +
theme(
axis.title = element_blank(),
panel.grid.minor = element_blank(),
panel.grid.major.y = element_blank(),
plot.margin = margin(t = 5, r = 25, b = 5, l = 5)
)
}
make_vds34_umgang_plot = function(anti_norm, pro_norm, differenz) {
df = data.frame(
kennzahl = c("Anti-norm", "Pro-norm", "Normorientierung gesamt (Differenz)"),
wert = c(anti_norm, pro_norm, differenz),
stringsAsFactors = FALSE
)
df$kennzahl = factor(df$kennzahl, levels = rev(df$kennzahl))
ggplot(df, aes(x = kennzahl, y = wert)) +
geom_col(fill = AKZENT_FARBE, width = 0.55) +
geom_text(aes(label = sprintf("%.2f", wert)),
hjust = ifelse(df$wert >= 0, -0.25, 1.25), size = 3.8, color = "#333333") +
geom_hline(yintercept = 0, color = "#999999", linewidth = 0.4) +
scale_y_continuous(limits = c(-1.15, 1.15), breaks = seq(-1, 1, 0.5)) +
coord_flip() +
theme_minimal(base_size = 12) +
theme(
axis.title = element_blank(),
panel.grid.minor = element_blank(),
panel.grid.major.y = element_blank(),
plot.margin = margin(t = 5, r = 25, b = 5, l = 5)
)
}
# Datenaufbereitung ####
VDS34_UMGANG_TEXTE = c(
"Gebote/Verbote muessen andere einhalten, mir selbst gegenueber bin ich da nicht so streng",
"Ich brauche es, dass jemand auf mich aufpasst, dass ich Gebote/Verbote einhalte",
"Gebote/Verbote halte ich dann ein, wenn mich jemand beim Uebertreten erwischen koennte.",
"Gebote/Verbote sind mir oft bewusst und ich halte sie auch fuer richtig, aber ich orientiere mein Verhalten nicht oder kaum an ihnen und dies ist fuer mich stimmig (Ich bin halt so)",
"Gebote/Verbote halte ich nach dem Prinzip \"Dienst nach Vorschrift\" ein, d.h. nur in dem Ausmass wie es absolut notwendig ist, damit man mir keinen Vorwurf machen kann.",
"Gegen Gebote/Verbote lehne ich mich auf, da sie meine persoenliche Freiheit einschraenken.",
"Gebote/Verbote werden mir erst bewusst, nachdem ich dagegen verstossen habe. Dann habe ich Schuld- oder Schamgefuehle. Diese halten mich aber nicht davon ab, beim naechsten Mal wieder dagegen zu verstossen.",
"Gebote/Verbote halte ich ganz bewusst ein, spaeter passiert mir dann oefter mal ein Missgeschick, das dazu fuehrt, dass ich dem Gebot/Verbot doch nicht Folge leisten kann.",
"Wenn meine Schuldgefuehle mich nicht so plagen wuerden, wuerde ich wohl nicht so sehr Gebote und Verbote einhalten.",
"Gebote/Verbote sind mir oft bewusst und ich halte sie auch fuer richtig, aber ich orientiere mein Verhalten nicht oder kaum an ihnen und dies ist fuer mich sehr unangenehm (Schuldgefuehl, Schamgefuehl, Selbstwert sinkt)",
"Gebote/Verbote stuerzen mich oft in Konflikte, da ich manche Situationen besser bewaeltigen koennte, wenn ich nicht an ein Gebot/Verbot gebunden waere",
"Wenn es mir gelang, ein Gebot einzuhalten, empfinde ich Genugtuung und Wohlbefinden.",
"Gebote/Verbote sind mir oft bewusst und ich achte so oft es geht darauf, mich daran zu halten und dies gelingt mir fast immer.",
"Ich habe die wichtigen Gebote und Verbote so verinnerlicht, dass ich mich auch ohne Aufpasser daran halten kann.",
"Gebote/Verbote sind mir so wichtig, dass ich wachsam darauf achte, dass auch die anderen Menschen sie einhalten.",
"Ich halte mich aus Ueberzeugung an Gebote und Verbote. Da muessen mich nicht erst meine Schuldgefuehle von einem Verstoss abhalten.",
"Gebote/Verbote sind mir nicht oft bewusst, aber ich orientiere mein Verhalten automatisch an ihnen.",
"Gebote/Verbote halte ich ein, weil ich moechte, dass die mir wichtigen Menschen mich moegen und ich den Verlust deren Zuneigung nicht riskieren moechte.",
"Gebote/Verbote halte ich ein, weil ich die Anerkennung und Wertschaetzung anderer Menschen nicht verlieren moechte.",
"Gebote/Verbote helfen mir, indem sie mir Orientierung geben und mich vor Verhaltensweisen schuetzen, die anderen Menschen und nicht zuletzt auch mir schaden wuerden."
)
# Kontrollsumme: 20 Umgang-Items (Abschnitt 4.3 der Spezifikation).
if (length(VDS34_UMGANG_TEXTE) != 20) {
stop("VDS34: Item-Kontrollsumme stimmt nicht (", length(VDS34_UMGANG_TEXTE), " statt 20).")
}
umgang_items = data.frame(
nr = 1:20,
feldname = sprintf("vds34_umgang_%02d", 1:20),
text = VDS34_UMGANG_TEXTE,
gruppe = c(rep("anti-norm", 7), rep("pro-norm", 13)),
stringsAsFactors = FALSE
)
umgang20_lookup = data.frame(
code = paste0("u", 1:20),
text = VDS34_UMGANG_TEXTE,
stringsAsFactors = FALSE
)
# UI ####
app_css = "
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; }
.app-header {
background: #8B2635; color: white; padding: 18px 24px 14px;
margin-bottom: 20px; border-radius: 0 0 6px 6px;
}
.app-header h2 { margin: 0; font-size: 1.5rem; font-weight: 600; }
.app-header p { margin: 4px 0 0; opacity: 0.85; font-size: 0.9rem; }
.input-panel {
background: white; border-radius: 6px; padding: 16px 20px;
margin-bottom: 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
display: flex; align-items: flex-end; gap: 12px; flex-wrap: wrap;
}
.input-panel .form-group { margin-bottom: 0; }
.input-panel label { font-weight: 600; color: #333; }
.btn-laden {
background: #8B2635 !important; color: white !important;
border: none !important; border-radius: 4px !important;
padding: 8px 20px !important; font-weight: 600 !important; 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; }
.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;
background: #ECEFF1; color: #37474F;
}
.zutreffen-badge {
border-radius: 4px; padding: 2px 9px; font-weight: 700;
font-size: 0.82em; white-space: nowrap; display: inline-block; flex-shrink: 0;
border: 1px solid #8B2635;
}
.zutreffen-ja { background: #8B2635; color: white; }
.zutreffen-nein { background: white; color: #8B2635; }
.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;
}
.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("VDS34 – Innere Normen"),
tags$p("Prof. Dr. Dr. Serge Sulz | rein deskriptives, idiografisches Instrument ohne Cutoff und ohne Normtabelle")
),
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_vds34_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("VDS34 – Innere Normen", 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"))
))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Teil a) – Zehn Gebote", fp_abschnitt)))
for (g in erg$gebote) {
text_satz = if (is.na(g$text)) "Du sollst … (keine Angabe)" else paste0("Du sollst ", g$text)
staerke_txt = if (is.na(g$staerke)) "k. A." else paste0(g$staerke, " / 3")
doc = body_add_fpar(doc, fpar(
ftext(paste0(g$nr, ". ", text_satz, " "), fp_normal),
ftext(paste0("Stärke: ", staerke_txt), fp_klein)
))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Teil b) – Zehn Verbote", fp_abschnitt)))
for (v in erg$verbote) {
text_satz = if (is.na(v$text)) "Du sollst NICHT … (keine Angabe)" else paste0("Du sollst NICHT ", v$text)
staerke_txt = if (is.na(v$staerke)) "k. A." else paste0(v$staerke, " / 3")
doc = body_add_fpar(doc, fpar(
ftext(paste0(v$nr, ". ", text_satz, " "), fp_normal),
ftext(paste0("Stärke: ", staerke_txt), fp_klein)
))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Mittelwerte (Skala 0–3)", fp_abschnitt)))
doc = body_add_fpar(doc, fpar(
ftext("Mittelwert Gebote: ", fp_label), ftext(sprintf("%.2f", erg$mw_gebote), fp_normal),
ftext(" Mittelwert Verbote: ", fp_label), ftext(sprintf("%.2f", erg$mw_verbote), fp_normal),
ftext(" Normorientierung insgesamt: ", fp_label), ftext(sprintf("%.2f", erg$normorientierung_insgesamt), fp_normal)
))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Bezugsperson / Norminstanz", fp_abschnitt)))
doc = body_add_fpar(doc, fpar(
ftext(if (is.na(erg$bezugsperson)) "k. A." else erg$bezugsperson, fp_normal)
))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Teil c) – Umgang mit Normen", fp_abschnitt)))
doc = body_add_fpar(doc, fpar(ftext("anti-norm (Items 1–7)", fp_text(bold = TRUE, font.size = 11, color = "#333333"))))
for (it in erg$umgang[erg$umgang_gruppe == "anti-norm"]) {
doc = body_add_fpar(doc, fpar(
ftext(paste0(it$nr, ". ", it$text, " "), fp_normal),
ftext(if (isTRUE(it$trifft_zu)) "trifft zu" else if (isFALSE(it$trifft_zu)) "trifft nicht zu" else "k. A.", fp_klein)
))
}
doc = body_add_fpar(doc, fpar(ftext("pro-norm (Items 8–20)", fp_text(bold = TRUE, font.size = 11, color = "#333333"))))
for (it in erg$umgang[erg$umgang_gruppe == "pro-norm"]) {
doc = body_add_fpar(doc, fpar(
ftext(paste0(it$nr, ". ", it$text, " "), fp_normal),
ftext(if (isTRUE(it$trifft_zu)) "trifft zu" else if (isFALSE(it$trifft_zu)) "trifft nicht zu" else "k. A.", fp_klein)
))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(
ftext("Anti-norm: ", fp_label), ftext(sprintf("%.2f", erg$anti_norm), fp_normal),
ftext(" Pro-norm: ", fp_label), ftext(sprintf("%.2f", erg$pro_norm), fp_normal),
ftext(" Normorientierung gesamt Umgang: ", fp_label), ftext(sprintf("%.2f", erg$normorientierung_gesamt_umgang), fp_normal)
))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Häufigste Umgangsarten (Zusammenfassung)", fp_abschnitt)))
doc = body_add_fpar(doc, fpar(
ftext("1. ", fp_label), ftext(if (is.na(erg$haeufigste_1)) "k. A." else erg$haeufigste_1, fp_normal)
))
doc = body_add_fpar(doc, fpar(
ftext("2. ", fp_label), ftext(if (is.na(erg$haeufigste_2)) "k. A." else erg$haeufigste_2, fp_normal)
))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(VDS34_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_vds34", envir = .GlobalEnv) || !exists("pseudo", envir = .GlobalEnv)) {
return(list(typ = "daten_fehlen"))
}
daten = get("daten_vds34", 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_vds34' gefunden. ",
"Bitte Session-ID-Spaltenname vor Produktiveinsatz prüfen."
)))
}
# Chiffre-Rueckauflösung aus dem Pseudonym, falls eingegeben.
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 -
# 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]
format(as.POSIXct(as.character(roh)), "%d.%m.%Y")
} else {
format(Sys.Date(), "%d.%m.%Y")
}
}, error = function(e) format(Sys.Date(), "%d.%m.%Y"))
# Teil a/b: 10 Gebote + 10 Verbote (Text + Staerke 0-3).
roh_gebote = tryCatch(list(ok = TRUE, items = vds34_lese_liste(daten, zeile, "gebot")),
error = function(e) list(ok = FALSE, msg = e$message))
if (!roh_gebote$ok) return(list(typ = "extraktion_fehler", meldung = roh_gebote$msg))
roh_verbote = tryCatch(list(ok = TRUE, items = vds34_lese_liste(daten, zeile, "verbot")),
error = function(e) list(ok = FALSE, msg = e$message))
if (!roh_verbote$ok) return(list(typ = "extraktion_fehler", meldung = roh_verbote$msg))
staerken_gebote = sapply(roh_gebote$items, function(x) x$staerke)
staerken_verbote = sapply(roh_verbote$items, function(x) x$staerke)
mw_gebote = vds34_mittelwert_10(staerken_gebote)
mw_verbote = vds34_mittelwert_10(staerken_verbote)
normorientierung_insgesamt = vds34_normorientierung_insgesamt(mw_gebote, mw_verbote)
bezugsperson = vds34_text_feld(zeile, "vds34_schuld_text")
# Teil c: 20 "trifft zu"/"trifft nicht zu"-Items.
roh_umgang = tryCatch(list(ok = TRUE, items = vds34_lese_umgang(daten, zeile)),
error = function(e) list(ok = FALSE, msg = e$message))
if (!roh_umgang$ok) return(list(typ = "extraktion_fehler", meldung = roh_umgang$msg))
trifft_zu_vec = sapply(roh_umgang$items, function(x) isTRUE(x$trifft_zu))
anti_norm = vds34_anteil_trifft_zu(trifft_zu_vec[umgang_items$gruppe == "anti-norm"], 7)
pro_norm = vds34_anteil_trifft_zu(trifft_zu_vec[umgang_items$gruppe == "pro-norm"], 13)
normorientierung_gesamt_umgang = vds34_normorientierung_gesamt_umgang(pro_norm, anti_norm)
umgang_ergebnis = lapply(1:20, function(i) {
list(nr = i, text = umgang_items$text[i], trifft_zu = roh_umgang$items[[i]]$trifft_zu)
})
# Zusammenfassung: 2 häufigste/charakteristischste Umgangsarten.
feld_zsf1 = "vds34_zsf_1_wahl"
feld_zsf2 = "vds34_zsf_2_wahl"
haeufigste_1 = if (feld_zsf1 %in% names(daten))
vds34_resolve_umgang_wahl(daten[[feld_zsf1]], zeile[[feld_zsf1]], umgang20_lookup) else NA_character_
haeufigste_2 = if (feld_zsf2 %in% names(daten))
vds34_resolve_umgang_wahl(daten[[feld_zsf2]], zeile[[feld_zsf2]], umgang20_lookup) else NA_character_
list(
typ = "erfolg",
chiffre = chiffre,
ausfuelldatum = ausfuelldatum,
mehrfach_warnung = mehrfach_warnung,
gebote = roh_gebote$items,
verbote = roh_verbote$items,
mw_gebote = mw_gebote,
mw_verbote = mw_verbote,
normorientierung_insgesamt = normorientierung_insgesamt,
bezugsperson = bezugsperson,
umgang = umgang_ergebnis,
umgang_gruppe = umgang_items$gruppe,
anti_norm = anti_norm,
pro_norm = pro_norm,
normorientierung_gesamt_umgang = normorientierung_gesamt_umgang,
haeufigste_1 = haeufigste_1,
haeufigste_2 = haeufigste_2
)
})
vds34_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_vds34' oder 'pseudo'.",
"chiffre_nicht_gefunden" = paste0("Chiffre '", d$chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden."),
"kein_treffer" = paste0("Kein VDS34-Datensatz für Chiffre '", d$chiffre, "' gefunden."),
"extraktion_fehler" = paste0("Fehler bei der Auswertung der Item-Rohwerte: ", d$meldung),
"Unbekannter Fehler."
)
}
output$fehler_ui = renderUI({
req(input$btn_suchen)
d = ergebnis()
if (d$typ != "erfolg") div(class = "alert-fehler", vds34_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)
gebote_ui = lapply(d$gebote, function(g) {
text_satz = if (is.na(g$text)) "Du sollst … (keine Angabe)" else paste0("Du sollst ", g$text)
staerke_txt = if (is.na(g$staerke)) "k. A." else paste0(g$staerke, " / 3")
div(class = "item-zeile",
div(class = "item-nr", paste0(g$nr, ".")),
div(class = "item-text", text_satz),
span(class = "stufe-badge", staerke_txt)
)
})
verbote_ui = lapply(d$verbote, function(v) {
text_satz = if (is.na(v$text)) "Du sollst NICHT … (keine Angabe)" else paste0("Du sollst NICHT ", v$text)
staerke_txt = if (is.na(v$staerke)) "k. A." else paste0(v$staerke, " / 3")
div(class = "item-zeile",
div(class = "item-nr", paste0(v$nr, ".")),
div(class = "item-text", text_satz),
span(class = "stufe-badge", staerke_txt)
)
})
karte_ab = div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Teil a/b – Zehn Gebote und Verbote"),
div(class = "meta-block",
tags$strong("Chiffre: "), d$chiffre,
tags$span(" | ", style = "color:#ccc;"),
tags$strong("Ausfülldatum: "), d$ausfuelldatum
),
tags$h5("Gebote"),
div(gebote_ui),
tags$h5("Verbote", style = "margin-top: 16px;"),
div(verbote_ui),
tags$hr(),
plotOutput("mittelwerte_plot", height = "200px"),
tags$hr(),
div(class = "kontext-zeile",
div(class = "kontext-label", "Bezugsperson / Norminstanz:"),
div(if (is.na(d$bezugsperson)) "k. A." else d$bezugsperson)
)
)
umgang_zeile = function(it) {
badge_klasse = if (isTRUE(it$trifft_zu)) "zutreffen-ja" else "zutreffen-nein"
badge_text = if (isTRUE(it$trifft_zu)) "trifft zu" else if (isFALSE(it$trifft_zu)) "trifft nicht zu" else "k. A."
div(class = "item-zeile",
div(class = "item-nr", paste0(it$nr, ".")),
div(class = "item-text", it$text),
span(class = paste0("zutreffen-badge ", badge_klasse), badge_text)
)
}
anti_ui = lapply(d$umgang[d$umgang_gruppe == "anti-norm"], umgang_zeile)
pro_ui = lapply(d$umgang[d$umgang_gruppe == "pro-norm"], umgang_zeile)
karte_c = div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Teil c – Umgang mit Normen"),
tags$div(class = "abschnitt-untertitel", "anti-norm (Items 1–7)"),
div(anti_ui),
tags$div(class = "abschnitt-untertitel", "pro-norm (Items 8–20)"),
div(pro_ui),
tags$hr(),
plotOutput("umgang_plot", height = "200px"),
tags$hr(),
tags$div(class = "abschnitt-untertitel", "Häufigste Umgangsarten (Zusammenfassung)"),
div(class = "kontext-zeile",
div(class = "kontext-label", "1."),
div(if (is.na(d$haeufigste_1)) "k. A." else d$haeufigste_1)
),
div(class = "kontext-zeile",
div(class = "kontext-label", "2."),
div(if (is.na(d$haeufigste_2)) "k. A." else d$haeufigste_2)
),
div(class = "disclaimer-zeile", VDS34_DISCLAIMER)
)
tagList(karte_ab, karte_c)
})
output$mittelwerte_plot = renderPlot({
req(input$btn_suchen)
d = ergebnis()
req(d$typ == "erfolg")
make_vds34_mittelwerte_plot(d$mw_gebote, d$mw_verbote, d$normorientierung_insgesamt)
}, bg = "transparent")
output$umgang_plot = renderPlot({
req(input$btn_suchen)
d = ergebnis()
req(d$typ == "erfolg")
make_vds34_umgang_plot(d$anti_norm, d$pro_norm, d$normorientierung_gesamt_umgang)
}, 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("VDS34_", 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_vds34_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
VDS34/renv.lock Normal file
View file

File diff suppressed because it is too large Load diff

17
VDS34/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 NICHT hier installiert - es steckt ausschliesslich im extern
# gesourcten Download-Skript (get_data_vds34.R), das ausserhalb dieses
# App-Verzeichnisses liegt und seine eigenen Abhaengigkeiten mitbringt.
# 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()")