Initial commit
This commit is contained in:
commit
3cba772836
1341 changed files with 532924 additions and 0 deletions
968
VDS33/app.R
Normal file
968
VDS33/app.R
Normal file
|
|
@ -0,0 +1,968 @@
|
|||
# Präambel ####
|
||||
|
||||
AKZENT_FARBE = "#8B2635"
|
||||
|
||||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_vds33.R" # liefert: daten_vds33
|
||||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo
|
||||
|
||||
VDS33_DISCLAIMER = paste0(
|
||||
"Dies ist ein ipsatives Werteprofil ohne Normwerte und ohne klinischen Cutoff. ",
|
||||
"Die Auswertung dient als Hilfsmittel für klinisches Fachpersonal und ersetzt keine ",
|
||||
"eigenständige fachliche Einordnung. Die Interpretation obliegt der behandelnden Person."
|
||||
)
|
||||
|
||||
# Farbskala fuer die Antwortstufen-Badges der 14 Items (Block C), analog zur
|
||||
# gruen -> dunkelrot-Verlaufslogik in pg13r/app.R.
|
||||
VDS33_STUFE_BADGE_FARBEN = c("0" = "#4CAF50", "1" = "#F48FB1", "2" = "#EF5350", "3" = "#B71C1C")
|
||||
VDS33_STUFE_BADGE_TEXT_FARBEN = c("0" = "white", "1" = "#333333", "2" = "white", "3" = "white")
|
||||
|
||||
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 - Ansatz uebernommen aus vds32/app.R.
|
||||
vds33_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 (Ja/Nein, Block-C-Antwortstufen) ueber das
|
||||
# labels-Attribut der ORIGINAL-Spalte - nie hartkodierte Zahlenwerte
|
||||
# annehmen (Abschnitt 4.2 der Spezifikation: Kodierungsrichtung unverifiziert).
|
||||
vds33_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 = vds33_match_in_labels(labs, roh)
|
||||
if (!is.null(treffer)) return(trimws(as.character(treffer$text)))
|
||||
}
|
||||
roh_chr = trimws(as.character(roh))
|
||||
if (nchar(roh_chr) > 0) return(roh_chr)
|
||||
NA_character_
|
||||
}
|
||||
|
||||
# Block C (Abschnitt 4.6): Stufe 0-3 aus der fuehrenden Ziffer des
|
||||
# Choice-Label-Texts ("0 = trifft nicht zu" usw.) statt aus dem Rohwert.
|
||||
vds33_stufe_aus_label = function(label_text) {
|
||||
if (is.na(label_text)) return(NA_integer_)
|
||||
if (grepl("^\\s*[0-3]\\s*=", label_text)) {
|
||||
return(as.integer(sub("^\\s*([0-3])\\s*=.*$", "\\1", label_text)))
|
||||
}
|
||||
stufe_num = suppressWarnings(as.integer(label_text))
|
||||
if (!is.na(stufe_num) && stufe_num >= 0 && stufe_num <= 3) return(stufe_num)
|
||||
NA_integer_
|
||||
}
|
||||
|
||||
# Variablenlabel (Itemtext) der ORIGINAL-Spalte, mit Feldname als Fallback
|
||||
# falls kein label-Attribut vorliegt.
|
||||
vds33_get_var_label = function(original_spalte, feldname) {
|
||||
lbl = attr(original_spalte, "label")
|
||||
if (!is.null(lbl) && nchar(trimws(as.character(lbl))) > 0) return(trimws(as.character(lbl)))
|
||||
feldname
|
||||
}
|
||||
|
||||
# Freitextfeld lesen, leere/NA-Werte einheitlich als NA_character_.
|
||||
vds33_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
|
||||
}
|
||||
|
||||
# mc_multiple-Ankreuzliste (Abschnitt 4.2/9.1): Exportformat nicht
|
||||
# verifiziert, daher robust auf Komma ODER Semikolon splitten und
|
||||
# fuehrende/folgende Klammern/Anfuehrungszeichen entfernen.
|
||||
vds33_parse_auswahl = function(roh) {
|
||||
if (is.null(roh) || length(roh) == 0) return(character(0))
|
||||
roh = roh[1]
|
||||
if (is.na(roh)) return(character(0))
|
||||
txt = trimws(as.character(unclass(roh)))
|
||||
if (nchar(txt) == 0) return(character(0))
|
||||
txt = gsub("^[\\[\"']+|[\\]\"']+$", "", txt)
|
||||
teile = trimws(strsplit(txt, "[,;]")[[1]])
|
||||
teile = gsub("^[\\[\"']+|[\\]\"']+$", "", teile)
|
||||
teile[nchar(teile) > 0]
|
||||
}
|
||||
|
||||
# select_one-Feld mit externer Choice-Liste (Abschnitt 9.2): formr
|
||||
# exportiert solche Felder in dieser App-Serie meist als internen
|
||||
# Choice-NAMEN (z.B. "w12", "wf3", "u5") direkt als String (verifiziert in
|
||||
# vds24/app.R) - deshalb zuerst direkter Muster-Abgleich auf as.character(),
|
||||
# erst bei Nichttreffer auf das labels-Attribut (dbl+lbl-Fall) ausweichen.
|
||||
vds33_resolve_select_one_code = function(original_spalte, wert, muster) {
|
||||
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_character_)
|
||||
roh = unclass(wert)[1]
|
||||
roh_chr = trimws(as.character(roh))
|
||||
if (grepl(muster, roh_chr)) return(roh_chr)
|
||||
|
||||
labs = attr(original_spalte, "labels")
|
||||
if (!is.null(labs) && length(labs) > 0) {
|
||||
treffer = vds33_match_in_labels(labs, roh)
|
||||
if (!is.null(treffer)) {
|
||||
kandidat = trimws(as.character(treffer$text))
|
||||
if (grepl(muster, kandidat)) return(kandidat)
|
||||
}
|
||||
}
|
||||
if (nchar(roh_chr) == 0) return(NA_character_)
|
||||
roh_chr
|
||||
}
|
||||
|
||||
make_vds33_profil_plot = function(pct) {
|
||||
bereich_reihenfolge = c("wf1", "wf2", "wf3", "wf4", "wf5", "wf6", "wf7", "aw", "ew")
|
||||
df = data.frame(
|
||||
bereich = factor(bereich_kurz[bereich_reihenfolge], levels = bereich_kurz[bereich_reihenfolge]),
|
||||
wert = unname(pct[bereich_reihenfolge]),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
df_vorhanden = df[!is.na(df$wert), ]
|
||||
|
||||
ggplot(df, aes(x = bereich, y = wert, group = 1)) +
|
||||
geom_line(data = df_vorhanden, color = AKZENT_FARBE, linewidth = 1) +
|
||||
geom_point(data = df_vorhanden, color = AKZENT_FARBE, size = 3) +
|
||||
scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 25)) +
|
||||
theme_minimal(base_size = 12) +
|
||||
theme(
|
||||
axis.title.x = element_blank(),
|
||||
panel.grid.minor = element_blank(),
|
||||
plot.margin = margin(t = 10, r = 15, b = 5, l = 5)
|
||||
) +
|
||||
labs(y = "Anteil angekreuzter Items (%)")
|
||||
}
|
||||
|
||||
|
||||
# Datenaufbereitung ####
|
||||
|
||||
item_bereich_map = data.frame(
|
||||
item_nr = 1:59,
|
||||
item_code = c(
|
||||
"wf1_1","wf1_2","wf1_3","wf1_4","wf1_5","wf1_6","wf1_7",
|
||||
"wf2_1","wf2_2","wf2_3","wf2_4","wf2_5","wf2_6","wf2_7",
|
||||
"wf3_1","wf3_2","wf3_3","wf3_4","wf3_5","wf3_6","wf3_7",
|
||||
"wf4_1","wf4_2","wf4_3","wf4_4","wf4_5","wf4_6","wf4_7",
|
||||
"wf5_1","wf5_2","wf5_3","wf5_4","wf5_5","wf5_6","wf5_7",
|
||||
"wf6_1","wf6_2","wf6_3","wf6_4","wf6_5","wf6_6",
|
||||
"wf7_1","wf7_2","wf7_3","wf7_4","wf7_5","wf7_6","wf7_7",
|
||||
"aw_1","aw_2","aw_3","aw_4","aw_5","aw_6","aw_7","aw_8","aw_9","aw_10","aw_11"
|
||||
),
|
||||
bereich_code = c(
|
||||
rep("wf1",7), rep("wf2",7), rep("wf3",7), rep("wf4",7), rep("wf5",7),
|
||||
rep("wf6",6), rep("wf7",7), rep("aw",11)
|
||||
),
|
||||
item_text = c(
|
||||
"dass ich gegen äußere Widerstände zu meiner Meinung stehen kann",
|
||||
"dass ich mich mit der Meinung anderer kritisch auseinandersetzen kann",
|
||||
"dass ich mich jederzeit frei und selbstverantwortlich entscheiden kann",
|
||||
"dass meine Handlungen mit meinen Einstellungen übereinstimmen",
|
||||
"dass ich mich selbst akzeptieren kann",
|
||||
"dass ich Schwierigkeiten nicht aus dem Weg gehe, nicht zu feige bin",
|
||||
"dass ich meine Meinung jederzeit frei äußern kann",
|
||||
"dass ich anderen überlegen bin",
|
||||
"dass ich bessere Leistungen erbringen kann als meine Kollegen, Mitschüler etc.",
|
||||
"dass ich einen angesehenen Beruf habe",
|
||||
"dass ich leistungsfähig bin",
|
||||
"dass ich in meinem Beruf erfolgreich bin",
|
||||
"dass ich fehlerfrei arbeite",
|
||||
"dass ich mich rasch auf neue Probleme und Situationen einstellen kann",
|
||||
"dass ich ein ruhiges und behagliches Leben habe",
|
||||
"dass ich sorglos leben kann",
|
||||
"dass ich eine sichere Zukunft habe",
|
||||
"dass ich materiellen Wohlstand habe",
|
||||
"dass ich stabile wirtschaftliche Verhältnisse habe",
|
||||
"dass ich ein konfliktfreies Leben habe",
|
||||
"dass ich keine Feinde habe",
|
||||
"mein Glaube an Gott",
|
||||
"dass ich zu allen Menschen freundlich und nett bin",
|
||||
"dass ich genügsam und bescheiden bin",
|
||||
"dass ich von anderen Menschen nichts Schlechtes denke",
|
||||
"dass ich meinen Mitmenschen gegenüber immer hilfsbereit bin",
|
||||
"mein Glaube an ein Leben nach dem Tod",
|
||||
"mein Glaube an eine göttliche Vorsehung",
|
||||
"dass ich ein harmonisches Verhältnis zu meinem (Ehe-)Partner habe",
|
||||
"dass ich stabile familiäre Verhältnisse habe",
|
||||
"dass ich ein harmonisches Familienleben habe",
|
||||
"dass ich in der Ehe/Partnerschaft treu bin",
|
||||
"dass ich meine Eltern liebe und achte",
|
||||
"dass ich Kinder habe",
|
||||
"dass ich mich auf andere (besonders meinen Partner) verlassen kann",
|
||||
"dass ich viele Freunde habe",
|
||||
"dass ich in meinem sozialen Umfeld (Arbeitsplatz, Nachbarn etc.) beliebt bin",
|
||||
"dass andere gut von mir denken",
|
||||
"dass ich mich sozial engagiere",
|
||||
"dass ich frei von Hemmungen bin",
|
||||
"dass ich sicher im Umgang mit anderen bin (Selbstsicherheit)",
|
||||
"dass ich ein interessantes, spannendes und ereignisreiches Leben habe",
|
||||
"dass ich möglichst viel von der Welt gesehen habe",
|
||||
"dass ich auf künstlerisch-kreativem Gebiet etwas Besonderes leiste",
|
||||
"dass ich äußerlich attraktiv bin",
|
||||
"dass ich frei und unabhängig bin",
|
||||
"dass ich die Schönheiten der Natur und der Künste genießen kann",
|
||||
"dass ich so viel wie möglich Freude und Vergnügen im Leben habe",
|
||||
"dass Frieden in der Welt ist",
|
||||
"dass ich gesund bin",
|
||||
"dass ich körperlich fit bin",
|
||||
"dass ich mich entsprechend meinen Möglichkeiten und Wünschen entfalten kann (Selbstverwirklichung)",
|
||||
"dass ich meinem Leben einen Sinn gebe",
|
||||
"dass ich das Gefühl habe, gebraucht zu werden",
|
||||
"dass ich tolerant gegenüber Menschen bin, die anders sind",
|
||||
"dass ich meine Pflichten gewissenhaft erfülle",
|
||||
"dass ich Freude an der Arbeit habe",
|
||||
"dass ich Bildung habe",
|
||||
"dass ich die Menschen und das Leben verstehe (Weisheit)"
|
||||
),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
bereich_labels = c(
|
||||
wf1 = "intellektuelle Freiheit – geistige Unabhängigkeit",
|
||||
wf2 = "Überlegenheit, Leistung",
|
||||
wf3 = "Sicherheit / materielle Sicherheit",
|
||||
wf4 = "Glauben/Spiritualität",
|
||||
wf5 = "Familie und Partnerschaft",
|
||||
wf6 = "soziale Akzeptanz und Anerkennung",
|
||||
wf7 = "etwas erleben und Schönes genießen",
|
||||
aw = "allgemeine Werte",
|
||||
ew = "weitere eigene (selbst genannte) Werte"
|
||||
)
|
||||
|
||||
bereich_kurz = c(wf1 = "WF1", wf2 = "WF2", wf3 = "WF3", wf4 = "WF4", wf5 = "WF5",
|
||||
wf6 = "WF6", wf7 = "WF7", aw = "AW", ew = "EW")
|
||||
|
||||
bereich_maxn = c(wf1 = 7, wf2 = 7, wf3 = 7, wf4 = 7, wf5 = 7, wf6 = 6, wf7 = 7, aw = 11, ew = 5)
|
||||
|
||||
VDS33_BEREICHE_OHNE_EW = c("wf1", "wf2", "wf3", "wf4", "wf5", "wf6", "wf7", "aw")
|
||||
VDS33_BEREICHE_ALLE = c(VDS33_BEREICHE_OHNE_EW, "ew")
|
||||
|
||||
|
||||
# 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; }
|
||||
.ipsativ-hinweis {
|
||||
background: #F5F5F5; border-left: 5px solid #9E9E9E;
|
||||
padding: 10px 16px; border-radius: 4px; color: #555555;
|
||||
margin-bottom: 16px; font-size: 0.88em; font-style: italic;
|
||||
}
|
||||
.tabelle-standard { width: 100%; border-collapse: collapse; font-size: 0.92em; }
|
||||
.tabelle-standard th, .tabelle-standard td {
|
||||
text-align: left; padding: 6px 10px; border-bottom: 1px solid #F0F0F0;
|
||||
}
|
||||
.tabelle-standard th {
|
||||
color: #777; font-size: 0.8em; text-transform: uppercase;
|
||||
letter-spacing: 0.03em; font-weight: 700;
|
||||
}
|
||||
.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;
|
||||
}
|
||||
.stufe-badge-0 { background: #4CAF50; color: white; }
|
||||
.stufe-badge-1 { background: #F48FB1; color: #333333; }
|
||||
.stufe-badge-2 { background: #EF5350; color: white; }
|
||||
.stufe-badge-3 { background: #B71C1C; color: white; }
|
||||
.legende-liste { margin-top: 12px; }
|
||||
.legende-zeile {
|
||||
display: flex; gap: 8px; padding: 2px 0; color: #444; font-size: 0.88em;
|
||||
}
|
||||
.legende-kurz { font-weight: 700; color: #8B2635; min-width: 34px; flex-shrink: 0; }
|
||||
.legende-text { flex: 1; }
|
||||
.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; }
|
||||
.hinweis-inkonsistenz { color: #B71C1C; font-style: italic; }
|
||||
.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("VDS33 – Wertorientierung"),
|
||||
tags$p("Ipsatives Werteprofil ohne Normwerte und ohne klinischen Cutoff | Prof. Dr. Dr. Serge Sulz")
|
||||
),
|
||||
|
||||
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_vds33_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("VDS33 – Wertorientierung", fp_titel)))
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext("Chiffre: ", fp_label),
|
||||
ftext(erg$chiffre, fp_normal),
|
||||
ftext(" Ausfülldatum: ", fp_label),
|
||||
ftext(format(erg$ausfuelldatum, "%d.%m.%Y"), 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")
|
||||
|
||||
profil_img = tempfile(fileext = ".png")
|
||||
ggsave(profil_img, plot = make_vds33_profil_plot(erg$pct), width = 7, height = 3.6, dpi = 150, bg = "white")
|
||||
doc = body_add_fpar(doc, fpar(ftext("Werteprofil", fp_abschnitt)))
|
||||
doc = body_add_img(doc, src = profil_img, width = 6.2, height = 3.2)
|
||||
|
||||
for (b in VDS33_BEREICHE_ALLE) {
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(paste0(bereich_kurz[[b]], " – "), fp_label),
|
||||
ftext(bereich_labels[[b]], fp_klein)
|
||||
))
|
||||
}
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
|
||||
for (t in erg$top3) {
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(paste0(t$rang, ": "), fp_label),
|
||||
ftext(t$text, fp_normal)
|
||||
))
|
||||
}
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext("Wichtigste Einzelwerte", fp_abschnitt)))
|
||||
for (r in erg$rang_wert) {
|
||||
if (!isTRUE(r$vorhanden)) next
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(paste0(r$rang, ". "), fp_label),
|
||||
ftext(r$text, fp_normal),
|
||||
ftext(paste0(" (", r$bereich_name, ")"), fp_klein)
|
||||
))
|
||||
if (isTRUE(r$inkonsistent)) {
|
||||
doc = body_add_fpar(doc, fpar(ftext(
|
||||
" Hinweis: Rangplatz verweist auf ein leeres eigenes-Werte-Freitextfeld.",
|
||||
fp_text(font.size = 9, italic = TRUE, color = "#B71C1C"))))
|
||||
}
|
||||
}
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext("Wichtigste Wertebereiche", fp_abschnitt)))
|
||||
for (r in erg$rang_bereich) {
|
||||
if (!isTRUE(r$vorhanden)) next
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(paste0(r$rang, ". "), fp_label),
|
||||
ftext(r$bereich_name, fp_normal)
|
||||
))
|
||||
}
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext("Selbsteinschätzung je Bereich (Ja/Nein)", fp_abschnitt)))
|
||||
for (b in VDS33_BEREICHE_ALLE) {
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(paste0(bereich_labels[[b]], ": "), fp_label),
|
||||
ftext(if (is.na(erg$janein[[b]])) "k. A." else erg$janein[[b]], fp_normal)
|
||||
))
|
||||
}
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext("14 Items (Block C)", fp_abschnitt)))
|
||||
for (it in erg$block_c) {
|
||||
stufe_key = if (!is.na(it$stufe)) as.character(it$stufe) else NA_character_
|
||||
fp_badge = if (!is.na(stufe_key)) fp_text(
|
||||
color = VDS33_STUFE_BADGE_TEXT_FARBEN[[stufe_key]],
|
||||
bold = TRUE,
|
||||
shading.color = VDS33_STUFE_BADGE_FARBEN[[stufe_key]],
|
||||
font.size = 10
|
||||
) else fp_klein
|
||||
badge_text = if (is.na(it$stufe)) " k. A. " else paste0(" ", it$stufe, " / 3 ")
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(paste0(it$nr, ". ", it$item_text, " "), fp_normal),
|
||||
ftext(badge_text, fp_badge)
|
||||
))
|
||||
}
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext("Umgang mit diesen Themen (Block D)", fp_abschnitt)))
|
||||
for (r in erg$d1) {
|
||||
if (!isTRUE(r$vorhanden)) next
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(paste0(r$rang, ". "), fp_label),
|
||||
ftext(r$text, fp_normal)
|
||||
))
|
||||
}
|
||||
if (!is.na(erg$d2_text)) {
|
||||
doc = body_add_fpar(doc, fpar(ftext("Freitext (D.2): ", fp_label)))
|
||||
doc = body_add_fpar(doc, fpar(ftext(erg$d2_text, fp_normal)))
|
||||
}
|
||||
if (!is.na(erg$d3_text)) {
|
||||
doc = body_add_fpar(doc, fpar(ftext("Freitext (D.3): ", fp_label)))
|
||||
doc = body_add_fpar(doc, fpar(ftext(erg$d3_text, fp_normal)))
|
||||
}
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext(VDS33_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_vds33", envir = .GlobalEnv) || !exists("pseudo", envir = .GlobalEnv)) {
|
||||
return(list(typ = "daten_fehlen"))
|
||||
}
|
||||
|
||||
daten = get("daten_vds33", 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_vds33' gefunden. ",
|
||||
"Bitte Session-ID-Spaltenname vor Produktiveinsatz prüfen."
|
||||
)))
|
||||
}
|
||||
|
||||
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]
|
||||
|
||||
ausfuelldatum = tryCatch({
|
||||
kandidaten = c("created", "ended")
|
||||
spalte = intersect(kandidaten, names(zeile))
|
||||
if (length(spalte) > 0) {
|
||||
roh = zeile[[spalte[1]]][1]
|
||||
as.Date(as.POSIXct(as.character(roh)))
|
||||
} else {
|
||||
Sys.Date()
|
||||
}
|
||||
}, error = function(e) Sys.Date())
|
||||
|
||||
# Abschnitt 6, Schritt 1+2: Prozentwert je Wertebereich.
|
||||
pct = setNames(rep(NA_real_, 9), VDS33_BEREICHE_ALLE)
|
||||
for (b in VDS33_BEREICHE_OHNE_EW) {
|
||||
feld = paste0("vds33_", b, "_auswahl")
|
||||
codes = if (feld %in% names(zeile)) vds33_parse_auswahl(zeile[[feld]][1]) else character(0)
|
||||
valide_codes = item_bereich_map$item_code[item_bereich_map$bereich_code == b]
|
||||
valide = codes[codes %in% valide_codes]
|
||||
pct[b] = 100 * length(valide) / bereich_maxn[[b]]
|
||||
}
|
||||
|
||||
ew_texte = sapply(1:5, function(i) vds33_text_feld(zeile, paste0("vds33_ew_", i)))
|
||||
ew_filled = sum(!is.na(ew_texte))
|
||||
pct["ew"] = if (ew_filled > 0) 100 * ew_filled / 5 else NA_real_
|
||||
|
||||
# Abschnitt 6, Schritt 4: Top-3-Bereiche, level-gruppiert.
|
||||
pct_valide = pct[!is.na(pct)]
|
||||
levels_sortiert = sort(unique(pct_valide), decreasing = TRUE)
|
||||
top_levels = head(levels_sortiert, 3)
|
||||
rang_namen = c("Am wichtigsten", "Am zweitwichtigsten", "Am drittwichtigsten")
|
||||
top3 = lapply(seq_along(top_levels), function(i) {
|
||||
lvl = top_levels[i]
|
||||
bereiche_auf_level = names(pct_valide)[pct_valide == lvl]
|
||||
list(
|
||||
rang = rang_namen[i],
|
||||
level = lvl,
|
||||
bereiche = bereiche_auf_level,
|
||||
text = paste(bereich_labels[bereiche_auf_level], collapse = "; ")
|
||||
)
|
||||
})
|
||||
|
||||
# Abschnitt 6, Schritt 5: wichtigste Einzelwerte (Block B1).
|
||||
rang_wert = lapply(1:5, function(i) {
|
||||
feld = paste0("vds33_rang_wert_", i)
|
||||
if (!(feld %in% names(zeile))) return(list(rang = i, vorhanden = FALSE))
|
||||
code = vds33_resolve_select_one_code(daten[[feld]], zeile[[feld]], "^w[0-9]{1,2}$")
|
||||
if (is.na(code)) return(list(rang = i, vorhanden = FALSE))
|
||||
|
||||
nr = suppressWarnings(as.integer(sub("^w", "", code)))
|
||||
if (!is.na(nr) && nr >= 1 && nr <= 59) {
|
||||
treffer = item_bereich_map[item_bereich_map$item_nr == nr, ]
|
||||
return(list(
|
||||
rang = i, code = code, vorhanden = TRUE, inkonsistent = FALSE,
|
||||
bereich = treffer$bereich_code[1],
|
||||
bereich_name = bereich_labels[[treffer$bereich_code[1]]],
|
||||
text = treffer$item_text[1]
|
||||
))
|
||||
}
|
||||
if (!is.na(nr) && nr >= 60 && nr <= 64) {
|
||||
ew_feld = paste0("vds33_ew_", nr - 59)
|
||||
ew_text = vds33_text_feld(zeile, ew_feld)
|
||||
inkonsistent = is.na(ew_text)
|
||||
return(list(
|
||||
rang = i, code = code, vorhanden = TRUE, inkonsistent = inkonsistent,
|
||||
bereich = "ew", bereich_name = bereich_labels[["ew"]],
|
||||
text = if (inkonsistent) "(zugehöriges Freitextfeld ist leer)" else ew_text
|
||||
))
|
||||
}
|
||||
list(
|
||||
rang = i, code = code, vorhanden = TRUE, inkonsistent = TRUE,
|
||||
bereich = NA_character_, bereich_name = "k. A.",
|
||||
text = paste0("Unbekannter Code: ", code)
|
||||
)
|
||||
})
|
||||
|
||||
# Abschnitt 6, Schritt 6: wichtigste Wertebereiche (Block B2).
|
||||
rang_bereich = lapply(1:3, function(i) {
|
||||
feld = paste0("vds33_rang_bereich_", i)
|
||||
if (!(feld %in% names(zeile))) return(list(rang = i, vorhanden = FALSE))
|
||||
code = vds33_resolve_select_one_code(daten[[feld]], zeile[[feld]], "^(wf[1-7]|aw|ew)$")
|
||||
if (is.na(code)) return(list(rang = i, vorhanden = FALSE))
|
||||
bereich_name = if (code %in% names(bereich_labels)) bereich_labels[[code]] else code
|
||||
list(rang = i, code = code, vorhanden = TRUE, bereich_name = bereich_name)
|
||||
})
|
||||
|
||||
# Abschnitt 6, Schritt 7: Ja/Nein-Selbsteinschätzung je Bereich (deskriptiv).
|
||||
janein = sapply(VDS33_BEREICHE_ALLE, function(b) {
|
||||
feld = paste0("vds33_", b, "_janein")
|
||||
if (!(feld %in% names(zeile))) return(NA_character_)
|
||||
vds33_resolve_label(daten[[feld]], zeile[[feld]])
|
||||
})
|
||||
|
||||
# Abschnitt 6, Schritt 8: Block C, 14 Items, rein deskriptiv.
|
||||
block_c = lapply(1:14, function(i) {
|
||||
feld = paste0("vds33_c", sprintf("%02d", i))
|
||||
label_text = if (feld %in% names(zeile)) vds33_resolve_label(daten[[feld]], zeile[[feld]]) else NA_character_
|
||||
list(
|
||||
nr = i,
|
||||
code = paste0("u", i),
|
||||
item_text = if (feld %in% names(daten)) vds33_get_var_label(daten[[feld]], feld) else feld,
|
||||
stufe = vds33_stufe_aus_label(label_text)
|
||||
)
|
||||
})
|
||||
u_texte = setNames(sapply(block_c, function(x) x$item_text), sapply(block_c, function(x) x$code))
|
||||
|
||||
# Abschnitt 6, Schritt 9: Block D.
|
||||
d1 = lapply(1:2, function(i) {
|
||||
feld = paste0("vds33_d1_wahl_", i)
|
||||
if (!(feld %in% names(zeile))) return(list(rang = i, vorhanden = FALSE))
|
||||
code = vds33_resolve_select_one_code(daten[[feld]], zeile[[feld]], "^u[0-9]{1,2}$")
|
||||
if (is.na(code)) return(list(rang = i, vorhanden = FALSE))
|
||||
text = if (code %in% names(u_texte)) unname(u_texte[[code]]) else paste0("Unbekannter Code: ", code)
|
||||
list(rang = i, code = code, vorhanden = TRUE, text = text)
|
||||
})
|
||||
d2_text = vds33_text_feld(zeile, "vds33_d2_text")
|
||||
d3_text = vds33_text_feld(zeile, "vds33_d3_text")
|
||||
|
||||
list(
|
||||
typ = "erfolg",
|
||||
chiffre = chiffre,
|
||||
ausfuelldatum = ausfuelldatum,
|
||||
mehrfach_warnung = mehrfach_warnung,
|
||||
pct = pct,
|
||||
top3 = top3,
|
||||
rang_wert = rang_wert,
|
||||
rang_bereich = rang_bereich,
|
||||
janein = janein,
|
||||
block_c = block_c,
|
||||
d1 = d1,
|
||||
d2_text = d2_text,
|
||||
d3_text = d3_text
|
||||
)
|
||||
})
|
||||
|
||||
vds33_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_vds33' oder 'pseudo'.",
|
||||
"chiffre_nicht_gefunden" = paste0("Chiffre '", d$chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden."),
|
||||
"kein_treffer" = paste0("Kein VDS33-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", vds33_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)
|
||||
|
||||
top3_ui = lapply(d$top3, function(t) {
|
||||
div(class = "kontext-zeile",
|
||||
div(class = "kontext-label", paste0(t$rang, ":")),
|
||||
div(t$text)
|
||||
)
|
||||
})
|
||||
|
||||
legende_ui = lapply(VDS33_BEREICHE_ALLE, function(b) {
|
||||
div(class = "legende-zeile",
|
||||
span(class = "legende-kurz", bereich_kurz[[b]]),
|
||||
span(class = "legende-text", bereich_labels[[b]])
|
||||
)
|
||||
})
|
||||
|
||||
karte_profil = div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Werteprofil"),
|
||||
div(class = "meta-block",
|
||||
tags$strong("Chiffre: "), d$chiffre,
|
||||
tags$span(" | ", style = "color:#ccc;"),
|
||||
tags$strong("Ausfülldatum: "), format(d$ausfuelldatum, "%d.%m.%Y")
|
||||
),
|
||||
div(class = "ipsativ-hinweis",
|
||||
"Rein ipsatives Werteprofil ohne Normwerte und ohne klinischen Cutoff. ",
|
||||
"Dargestellt wird ausschließlich der relative Vergleich der 9 Wertebereiche zueinander."),
|
||||
plotOutput("profil_plot", height = "280px"),
|
||||
div(class = "legende-liste", legende_ui),
|
||||
tags$hr(),
|
||||
div(top3_ui)
|
||||
)
|
||||
|
||||
rang_wert_ui = lapply(d$rang_wert, function(r) {
|
||||
if (!isTRUE(r$vorhanden)) return(NULL)
|
||||
tagList(
|
||||
div(class = "item-zeile",
|
||||
div(class = "item-nr", paste0(r$rang, ".")),
|
||||
div(class = "item-text", r$text),
|
||||
span(class = "stufe-badge", r$bereich_name)
|
||||
),
|
||||
if (isTRUE(r$inkonsistent)) div(class = "hinweis-inkonsistenz hinweis-klein",
|
||||
"Hinweis: Rangplatz verweist auf ein leeres eigenes-Werte-Freitextfeld.")
|
||||
)
|
||||
})
|
||||
|
||||
karte_einzelwerte = div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Wichtigste Einzelwerte"),
|
||||
div(rang_wert_ui)
|
||||
)
|
||||
|
||||
rang_bereich_ui = lapply(d$rang_bereich, function(r) {
|
||||
if (!isTRUE(r$vorhanden)) return(NULL)
|
||||
div(class = "item-zeile",
|
||||
div(class = "item-nr", paste0(r$rang, ".")),
|
||||
div(class = "item-text", r$bereich_name)
|
||||
)
|
||||
})
|
||||
|
||||
karte_wertebereiche = div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Wichtigste Wertebereiche"),
|
||||
div(rang_bereich_ui)
|
||||
)
|
||||
|
||||
janein_zeilen = lapply(VDS33_BEREICHE_ALLE, function(b) {
|
||||
tags$tr(
|
||||
tags$td(bereich_labels[[b]]),
|
||||
tags$td(if (is.na(d$janein[[b]])) "k. A." else d$janein[[b]])
|
||||
)
|
||||
})
|
||||
|
||||
karte_janein = div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Selbsteinschätzung je Bereich"),
|
||||
div(class = "hinweis-klein",
|
||||
"Rein deskriptiv - fließt nicht in die Prozentwerte des Werteprofils ein."),
|
||||
tags$table(class = "tabelle-standard",
|
||||
tags$thead(tags$tr(tags$th("Bereich"), tags$th("Insgesamt wichtig?"))),
|
||||
tags$tbody(janein_zeilen)
|
||||
)
|
||||
)
|
||||
|
||||
block_c_ui = lapply(d$block_c, function(it) {
|
||||
badge_klasse = if (is.na(it$stufe)) "stufe-badge" else paste0("stufe-badge stufe-badge-", it$stufe)
|
||||
div(class = "item-zeile",
|
||||
div(class = "item-nr", paste0(it$nr, ".")),
|
||||
div(class = "item-text", it$item_text),
|
||||
span(class = badge_klasse, if (is.na(it$stufe)) "k. A." else paste0(it$stufe, " / 3"))
|
||||
)
|
||||
})
|
||||
|
||||
karte_block_c = div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "14 Items"),
|
||||
div(class = "hinweis-klein", "Rein deskriptive Auflistung, keine Aggregation, kein Summenscore."),
|
||||
div(block_c_ui)
|
||||
)
|
||||
|
||||
d1_ui = lapply(d$d1, function(r) {
|
||||
if (!isTRUE(r$vorhanden)) return(NULL)
|
||||
div(class = "item-zeile",
|
||||
div(class = "item-nr", paste0(r$rang, ".")),
|
||||
div(class = "item-text", r$text)
|
||||
)
|
||||
})
|
||||
|
||||
karte_block_d = div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Umgang mit diesen Themen"),
|
||||
div(d1_ui),
|
||||
if (!is.na(d$d2_text)) tagList(
|
||||
tags$div(class = "abschnitt-untertitel", "Freitext (D.2)"),
|
||||
div(class = "freitext-zitat", style = "margin-left: 0;", d$d2_text)
|
||||
),
|
||||
if (!is.na(d$d3_text)) tagList(
|
||||
tags$div(class = "abschnitt-untertitel", "Freitext (D.3)"),
|
||||
div(class = "freitext-zitat", style = "margin-left: 0;", d$d3_text)
|
||||
),
|
||||
div(class = "disclaimer-zeile", VDS33_DISCLAIMER)
|
||||
)
|
||||
|
||||
tagList(karte_profil, karte_einzelwerte, karte_wertebereiche, karte_janein, karte_block_c, karte_block_d)
|
||||
})
|
||||
|
||||
output$profil_plot = renderPlot({
|
||||
req(input$btn_suchen)
|
||||
d = ergebnis()
|
||||
req(d$typ == "erfolg")
|
||||
make_vds33_profil_plot(d$pct)
|
||||
}, 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), "%Y%m%d"),
|
||||
error = function(e) format(Sys.Date(), "%Y%m%d"))
|
||||
} else {
|
||||
format(Sys.Date(), "%Y%m%d")
|
||||
}
|
||||
paste0("VDS33_", 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_vds33_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)
|
||||
Loading…
Add table
Add a link
Reference in a new issue