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

Binary file not shown.

1
YSQ-S3/.Rprofile Normal file
View file

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

13
YSQ-S3/YSQ-S3.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

665
YSQ-S3/app.R Normal file
View file

@ -0,0 +1,665 @@
# Präambel ####
AKZENT_FARBE = "#8B2635"
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_ysq3.R"
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
YSQ3_DISCLAIMER = paste0(
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ",
"Es liegen keine publizierten Normwerte oder klinischen Cutoffs fuer dieses Instrument vor; ",
"die Werte sind ausschliesslich im intraindividuellen und therapeutischen Kontext zu interpretieren."
)
# 6-stufige Antwortskala, identisch fuer alle 90 Items, keine invertierten Items.
YSQ3_ANTWORTSKALA = c(
"Trifft auf mich überhaupt nicht zu" = 1,
"Trifft auf mich kaum zu" = 2,
"Eher zutreffend als unzutreffend" = 3,
"Trifft auf mich mäßig zu" = 4,
"Trifft auf mich meistens zu" = 5,
"Beschreibt mich perfekt" = 6
)
# Schema-Item-Zuordnung, explizit hinterlegt (nicht aus dem Feldnamen-Suffix re-parsen).
YSQ3_SCHEMATA = list(
ee = list(name = "Emotionale Entbehrung", items = c(1, 19, 37, 55, 73)),
vl = list(name = "Verlassenheit", items = c(2, 20, 38, 56, 74)),
mt = list(name = "Misstrauen", items = c(3, 21, 39, 57, 75)),
si = list(name = "Soziale Isolation / Entfremdung", items = c(4, 22, 40, 58, 76)),
mu = list(name = "Mangelhaftigkeit / Unliebenswürdigkeit", items = c(5, 23, 41, 59, 77)),
ve = list(name = "Versagen bei der Leistungserbringung", items = c(6, 24, 42, 60, 78)),
pi = list(name = "Praktische Inkompetenz / Abhängigkeit", items = c(7, 25, 43, 61, 79)),
vw = list(name = "Verwundbarkeit durch Leid oder Krankheit", items = c(8, 26, 44, 62, 80)),
vs = list(name = "Verstrickung", items = c(9, 27, 45, 63, 81)),
uw = list(name = "Unterwerfung", items = c(10, 28, 46, 64, 82)),
so = list(name = "Selbstaufopferung", items = c(11, 29, 47, 65, 83)),
eg = list(name = "Emotionale Gehemmtheit", items = c(12, 30, 48, 66, 84)),
us = list(name = "Unerbittliche Standards", items = c(13, 31, 49, 67, 85)),
ag = list(name = "Ansprüchlichkeit / Großartigkeit", items = c(14, 32, 50, 68, 86)),
sk = list(name = "Unzureichende Selbstkontrolle / Selbstdisziplin", items = c(15, 33, 51, 69, 87)),
ba = list(name = "Suche nach Bewunderung / Anerkennung", items = c(16, 34, 52, 70, 88)),
ps = list(name = "Pessimismus / Sorgenmachen", items = c(17, 35, 53, 71, 89)),
sb = list(name = "Selbstbestrafung", items = c(18, 36, 54, 72, 90))
)
# Itemnummer (1-90) -> Spaltenname im formr-Export, aus der Schema-Tabelle abgeleitet.
YSQ3_ITEM_SPALTEN = character(90)
for (.kuerzel in names(YSQ3_SCHEMATA)) {
for (.item_nr in YSQ3_SCHEMATA[[.kuerzel]]$items) {
YSQ3_ITEM_SPALTEN[.item_nr] = sprintf("ysq_%03d_%s", .item_nr, .kuerzel)
}
}
rm(.kuerzel, .item_nr)
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 ####
# Entfernt "**"-Markdown-Fettung und die fuehrende Itemnummer ("**1. Text**" -> "Text").
extrahiere_itemtext = function(label_roh) {
if (is.null(label_roh) || length(label_roh) == 0 || is.na(label_roh)) return(NA_character_)
text = as.character(label_roh)
text = gsub("\\*\\*", "", text)
text = sub("^\\s*[0-9]+\\.\\s*", "", text)
trimws(text)
}
# Erkennt das Exportformat pro Item zur Laufzeit: numerisch 1-6, dbl+lbl ueber
# das labels-Attribut der Original-Spalte, oder Freitext ueber die Antworttabelle.
# Nicht eindeutig zuordenbare Werte werden NA (kein stillschweigendes Raten).
recodiere_einzelwert = function(spalte_gesamt, wert) {
if (is.null(wert) || length(wert) == 0 || is.na(wert)) return(NA_real_)
roh = suppressWarnings(as.numeric(wert))
if (!is.na(roh) && roh >= 1 && roh <= 6) return(roh)
lbl_attr = attr(spalte_gesamt, "labels")
if (!is.null(lbl_attr) && length(lbl_attr) > 0 && !is.na(roh)) {
pos = which(as.vector(lbl_attr) == roh)
if (length(pos) > 0) {
treffer = unname(YSQ3_ANTWORTSKALA[trimws(names(lbl_attr)[pos[1]])])
if (!is.na(treffer)) return(treffer)
}
}
text = trimws(as.character(wert))
treffer = unname(YSQ3_ANTWORTSKALA[text])
if (!is.na(treffer)) return(treffer)
NA_real_
}
# Liest alle 90 Items einer einzelnen Zeile aus und recodiert sie auf 1-6.
# Gibt zusaetzlich die Itemnummern zurueck, die fehlen oder nicht auswertbar waren.
berechne_ysq3_werte = function(daten, zeile) {
werte = rep(NA_real_, 90)
fehlende = character(0)
for (nr in 1:90) {
spalte_name = YSQ3_ITEM_SPALTEN[nr]
if (!(spalte_name %in% names(daten))) {
fehlende = c(fehlende, as.character(nr))
next
}
wert = recodiere_einzelwert(daten[[spalte_name]], zeile[[spalte_name]][1])
werte[nr] = wert
if (is.na(wert)) fehlende = c(fehlende, as.character(nr))
}
list(werte = werte, fehlende = fehlende)
}
# Schema-Total = Summe der 5 Itemwerte, NA wenn mindestens ein Item NA ist
# (kein stillschweigendes Weiterrechnen mit den restlichen 4 Items).
berechne_schema_ergebnisse = function(werte_90) {
ergebnisse = lapply(names(YSQ3_SCHEMATA), function(kuerzel) {
schema = YSQ3_SCHEMATA[[kuerzel]]
werte_schema = werte_90[schema$items]
total = if (any(is.na(werte_schema))) NA_real_ else sum(werte_schema)
list(kuerzel = kuerzel, name = schema$name, total = total)
})
names(ergebnisse) = names(YSQ3_SCHEMATA)
ergebnisse
}
# Bricht lange Schemanamen auf zwei Zeilen um, damit die Achsenbeschriftung lesbar bleibt.
umbreche_schemaname = function(name, breite = 22) {
paste(strwrap(name, width = breite), collapse = "\n")
}
# Horizontales Balkendiagramm der 18 Schema-Totals, absteigend sortiert,
# fixer Range 5-30, keine Farbzonen (keine klinischen Schwellen vorhanden).
erstelle_schema_profil_plot = function(schema_ergebnisse) {
df = data.frame(
kuerzel = names(schema_ergebnisse),
name = sapply(schema_ergebnisse, function(x) x$name),
total = sapply(schema_ergebnisse, function(x) x$total),
stringsAsFactors = FALSE
)
reihenfolge = order(df$total, decreasing = FALSE, na.last = FALSE)
df$name_umbruch = sapply(df$name, umbreche_schemaname)
df$name_f = factor(df$name_umbruch, levels = df$name_umbruch[reihenfolge])
df$balken = ifelse(is.na(df$total), 0, df$total)
df$label = ifelse(is.na(df$total), "unvollständig", as.character(df$total))
df$label_y = ifelse(is.na(df$total), 5.3, pmin(df$total + 0.8, 29.3))
df$label_hjust = 0
df$label_farbe = ifelse(is.na(df$total), "#999999", "#333333")
ggplot(df, aes(x = name_f, y = balken)) +
geom_col(fill = AKZENT_FARBE, width = 0.65) +
geom_text(aes(y = label_y, label = label, hjust = label_hjust, color = label_farbe),
size = 3.4, fontface = "bold") +
scale_color_identity() +
scale_y_continuous(breaks = seq(5, 30, 5)) +
coord_flip(ylim = c(5, 30)) +
guides(color = "none") +
labs(x = NULL, y = "Schema-Total (5-30)") +
theme_minimal(base_size = 12) +
theme(
axis.text.y = element_text(hjust = 1, lineheight = 0.85),
panel.grid.minor = element_blank(),
plot.margin = margin(t = 5, r = 20, b = 5, l = 5)
)
}
# 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; }
.score-zahl { font-size: 2.4rem; font-weight: 800; color: #8B2635; }
.score-info { font-size: 0.9em; color: #555; margin-top: 2px; }
.gruppen-block {
margin-bottom: 18px; padding-top: 10px; border-top: 1px solid #F0F0F0;
}
.gruppen-titel {
font-weight: 700; color: #333; margin-bottom: 4px;
display: flex; justify-content: space-between; align-items: baseline;
}
.gruppen-total { font-weight: 700; color: #8B2635; }
.item-zeile {
display: flex; align-items: flex-start; gap: 10px;
padding: 6px 0; border-bottom: 1px solid #F5F5F5;
}
.item-nr { font-weight: 600; color: #8B2635; min-width: 26px; flex-shrink: 0; }
.item-text { flex: 1; color: #333; font-size: 0.92em; }
.item-wert {
background: #F0F0F0; color: #333; border-radius: 4px; padding: 2px 9px;
font-weight: 700; font-size: 0.82em; flex-shrink: 0;
}
"
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("YSQ-S3 – Young Schema Questionnaire (Kurzform 3)"),
tags$p("18 Schemata, 90 Items | deskriptive Summenwertauswertung, keine klinischen Cutoffs")
),
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_ysq3_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_score = fp_text(bold = TRUE, font.size = 14, color = AKZENT_FARBE)
fp_warnung = fp_text(font.size = 10, italic = TRUE, color = "#BF360C")
fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
doc = body_add_fpar(doc, fpar(ftext("YSQ-S3 - Einzelauswertung", fp_titel)))
doc = body_add_fpar(doc, fpar(
ftext("Chiffre: ", fp_label),
ftext(erg$chiffre, fp_normal),
ftext(" Ausfuelldatum: ", fp_label),
ftext(erg$ausfuelldatum_str, fp_normal)
))
if (length(erg$warnungen) > 0) {
for (w in erg$warnungen) {
doc = body_add_fpar(doc, fpar(ftext(w, fp_warnung)))
}
}
doc = body_add_par(doc, "", style = "Normal")
gesamt_text = if (is.na(erg$gesamtscore)) "unvollstaendig" else paste0(erg$gesamtscore, " / 540")
doc = body_add_fpar(doc, fpar(ftext("Gesamtscore", fp_abschnitt)))
doc = body_add_fpar(doc, fpar(ftext(gesamt_text, fp_score)))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Schema-Profil", fp_abschnitt)))
bild_pfad = tempfile(fileext = ".png")
ggsave(bild_pfad, plot = erg$profil_plot, width = 7, height = 7.8, dpi = 150)
doc = doc %>% body_add_img(src = bild_pfad, width = 6, height = 6.7)
file.remove(bild_pfad)
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Schema-Totalwerte", fp_abschnitt)))
for (kuerzel in names(erg$schema_ergebnisse)) {
s = erg$schema_ergebnisse[[kuerzel]]
wert_text = if (is.na(s$total)) "unvollstaendig" else paste0(s$total, " / 30")
doc = body_add_fpar(doc, fpar(
ftext(paste0(s$name, " (", toupper(kuerzel), "): "), fp_label),
ftext(wert_text, fp_normal)
))
}
doc = body_add_par(doc, "", style = "Normal")
fp_item_wert = fp_text(bold = TRUE, font.size = 10, color = AKZENT_FARBE)
doc = body_add_fpar(doc, fpar(ftext("Einzelitems nach Schema", fp_abschnitt)))
for (kuerzel in names(erg$schema_ergebnisse)) {
s = erg$schema_ergebnisse[[kuerzel]]
doc = body_add_fpar(doc, fpar(
ftext(paste0(s$name, " (", toupper(kuerzel), ")"), fp_label)
))
for (nr in YSQ3_SCHEMATA[[kuerzel]]$items) {
spalte_name = YSQ3_ITEM_SPALTEN[nr]
label_roh = if (spalte_name %in% names(erg$daten)) attr(erg$daten[[spalte_name]], "label") else NA
item_text = extrahiere_itemtext(label_roh)
if (is.na(item_text)) item_text = paste0("Item ", nr)
wert = erg$werte_90[nr]
wert_text = if (is.na(wert)) "k. A." else as.character(wert)
doc = body_add_fpar(doc, fpar(
ftext(paste0(nr, ". ", item_text, " "), fp_normal),
ftext(paste0("(", wert_text, ")"), fp_item_wert)
))
}
doc = body_add_par(doc, "", style = "Normal")
}
doc = body_add_fpar(doc, fpar(ftext(YSQ3_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(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,
meldung = paste0(
"Ungueltige Chiffre '", chiffre, "'. Erwartet: ein Grossbuchstabe + 6 Ziffern (z. B. P000123)."
)
))
}
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 = tryCatch({
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
list(ok = TRUE)
}, error = function(e) list(ok = FALSE, msg = e$message))
if (!ok$ok) {
return(list(typ = "skript_fehler", meldung = paste0("Fehler im Download-Skript: ", ok$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()
on.exit(setwd(alter_wd), add = TRUE)
wd_ziel = if (!is.null(db_ordner)) db_ordner else
dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE))
setwd(wd_ziel)
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 = paste0("Fehler im Pseudonym-Skript: ", ok_ps$msg)))
}
if (!exists("daten_ysq3", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = "Objekt 'daten_ysq3' nach dem Sourcen nicht gefunden. Bitte Download-Skript pruefen."))
}
if (!exists("pseudo", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = "Objekt 'pseudo' nach dem Sourcen nicht gefunden. Bitte Pseudonym-Skript pruefen."))
}
daten = get("daten_ysq3", envir = .GlobalEnv)
pseudo = get("pseudo", envir = .GlobalEnv)
# Chiffre-Rueckauflösung aus Pseudonym: explizit eingegebenes Pseudonym hat Vorrang.
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]))
}
treffer_ps = pseudo[pseudo$chiffre == chiffre, ]
alle_session_ids = unique(treffer_ps$pseudonym)
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
treffer_dat = daten[daten$session %in% alle_session_ids, ]
if (nrow(treffer_dat) == 0) {
return(list(typ = "keine_daten",
meldung = paste0("Kein YSQ-S3-Datensatz fuer Chiffre '", chiffre, "' gefunden.")))
}
warnungen = character(0)
if (nrow(treffer_dat) > 1) {
datum_spalte_sort = intersect(c("ended", "created", "modified"), names(treffer_dat))[1]
if (!is.na(datum_spalte_sort)) {
treffer_dat = treffer_dat[order(treffer_dat[[datum_spalte_sort]], decreasing = TRUE), ]
}
n = nrow(treffer_dat)
treffer_dat = treffer_dat[1, , drop = FALSE]
warnungen = c(warnungen, paste0(
"Mehrere Ausfuellungen gefunden (", n, " Eintraege). Angezeigt wird die neueste."
))
}
zeile = treffer_dat[1, , drop = FALSE]
# Ausfuelldatum defensiv aus der ersten passenden Spalte, nicht aus Sys.Date().
datum_spalte = intersect(c("ended", "created", "modified"), names(daten))[1]
ausfuelldatum_str = if (!is.na(datum_spalte)) {
tryCatch(format(as.POSIXct(zeile[[datum_spalte]][1]), "%d.%m.%Y"),
error = function(e) "unbekannt")
} else "unbekannt"
werte_ergebnis = berechne_ysq3_werte(daten, zeile)
werte_90 = werte_ergebnis$werte
fehlende_items = werte_ergebnis$fehlende
if (length(fehlende_items) > 0) {
warnungen = c(warnungen, paste0(
"Achtung: ", length(fehlende_items),
" Item(s) konnten nicht eindeutig ausgewertet werden (Item(s) ",
paste(fehlende_items, collapse = ", "), ")."
))
}
schema_ergebnisse = berechne_schema_ergebnisse(werte_90)
totals = sapply(schema_ergebnisse, function(x) x$total)
gesamtscore = if (any(is.na(totals))) NA_real_ else sum(totals)
list(
typ = "ok",
chiffre = chiffre,
ausfuelldatum_str = ausfuelldatum_str,
warnungen = warnungen,
werte_90 = werte_90,
schema_ergebnisse = schema_ergebnisse,
gesamtscore = gesamtscore,
daten = daten,
zeile = zeile
)
})
output$fehler_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (d$typ != "ok") div(class = "alert-fehler", d$meldung)
})
output$warnung_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (d$typ != "ok" || length(d$warnungen) == 0) return(NULL)
tagList(lapply(d$warnungen, function(w) div(class = "alert-warnung", w)))
})
output$ergebnis_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (d$typ != "ok") return(NULL)
gesamt_text = if (is.na(d$gesamtscore)) "unvollständig" else paste0(d$gesamtscore, " / 540")
gruppen_ui = lapply(names(d$schema_ergebnisse), function(kuerzel) {
schema = d$schema_ergebnisse[[kuerzel]]
total_text = if (is.na(schema$total)) "unvollständig" else paste0(schema$total, " / 30")
item_nrn = YSQ3_SCHEMATA[[kuerzel]]$items
item_zeilen = lapply(item_nrn, function(nr) {
spalte_name = YSQ3_ITEM_SPALTEN[nr]
label_roh = if (spalte_name %in% names(d$daten)) attr(d$daten[[spalte_name]], "label") else NA
item_text = extrahiere_itemtext(label_roh)
if (is.na(item_text)) item_text = paste0("Item ", nr)
wert = d$werte_90[nr]
wert_text = if (is.na(wert)) "–" else as.character(wert)
div(class = "item-zeile",
div(class = "item-nr", paste0(nr, ".")),
div(class = "item-text", item_text),
div(class = "item-wert", wert_text)
)
})
div(class = "gruppen-block",
div(class = "gruppen-titel",
span(paste0(schema$name, " (", toupper(kuerzel), ")")),
span(class = "gruppen-total", total_text)
),
item_zeilen
)
})
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "YSQ-S3 Auswertung"),
div(class = "meta-block",
tags$strong("Chiffre: "), d$chiffre,
tags$span(" | ", style = "color:#ccc;"),
tags$strong("Ausfuelldatum: "), d$ausfuelldatum_str
),
tags$hr(),
div(
div(class = "score-zahl", gesamt_text),
div(class = "score-info", "Gesamtscore")
),
plotOutput("profil_plot", height = "750px"),
tags$hr(),
tags$h5("Einzelitems nach Schema"),
gruppen_ui
)
})
output$profil_plot = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(d$typ == "ok")
erstelle_schema_profil_plot(d$schema_ergebnisse)
}, bg = "transparent")
output$download_word = downloadHandler(
filename = function() {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
chiffre_datei = if (is.list(d) && identical(d$typ, "ok"))
gsub("[^A-Za-z0-9]", "", d$chiffre) else "export"
datum_datei = if (is.list(d) && identical(d$typ, "ok")) {
tryCatch(format(as.Date(d$ausfuelldatum_str, "%d.%m.%Y"), "%Y%m%d"),
error = function(e) format(Sys.Date(), "%Y%m%d"))
} else format(Sys.Date(), "%Y%m%d")
paste0("YSQ3_", chiffre_datei, "_", datum_datei, ".docx")
},
content = function(file) {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
if (!is.list(d) || !identical(d$typ, "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()
}
erg = list(
chiffre = d$chiffre,
ausfuelldatum_str = d$ausfuelldatum_str,
warnungen = d$warnungen,
gesamtscore = d$gesamtscore,
schema_ergebnisse = d$schema_ergebnisse,
werte_90 = d$werte_90,
daten = d$daten,
profil_plot = erstelle_schema_profil_plot(d$schema_ergebnisse)
)
doc = tryCatch(
erstelle_ysq3_docx(erg),
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
YSQ-S3/renv.lock Normal file
View file

File diff suppressed because it is too large Load diff

14
YSQ-S3/setup_renv.R Normal file
View file

@ -0,0 +1,14 @@
# Einmalig ausfuehren, bevor die App zum ersten Mal gestartet wird.
# Initialisiert renv und installiert alle benoedigten Pakete.
#
# 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()")