DiagnostikApps/VDS36/app.R
2026-09-22 18:35:43 +02:00

634 lines
24 KiB
R
Raw Permalink Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

# Präambel ####
library(shiny)
library(dplyr)
library(tidyr)
library(ggplot2)
library(haven)
library(officer)
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_vds36.R"
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
AKZENT_FARBE = "#8B2635"
VDS36_DISCLAIMER = paste0(
"Diese Darstellung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
"keine klinische Diagnose oder Interpretation. Die Auswertung des VDS36 ist rein ",
"grafisch-qualitativ; die Interpretation der Profile obliegt vollstaendig der ",
"behandelnden Person."
)
VDS36_ITEMS_T1 = c(
"Dem Anderen Freiheit gewähren",
"Den Anderen bestätigen, verstehen",
"Den Anderen aktiv lieben, umsorgen",
"Dem Anderen helfen, beschützen",
"Den Anderen kontrollieren, beaufsichtigen",
"Den Anderen beschuldigen, herabsetzen",
"Den Anderen angreifen, ablehnen, zurückweisen",
"Den Anderen ignorieren, vernachlässigen"
)
VDS36_ITEMS_T2 = c(
"Sich vom Anderen unabhängig machen",
"Sich dem Anderen öffnen, offenbaren",
"Sich vom Anderen lieben lassen, genießen",
"Dem Anderen vertrauen, sich auf ihn verlassen",
"Dem Anderen nachgeben, sich ihm unterwerfen",
"Schmollen, den Anderen beschwichtigen",
"Sich zurückziehen, protestieren",
"Zumachen, dem Anderen ausweichen"
)
VDS36_ITEMS_T3 = c(
"Sich selbst gegenüber emanzipieren",
"Sich selbst bestätigen, sich selbst erforschen",
"Sich selbst (aktiv) lieben",
"Sich selbst beschützen",
"Sich selbst kontrollieren, einschränken",
"Sich selbst anklagen, unterdrücken",
"Sich selbst angreifen, ablehnen",
"Sich selbst ignorieren, vernachlässigen"
)
VDS36_TEILE = c("vds36_t1", "vds36_t2", "vds36_t3")
VDS36_ZSF_VARS = c(
"vds36_zsf_t1_1", "vds36_zsf_t1_2",
"vds36_zsf_t2_1", "vds36_zsf_t2_2",
"vds36_zsf_t3_1", "vds36_zsf_t3_2"
)
# 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 ####
# Liest den rohen Speicherwert eines haven_labelled-Skalars OHNE vctrs-Typkonvertierung.
# formr exportiert mc-/select_one-Felder je nach Konfiguration mal als numerischen, mal
# als CHARACTER-Storage (z.B. "1" statt 1) - as.numeric()/as.character() auf dem
# haven_labelled-Objekt selbst loest dann vec_cast()-Fehler aus, sobald der Storage-Typ
# nicht zur Zielfunktion passt. unclass() umgeht die vctrs-Dispatch-Kette und liefert den
# rohen Wert unveraendert, danach wird konsequent als Text verglichen (typunabhaengig).
vds36_roh_speicherwert = function(wert) {
if (is.null(wert) || length(wert) == 0) return(NA_character_)
roh = unclass(wert)[1]
if (is.null(roh) || is.na(roh)) return(NA_character_)
trimws(as.character(roh))
}
# Sucht den rohen Speicherwert im labels-Attribut und liefert den zugehoerigen
# Anzeigetext - in BEIDE Richtungen geprueft, da formr die Rollen von Name/Wert
# im labels-Attribut nicht einheitlich anlegt: bei den meisten mc-Feldern gilt die
# haven-Standardkonvention (Name = Anzeigetext, Wert = Rohcode), bei manchen mit
# benannten Choice-Codes (beobachtet bei den vds36_zsf_*-Feldern: Rohwert
# "t3_item2" o.ae.) ist es genau umgekehrt (Name = Code, Wert = Anzeigetext).
# Ohne diese beidseitige Pruefung liefert die Extraktion bei der jeweils anderen
# Konvention durchgehend NA (beobachteter Fehlerfall: alle Zusammenfassungsfelder
# zeigten "k. A." trotz vorhandener Antwort).
vds36_label_lookup = function(lbl_attr, roh) {
if (is.null(lbl_attr) || length(lbl_attr) == 0 || is.na(roh)) return(NA_character_)
werte = trimws(as.character(as.vector(lbl_attr)))
namen = trimws(as.character(names(lbl_attr)))
pos = which(werte == roh)
if (length(pos) > 0) return(trimws(namen[pos[1]]))
pos = which(namen == roh)
if (length(pos) > 0) return(trimws(werte[pos[1]]))
NA_character_
}
# VERIFIZIERUNGSPFLICHT (vor Produktivnahme): Diese Funktion liest den Rohwert
# ausschliesslich aus dem Label-Text (z.B. "3 = mittel" -> 3), nicht aus dem
# haven-Storage-Wert. Vor dem ersten echten Patienteneinsatz mit einem
# Testdurchlauf gegen den formr-Export verifizieren, dass das Label-Attribut
# bei mc-Feldern in dieser Installation tatsaechlich den vollen Text
# "0 = gar nicht" ... "5 = extrem" enthaelt und nicht z.B. nur "3".
vds36_rohwert = function(original_col, wert) {
roh = vds36_roh_speicherwert(wert)
if (is.na(roh)) return(NA_real_)
label_text = vds36_label_lookup(attr(original_col, "labels"), roh)
if (is.na(label_text)) return(NA_real_)
as.numeric(sub("^([0-9]+).*", "\\1", label_text))
}
# Voller Label-Text (inkl. Original-Nummerierung) der Zusammenfassungsfelder,
# ausschliesslich ueber das labels-Attribut der ORIGINAL-Spalte aufgeloest.
vds36_zsf_text = function(original_col, wert) {
roh = vds36_roh_speicherwert(wert)
if (is.na(roh)) return(NA_character_)
vds36_label_lookup(attr(original_col, "labels"), roh)
}
# Generische Radar-Chart-Funktion fuer alle drei Teile (kein Copy-Paste), damit der
# dokumentierte Quellenfehler (Teil-3-Diagramm mit Teil-1-Beschriftung) strukturell
# ausgeschlossen ist: item_labels wird bei jedem Aufruf explizit uebergeben.
#
# Manuelle Trigonometrie + coord_fixed() statt coord_polar(theta = "x"): coord_polar()
# "muncht" gerade Kanten zwischen den Achsenpunkten zu gekruemmten Boegen (reproduzierbarer
# Spiral-Artefakt in ggplot2, unabhaengig davon ob die Item-Achse als Faktor oder als Zahl
# mit Schliesspunkt n+1 angelegt wird - getestet und verifiziert). Gleiches, bereits
# etabliertes Vorgehen wie in iipc/app.R (make_circumplex_plot) fuer ein sauberes,
# gerade-kantiges Circumplex-Polygon.
baue_radar_chart = function(daten_zeile, praefix, item_labels, akzent_farbe) {
n = length(item_labels)
werte = daten_zeile$werte[[praefix]]
winkel = pi / 2 - (seq_len(n) - 1) * (2 * pi / n)
labels_wrapped = vapply(item_labels, function(t) paste(strwrap(t, width = 18), collapse = "\n"),
character(1), USE.NAMES = FALSE)
werte_lang = werte %>%
pivot_longer(cols = c(ich, bp), names_to = "serie", values_to = "wert") %>%
mutate(
serie = recode(serie, ich = "Ich", bp = "Bezugsperson(en)"),
serie = factor(serie, levels = c("Ich", "Bezugsperson(en)")),
winkel = winkel[item],
x = wert * cos(winkel),
y = wert * sin(winkel)
)
# Ersten Punkt jeder Serie am Ende erneut anhaengen, sonst bleibt das Polygon
# am Acht-zu-eins-Uebergang offen.
punkte_geschlossen = werte_lang %>%
group_by(serie) %>%
group_modify(~ bind_rows(.x, .x[1, ])) %>%
ungroup()
ring_werte = 0:5
ring_df = do.call(rbind, lapply(ring_werte, function(rw) {
d = data.frame(x = rw * cos(winkel), y = rw * sin(winkel), ring = rw)
rbind(d, d[1, ])
}))
achsen_df = data.frame(x0 = 0, y0 = 0, x1 = 5 * cos(winkel), y1 = 5 * sin(winkel))
label_r = 5 + 1.1
label_df = data.frame(x = label_r * cos(winkel), y = label_r * sin(winkel), label = labels_wrapped)
ring_label_df = data.frame(x = 0.15, y = ring_werte, label = as.character(ring_werte))
ggplot() +
geom_path(data = ring_df, aes(x = x, y = y, group = ring), color = "#DDDDDD") +
geom_segment(data = achsen_df, aes(x = x0, y = y0, xend = x1, yend = y1), color = "#DDDDDD") +
geom_polygon(data = punkte_geschlossen, aes(x = x, y = y, group = serie, linetype = serie),
fill = NA, color = akzent_farbe, linewidth = 0.9) +
geom_point(data = punkte_geschlossen, aes(x = x, y = y, group = serie),
color = akzent_farbe, size = 1.6) +
geom_text(data = label_df, aes(x = x, y = y, label = label), size = 3.2, lineheight = 0.85) +
geom_text(data = ring_label_df, aes(x = x, y = y, label = label), size = 2.8, color = "#888888") +
scale_linetype_manual(name = NULL, values = c("Ich" = "solid", "Bezugsperson(en)" = "dashed")) +
coord_fixed(xlim = c(-8, 8), ylim = c(-8, 8), clip = "off") +
theme_void(base_size = 11) +
theme(legend.position = "bottom")
}
# 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; }
#download_word {
background: #8B2635; color: white; border: none;
font-weight: 600; padding: 8px 20px; border-radius: 4px;
}
#download_word:hover { background: #6d1e29; color: white; }
.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; }
.zsf-zeile {
display: flex; align-items: flex-start; gap: 10px;
padding: 7px 0; border-bottom: 1px solid #F0F0F0;
}
.zsf-nr { font-weight: 600; color: #8B2635; min-width: 26px; flex-shrink: 0; }
.zsf-text { flex: 1; color: #333; font-size: 0.95em; }
"
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("VDS36 Interaktions- und Beziehungsanalyse"),
tags$p("Sulz et al. 2011 | rein grafisch-qualitative Auswertung, kein Summenscore")
),
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_vds36_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_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
doc = body_add_fpar(doc, fpar(ftext("VDS36 Interaktions- und Beziehungsanalyse", fp_titel)))
doc = body_add_fpar(doc, fpar(
ftext("Chiffre: ", fp_label), ftext(erg$chiffre, fp_normal),
ftext(" Ausfülldatum: ", fp_label), ftext(erg$datum_str, fp_normal)
))
for (w in erg$warnungen) {
doc = body_add_fpar(doc, fpar(ftext(w, fp_text(font.size = 10, italic = TRUE, color = "#BF360C"))))
}
doc = body_add_par(doc, "", style = "Normal")
teile_info = list(
list(praefix = "vds36_t1", titel = "Teil 1 Aktiver Modus", items = VDS36_ITEMS_T1),
list(praefix = "vds36_t2", titel = "Teil 2 Reaktiver Modus", items = VDS36_ITEMS_T2),
list(praefix = "vds36_t3", titel = "Teil 3 Reflexiver Modus", items = VDS36_ITEMS_T3)
)
for (teil in teile_info) {
doc = body_add_fpar(doc, fpar(ftext(teil$titel, fp_abschnitt)))
bild_pfad = tempfile(fileext = ".png")
ggsave(bild_pfad,
plot = baue_radar_chart(erg, teil$praefix, teil$items, AKZENT_FARBE),
width = 6, height = 6, dpi = 150, bg = "white")
doc = body_add_img(doc, src = bild_pfad, width = 5, height = 5)
doc = body_add_par(doc, "", style = "Normal")
}
doc = body_add_fpar(doc, fpar(ftext("Zusammenfassung", fp_abschnitt)))
for (i in seq_along(erg$zsf_texte)) {
doc = body_add_fpar(doc, fpar(ftext(paste0(i, ". ", erg$zsf_texte[i]), fp_normal)))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(VDS36_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", meldung = paste0(
"Ungültige Chiffre '", chiffre, "'. Erwartetes Format: ein Großbuchstabe gefolgt von 6 Ziffern (z. B. P000123)."
)))
}
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
return(list(typ = "pfad_fehler",
meldung = paste0("Download-Skript nicht gefunden unter:\n", PFAD_DOWNLOAD_SKRIPT)))
}
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
return(list(typ = "pfad_fehler",
meldung = paste0("Pseudonym-Skript nicht gefunden unter:\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()
wd_ziel = if (!is.null(db_ordner)) db_ordner else
dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE))
on.exit(setwd(alter_wd), add = TRUE)
setwd(wd_ziel)
ok2 = tryCatch({
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
list(ok = TRUE)
}, error = function(e) list(ok = FALSE, msg = e$message))
if (!ok2$ok) return(list(typ = "skript_fehler", meldung = paste0("Fehler im Pseudonym-Skript: ", ok2$msg)))
if (!exists("daten_vds36", envir = .GlobalEnv)) {
return(list(typ = "objekt_fehler",
meldung = "Objekt 'daten_vds36' wurde nach dem Sourcen des Download-Skripts nicht gefunden."))
}
if (!exists("pseudo", envir = .GlobalEnv)) {
return(list(typ = "objekt_fehler",
meldung = "Objekt 'pseudo' wurde nach dem Sourcen des Pseudonym-Skripts nicht gefunden."))
}
daten = get("daten_vds36", envir = .GlobalEnv)
pseudo_df = get("pseudo", envir = .GlobalEnv)
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[pseudo_df$chiffre == chiffre, ]
if (nrow(treffer_ps) == 0) {
return(list(typ = "chiffre_unbekannt",
meldung = 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)
treffer_dat = daten[daten$session %in% alle_session_ids, ]
if (nrow(treffer_dat) == 0) {
return(list(typ = "kein_datensatz", meldung = paste0(
"Kein VDS36-Datensatz für Chiffre '", chiffre, "' gefunden. (",
length(alle_session_ids), " Pseudonym(e) geprüft)"
)))
}
warnungen = c()
if (nrow(treffer_dat) > 1) {
treffer_dat_sortiert = tryCatch({
td = treffer_dat
td$.created_parsed = suppressWarnings(as.POSIXct(td$created))
td[order(td$.created_parsed, decreasing = TRUE), ]
}, error = function(e) treffer_dat)
datum_neu = tryCatch(
format(as.POSIXct(treffer_dat_sortiert$created[1]), "%d.%m.%Y %H:%M"),
error = function(e) "unbekanntes Datum"
)
warnungen = c(warnungen, paste0(
"Mehrere Ausfüllungen gefunden (", nrow(treffer_dat), " Einträge). ",
"Angezeigt wird die neueste vom ", datum_neu, "."
))
treffer_dat = treffer_dat_sortiert[1, , drop = FALSE]
}
zeile = treffer_dat[1, , drop = FALSE]
created_wert = tryCatch(as.POSIXct(zeile[["created"]][1]), error = function(e) NA)
if (is.null(created_wert) || is.na(created_wert)) {
created_wert = Sys.time()
warnungen = c(warnungen, paste0(
"Ausfülldatum konnte nicht aus dem Exportdatensatz ('created') ermittelt werden - ",
"Downloaddatum wird stattdessen verwendet."
))
}
datum_str = format(created_wert, "%d.%m.%Y")
werte_liste = list()
fehlende_items = c()
for (praefix in VDS36_TEILE) {
ich_werte = numeric(8)
bp_werte = numeric(8)
for (i in 1:8) {
var_ich = paste0(praefix, "_", sprintf("%02d", i), "_ich")
var_bp = paste0(praefix, "_", sprintf("%02d", i), "_bp")
ich_werte[i] = vds36_rohwert(daten[[var_ich]], zeile[[var_ich]])
bp_werte[i] = vds36_rohwert(daten[[var_bp]], zeile[[var_bp]])
if (is.na(ich_werte[i])) fehlende_items = c(fehlende_items, var_ich)
if (is.na(bp_werte[i])) fehlende_items = c(fehlende_items, var_bp)
}
werte_liste[[praefix]] = data.frame(item = 1:8, ich = ich_werte, bp = bp_werte)
}
if (length(fehlende_items) > 0) {
warnungen = c(warnungen, paste0(
"Auswertung nicht möglich: ", length(fehlende_items),
" Item(s) ohne gültigen Wert (", paste(fehlende_items, collapse = ", "), "). ",
"Bitte Datensatz prüfen."
))
return(list(
typ = "unvollstaendig",
chiffre = chiffre,
datum_str = datum_str,
warnungen = warnungen
))
}
zsf_texte = vapply(VDS36_ZSF_VARS, function(v) {
txt = vds36_zsf_text(daten[[v]], zeile[[v]])
if (is.na(txt)) "k. A." else txt
}, character(1), USE.NAMES = FALSE)
list(
typ = "ok",
chiffre = chiffre,
created = created_wert,
datum_str = datum_str,
warnungen = warnungen,
werte = werte_liste,
zsf_texte = zsf_texte
)
})
output$fehler_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (!identical(d$typ, "ok") && !identical(d$typ, "unvollstaendig")) {
div(class = "alert-fehler", d$meldung)
}
})
output$warnung_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (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 (!identical(d$typ, "ok")) return(NULL)
zsf_ui = lapply(seq_along(d$zsf_texte), function(i) {
div(class = "zsf-zeile",
div(class = "zsf-nr", paste0(i, ".")),
div(class = "zsf-text", d$zsf_texte[i])
)
})
tagList(
div(class = "abschnitt-karte",
div(class = "meta-block",
tags$strong("Chiffre: "), d$chiffre,
tags$span(" | ", style = "color:#ccc;"),
tags$strong("Ausfülldatum: "), d$datum_str
)
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Teil 1 Aktiver Modus"),
plotOutput("plot_t1", height = "460px")
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Teil 2 Reaktiver Modus"),
plotOutput("plot_t2", height = "460px")
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Teil 3 Reflexiver Modus"),
plotOutput("plot_t3", height = "460px")
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Zusammenfassung"),
zsf_ui
)
)
})
output$plot_t1 = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(identical(d$typ, "ok"))
baue_radar_chart(d, "vds36_t1", VDS36_ITEMS_T1, AKZENT_FARBE)
}, bg = "transparent")
output$plot_t2 = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(identical(d$typ, "ok"))
baue_radar_chart(d, "vds36_t2", VDS36_ITEMS_T2, AKZENT_FARBE)
}, bg = "transparent")
output$plot_t3 = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(identical(d$typ, "ok"))
# explizit T3-Labels, nicht T1! (siehe dokumentierter Quellenfehler in der Original-docx)
baue_radar_chart(d, "vds36_t3", VDS36_ITEMS_T3, AKZENT_FARBE)
}, bg = "transparent")
output$download_word = downloadHandler(
filename = function() {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
chiffre_esc = if (is.list(d) && identical(d$typ, "ok")) gsub("[^A-Za-z0-9]", "", d$chiffre) else "export"
ausfuelldatum_fn = if (is.list(d) && identical(d$typ, "ok") && !is.null(d$created))
tryCatch(format(d$created, "%Y%m%d"), error = function(e) format(Sys.Date(), "%Y%m%d"))
else
format(Sys.Date(), "%Y%m%d")
paste0("VDS36_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
},
content = function(file) {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
daten_ok = is.list(d) && identical(d$typ, "ok")
if (!daten_ok) {
doc = read_docx()
doc = body_add_par(doc,
"Kein vollständiger Datensatz geladen. Bitte zuerst Chiffre oder Pseudonym eingeben und 'Auswerten' klicken.",
style = "Normal")
print(doc, target = file)
return()
}
doc = tryCatch(
erstelle_vds36_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)