777 lines
30 KiB
R
777 lines
30 KiB
R
# Präambel ####
|
||
|
||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_vds27.R" # liefert: daten_vds27
|
||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo
|
||
AKZENT_FARBE = "#8B2635"
|
||
|
||
VDS27_DISCLAIMER = paste0(
|
||
"Diese Auswertung ist ein Hilfsmittel für klinisches Fachpersonal und ersetzt ",
|
||
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person."
|
||
)
|
||
|
||
VDS27_LANGFORM_HINWEIS = paste0(
|
||
"Dieser Fragebogen erfasst die 21 Kernitems der Bedürfnisdiagnostik. Für eine vertiefte ",
|
||
"Exploration einzelner Bedürfnisbereiche (eigener Umgang, Reaktion der Bezugspersonen, ",
|
||
"Therapieziel) verweisen wir auf die ausführliche Papier-Langform."
|
||
)
|
||
|
||
# Farbverlauf gruen -> dunkelrot ueber die 6 Antwortstufen 0-5, wie in der
|
||
# Referenzimplementierung pg13r/app.R (dort 5 Stufen 0-4).
|
||
VDS27_BADGE_FARBEN = c(
|
||
"0" = "#4CAF50",
|
||
"1" = "#8BC34A",
|
||
"2" = "#FFB74D",
|
||
"3" = "#EF5350",
|
||
"4" = "#B71C1C",
|
||
"5" = "#4A0000"
|
||
)
|
||
VDS27_BADGE_TEXT_FARBEN = c(
|
||
"0" = "white",
|
||
"1" = "#333333",
|
||
"2" = "#333333",
|
||
"3" = "white",
|
||
"4" = "white",
|
||
"5" = "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 ####
|
||
|
||
# Score (0-5) je Item wird IMMER aus dem Klartext des Labels abgeleitet, nie aus
|
||
# dem rohen numerischen Code selbst - fuer den formr-Itemtyp "mc" ist das
|
||
# Exportformat in dieser Installation NICHT verifiziert (siehe Spezifikation).
|
||
# Deckt defensiv drei moegliche Faelle ab, der Reihe nach geprueft:
|
||
# (a) haven-labelled: Code + labels-Attribut, Klartext (z.B. "3 = deutlich")
|
||
# steht in den NAMEN von labels - fuehrende Ziffer daraus lesen
|
||
# (b) Klartext bereits direkt als String im Rohwert, z.B. "3 = deutlich"
|
||
# (c) UNGEPRUEFTER Fall: Rohwert ist bereits die nackte Zahl 0-5 ohne Label
|
||
extrahiere_score = function(spalte_voll, wert_roh) {
|
||
if (is.null(wert_roh) || length(wert_roh) == 0 || is.na(wert_roh[1])) return(NA_real_)
|
||
wert_roh = wert_roh[1]
|
||
|
||
labels_attr = attr(spalte_voll, "labels")
|
||
ist_labelled = haven::is.labelled(spalte_voll) || !is.null(labels_attr)
|
||
|
||
if (ist_labelled) {
|
||
if (!is.null(labels_attr) && length(labels_attr) > 0) {
|
||
treffer = which(as.numeric(labels_attr) == as.numeric(unclass(wert_roh)))
|
||
if (length(treffer) > 0) {
|
||
label_text = names(labels_attr)[treffer[1]]
|
||
ziffer = sub("^\\s*(\\d+).*", "\\1", trimws(label_text))
|
||
if (grepl("^\\d+$", ziffer)) return(as.numeric(ziffer))
|
||
}
|
||
}
|
||
return(NA_real_)
|
||
}
|
||
|
||
if (is.character(wert_roh) && grepl("^\\s*\\d+\\s*=", wert_roh)) {
|
||
ziffer = sub("^\\s*(\\d+).*", "\\1", trimws(wert_roh))
|
||
return(as.numeric(ziffer))
|
||
}
|
||
|
||
# Fall (c), UNGEPRUEFT: Rohwert evtl. bereits die nackte Zahl 0-5.
|
||
wert_num = suppressWarnings(as.numeric(wert_roh))
|
||
if (!is.na(wert_num) && wert_num >= 0 && wert_num <= 5) return(wert_num)
|
||
|
||
NA_real_
|
||
}
|
||
|
||
# Entfernt escapte Backslashes vor Satzzeichen in Item-/Choicetexten (Artefakt
|
||
# aus der xlsx-Formularerstellung, z.B. "1\\. Willkommensein" -> "1. Willkommensein",
|
||
# bestaetigt im ersten produktiven Testlauf: sowohl bei den Itemtexten selbst
|
||
# als auch bei den Rangfolge-Choicetexten vorhanden). fixed = TRUE, da ein
|
||
# woertlicher Backslash entfernt werden soll, kein Regex-Sonderzeichen.
|
||
vds27_text_bereinigen = function(x) {
|
||
if (is.na(x)) return(NA_character_)
|
||
gsub("\\", "", x, fixed = TRUE)
|
||
}
|
||
|
||
# Itemtext aus dem formr "label"-Attribut der Spalte (Fragetext) gelesen, nicht
|
||
# statisch im App-Code hinterlegt - fuer VDS27 liegen keine verifizierten
|
||
# Itemtexte vor, die als Konstante uebernommen werden koennten. Wird durch
|
||
# vds27_text_bereinigen() von den escapten Backslashes befreit (siehe oben).
|
||
vds27_item_label = function(spalte, fallback) {
|
||
lbl = attr(spalte, "label")
|
||
if (is.null(lbl) || length(lbl) == 0 || is.na(lbl[1]) || trimws(lbl[1]) == "") return(fallback)
|
||
vds27_text_bereinigen(trimws(as.character(lbl[1])))
|
||
}
|
||
|
||
# Klartext eines select_one-Rangfolgefeldes. Deckt beide plausiblen
|
||
# Exportrichtungen ab: numerischer/interner Code mit Klartext in den NAMEN von
|
||
# labels, oder ein Zeichenkettencode, dessen Klartext im WERT von labels
|
||
# steht. Nicht zuordenbare Rohwerte werden als NA behandelt, nicht geraten.
|
||
vds27_wahl_text = function(spalte_voll, wert_roh) {
|
||
if (is.null(wert_roh) || length(wert_roh) == 0 || is.na(wert_roh[1])) return(NA_character_)
|
||
wert_roh = wert_roh[1]
|
||
|
||
lab = attr(spalte_voll, "labels")
|
||
klartext = NA_character_
|
||
if (!is.null(lab) && length(lab) > 0) {
|
||
wert_chr = trimws(as.character(unclass(wert_roh)))
|
||
if (is.character(lab) && !is.null(names(lab)) && wert_chr %in% names(lab)) {
|
||
klartext = unname(lab[[wert_chr]])
|
||
} else {
|
||
pos = which(as.character(unclass(as.vector(lab))) == wert_chr)
|
||
if (length(pos) > 0) klartext = names(lab)[pos[1]]
|
||
}
|
||
} else if (is.character(wert_roh)) {
|
||
klartext = wert_roh
|
||
} else {
|
||
klartext = as.character(wert_roh)
|
||
}
|
||
if (is.na(klartext) || trimws(klartext) == "") return(NA_character_)
|
||
vds27_text_bereinigen(trimws(klartext))
|
||
}
|
||
|
||
# Inline-CSS fuer den Item-Score-Badge, Farbe nach VDS27_BADGE_FARBEN (siehe
|
||
# Praeambel). Score wird auf 0-5 begrenzt/gerundet, falls er aus irgendeinem
|
||
# Grund ausserhalb der erwarteten Skala liegt. Fehlende Werte (NA) erhalten
|
||
# ein neutrales Grau statt einer Stufenfarbe.
|
||
vds27_badge_style = function(score) {
|
||
if (is.na(score)) return("background-color:#E0E0E0; color:#555555;")
|
||
k = as.character(max(0L, min(5L, as.integer(round(score)))))
|
||
paste0("background-color:", VDS27_BADGE_FARBEN[[k]], "; color:", VDS27_BADGE_TEXT_FARBEN[[k]], ";")
|
||
}
|
||
|
||
# Faktor-Mittelwert (0-5), reine Mittelwertbildung ohne Summenscore, Umpolung
|
||
# oder Gewichtung. NA-Items werden aus Summe UND Anzahl-Divisor ausgeschlossen,
|
||
# statt still mit einem verfaelschten Mittelwert weiterzurechnen.
|
||
vds27_faktor_auswerten = function(werte) {
|
||
vorhanden = !is.na(werte)
|
||
n_vorhanden = sum(vorhanden)
|
||
n_gesamt = length(werte)
|
||
rohsumme = if (n_vorhanden > 0) sum(werte[vorhanden]) else NA_real_
|
||
mittelwert = if (n_vorhanden > 0) rohsumme / n_vorhanden else NA_real_
|
||
list(rohsumme = rohsumme, mittelwert = mittelwert, n_vorhanden = n_vorhanden, n_gesamt = n_gesamt)
|
||
}
|
||
|
||
# Profilwert (0-3-Skala) nur fuer die Diagrammachse - reine Darstellungskonvention
|
||
# analog zur VDS24-App, keine im VDS27-Originaldokument enthaltene Formel.
|
||
vds27_profilwert = function(mittelwert) mittelwert * 3 / 5
|
||
|
||
# Profildiagramm: 6 Faktoren, Skala 0-3 (Profilwert), Beschriftung zeigt
|
||
# zusaetzlich den rohen Mittelwert (0-5). Kein Cutoff, keine Farbzonen - fuer
|
||
# dieses Instrument liegen keine Normwerte vor.
|
||
vds27_profil_plot = function(profil_df) {
|
||
profil_df$faktor = factor(profil_df$faktor, levels = rev(FAKTOR_REIHENFOLGE))
|
||
profil_df$y_balken = ifelse(is.na(profil_df$profilwert), 0, profil_df$profilwert)
|
||
profil_df$beschriftung = ifelse(
|
||
is.na(profil_df$mittelwert), "k. A.",
|
||
paste0(format(round(profil_df$mittelwert, 1), nsmall = 1), " / 5")
|
||
)
|
||
|
||
ggplot(profil_df, aes(x = faktor, y = y_balken)) +
|
||
geom_col(fill = AKZENT_FARBE, width = 0.6) +
|
||
geom_text(aes(label = beschriftung), hjust = -0.12, size = 4, color = "#333333") +
|
||
coord_flip(clip = "off") +
|
||
scale_y_continuous(limits = c(0, 3.6), breaks = 0:3) +
|
||
labs(x = NULL, y = "Profilwert (0–3), entspricht Faktor-Mittelwert × 3/5") +
|
||
theme_minimal(base_size = 12) +
|
||
theme(
|
||
panel.grid.minor = element_blank(),
|
||
axis.text.y = element_text(face = "bold", color = "#333333"),
|
||
plot.margin = margin(t = 5, r = 40, b = 5, l = 5)
|
||
)
|
||
}
|
||
|
||
|
||
# Datenaufbereitung ####
|
||
|
||
FAKTOR_REIHENFOLGE = c("BINDUNG", "SELBSTWERT", "AUTONOMIE", "ORIENTIERUNG", "IDENTITÄT", "HOMÖOSTASE")
|
||
|
||
VDS27_ITEMS = data.frame(
|
||
nr = c(as.character(1:14), paste0("H", 1:7)),
|
||
feld = c(paste0("vds27_", sprintf("%02d", 1:14)), paste0("vds27_h", 1:7)),
|
||
faktor = c(rep("BINDUNG", 4), rep("SELBSTWERT", 3), rep("AUTONOMIE", 2),
|
||
rep("ORIENTIERUNG", 3), rep("IDENTITÄT", 2), rep("HOMÖOSTASE", 7)),
|
||
stringsAsFactors = FALSE
|
||
)
|
||
|
||
# Kontrollsumme: 4 + 3 + 2 + 3 + 2 + 7 = 21 Items. Bei Abweichung sofort
|
||
# abbrechen statt still mit einer falschen Tabelle weiterzurechnen (Schutz vor
|
||
# Copy-Paste-Fehlern in der Struktur oben).
|
||
.vds27_kontrollsumme = nrow(VDS27_ITEMS)
|
||
if (.vds27_kontrollsumme != 21) {
|
||
stop("VDS27: Item-Faktor-Tabelle hat ", .vds27_kontrollsumme, " Zeilen, erwartet 21.")
|
||
}
|
||
.vds27_faktor_counts = table(factor(VDS27_ITEMS$faktor, levels = FAKTOR_REIHENFOLGE))
|
||
.vds27_counts_erwartet = setNames(c(4, 3, 2, 3, 2, 7), FAKTOR_REIHENFOLGE)
|
||
if (!identical(as.integer(.vds27_faktor_counts[FAKTOR_REIHENFOLGE]), as.integer(.vds27_counts_erwartet))) {
|
||
stop("VDS27: Itemanzahl je Faktor weicht von der Spezifikation ab. Bitte VDS27_ITEMS prüfen.")
|
||
}
|
||
|
||
# Rangfolge-Felder (formr-Typ select_one), rein deskriptiv - fliessen NICHT in
|
||
# die Faktor-Mittelwerte ein.
|
||
VDS27_RANG_FELDER = list(
|
||
list(titel = "Block A – 1. Priorität (Bindung/Selbstwert)",
|
||
feld = "vds27_rang_a1_wahl"),
|
||
list(titel = "Block A – 2. Priorität (Bindung/Selbstwert)",
|
||
feld = "vds27_rang_a2_wahl"),
|
||
list(titel = "Block B – 1. Priorität (Autonomie/Orientierung/Identität)",
|
||
feld = "vds27_rang_b1_wahl"),
|
||
list(titel = "Block B – 2. Priorität (Autonomie/Orientierung/Identität)",
|
||
feld = "vds27_rang_b2_wahl"),
|
||
list(titel = "Gesamt Block A+B (Items 1–14) – wichtigstes Bedürfnis",
|
||
feld = "vds27_rang_b_gesamt_wahl"),
|
||
list(titel = "Block C – 1. Priorität (Homöostase)",
|
||
feld = "vds27_rang_c1_wahl"),
|
||
list(titel = "Block C – 2. Priorität (Homöostase)",
|
||
feld = "vds27_rang_c2_wahl"),
|
||
list(titel = "Gesamt (Items 1–14 und H1–H7) – wichtigstes Bedürfnis",
|
||
feld = "vds27_rang_c_gesamt_wahl")
|
||
)
|
||
|
||
|
||
# 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; }
|
||
.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; }
|
||
.item-wert {
|
||
border-radius: 4px;
|
||
padding: 2px 9px; font-weight: 700; font-size: 0.82em;
|
||
white-space: nowrap; display: inline-block; flex-shrink: 0;
|
||
}
|
||
.faktor-tabelle { width: 100%; border-collapse: collapse; margin-top: 10px; }
|
||
.faktor-tabelle th, .faktor-tabelle td {
|
||
text-align: left; padding: 6px 10px; border-bottom: 1px solid #eee; font-size: 0.93em;
|
||
}
|
||
.faktor-tabelle th { color: #8B2635; border-bottom: 2px solid #8B2635; }
|
||
.freitext-block { margin-bottom: 12px; }
|
||
.freitext-block:last-child { margin-bottom: 0; }
|
||
.freitext-frage { font-weight: 600; color: #8B2635; font-size: 0.93em; margin-bottom: 3px; }
|
||
.freitext-antwort { color: #333; font-size: 0.93em; }
|
||
.hinweis-langform {
|
||
background: #F5F5F5; border-left: 5px solid #8B2635; border-radius: 4px;
|
||
padding: 12px 16px; margin-bottom: 16px; color: #444; font-size: 0.9em; line-height: 1.5;
|
||
}
|
||
.hinweis-rang {
|
||
font-size: 0.82em; color: #777; font-style: italic;
|
||
margin-bottom: 12px; border-bottom: 1px dashed #ddd; padding-bottom: 8px;
|
||
}
|
||
.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("VDS27 – Zentrale Bedürfnisse / Grundbedürfnisse"),
|
||
tags$p("21 Ratingitems, 6 Bedürfnisbereiche, kein Summenscore, keine Normwerte")
|
||
),
|
||
|
||
div(class = "container-fluid",
|
||
|
||
div(class = "input-panel",
|
||
div(style = "min-width: 360px; white-space: nowrap;",
|
||
textInput("pseudonym",
|
||
label = tagList(
|
||
"Pseudonym",
|
||
tags$span(style = "font-weight: normal; font-style: italic; font-size: 0.78em; color: #888; margin-left: 4px; white-space: nowrap;",
|
||
"optional, hat Vorrang vor Chiffre")
|
||
),
|
||
placeholder = "optional", width = "340px")
|
||
),
|
||
div(style = "min-width: 200px;",
|
||
textInput("chiffre", label = "Patientenchiffre",
|
||
placeholder = "z.B. P000123", width = "100%")
|
||
),
|
||
actionButton("btn_suchen", "Auswerten", class = "btn btn-primary btn-laden"),
|
||
div(style = "margin-left: auto;",
|
||
downloadButton("download_word", "Word-Export (.docx)")
|
||
)
|
||
),
|
||
|
||
uiOutput("fehler_ui"),
|
||
uiOutput("warnung_ui"),
|
||
uiOutput("ergebnis_ui")
|
||
)
|
||
)
|
||
|
||
|
||
# Word-Export ####
|
||
|
||
erstelle_vds27_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")
|
||
|
||
# Score-Badge im gleichen Gruen->Dunkelrot-Verlauf wie in der UI (siehe
|
||
# vds27_badge_style), analog zur Referenzimplementierung pg13r/app.R.
|
||
vds27_fp_badge = function(score) {
|
||
if (is.na(score)) return(fp_text(color = "#555555", bold = TRUE, shading.color = "#E0E0E0", font.size = 10))
|
||
k = as.character(max(0L, min(5L, as.integer(round(score)))))
|
||
fp_text(color = VDS27_BADGE_TEXT_FARBEN[[k]], bold = TRUE,
|
||
shading.color = VDS27_BADGE_FARBEN[[k]], font.size = 10)
|
||
}
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("VDS27 – Zentrale Bedürfnisse / Grundbedürfnisse", 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("Profil der 6 Bedürfnisbereiche", fp_abschnitt)))
|
||
|
||
profil_img = tempfile(fileext = ".png")
|
||
ggsave(profil_img, plot = vds27_profil_plot(erg$profil_df), width = 7, height = 4, dpi = 150, bg = "white")
|
||
doc = body_add_img(doc, src = profil_img, width = 6, height = 3.4)
|
||
file.remove(profil_img)
|
||
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
faktor_tabelle_df = data.frame(
|
||
Faktor = sapply(erg$faktor_ergebnisse, function(fe) fe$faktor),
|
||
Itemanzahl = sapply(erg$faktor_ergebnisse, function(fe) fe$n_gesamt),
|
||
`Mittelwert (0-5)` = sapply(erg$faktor_ergebnisse, function(fe) if (is.na(fe$mittelwert)) "–" else format(round(fe$mittelwert, 2), nsmall = 2)),
|
||
`Profilwert (0-3)` = sapply(erg$faktor_ergebnisse, function(fe) if (is.na(fe$mittelwert)) "–" else format(round(vds27_profilwert(fe$mittelwert), 2), nsmall = 2)),
|
||
check.names = FALSE, stringsAsFactors = FALSE
|
||
)
|
||
doc = body_add_table(doc, faktor_tabelle_df)
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
for (fe in erg$faktor_ergebnisse) {
|
||
doc = body_add_fpar(doc, fpar(ftext(fe$faktor, fp_abschnitt)))
|
||
if (!is.na(fe$mittelwert) && fe$n_vorhanden < fe$n_gesamt) {
|
||
doc = body_add_fpar(doc, fpar(ftext(
|
||
paste0("Faktor-Score basiert auf ", fe$n_vorhanden, " von ", fe$n_gesamt, " Items."),
|
||
fp_text(font.size = 9.5, italic = TRUE, color = "#BF360C")
|
||
)))
|
||
}
|
||
for (r in seq_len(nrow(fe$items))) {
|
||
zeile = fe$items[r, ]
|
||
wert_txt = if (is.na(zeile$score)) "k. A." else paste0(zeile$score, " / 5")
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext(paste0(zeile$nr, ". ", zeile$itemtext, " "), fp_normal),
|
||
ftext(paste0(" ", wert_txt, " "), vds27_fp_badge(zeile$score))
|
||
))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
}
|
||
|
||
doc = body_add_break(doc)
|
||
doc = body_add_fpar(doc, fpar(ftext("Rangfolge (deskriptiv)", fp_abschnitt)))
|
||
doc = body_add_fpar(doc, fpar(ftext(
|
||
"Durch die Patientin/den Patienten angegeben, rein deskriptiv, fließt nicht in die Faktor-Mittelwerte ein.",
|
||
fp_text(font.size = 9.5, italic = TRUE, color = "#777777")
|
||
)))
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
for (rg in erg$rang_ergebnisse) {
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext(paste0(rg$titel, ": "), fp_label),
|
||
ftext(if (is.na(rg$wert)) "keine Angabe" else rg$wert, fp_normal)
|
||
))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Hinweis zur Langform", fp_label)))
|
||
doc = body_add_fpar(doc, fpar(ftext(VDS27_LANGFORM_HINWEIS, fp_normal)))
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext(VDS27_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 = eventReactive(input$btn_suchen, {
|
||
|
||
chiffre = toupper(trimws(input$chiffre))
|
||
|
||
if (nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0) {
|
||
return(list(typ = "leere_eingabe", meldung = "Bitte Chiffre oder Pseudonym eingeben."))
|
||
}
|
||
if (nchar(trimws(input$pseudonym)) == 0 && !grepl("^[A-Z][0-9]{6}$", chiffre)) {
|
||
return(list(typ = "format_fehler", chiffre = chiffre))
|
||
}
|
||
|
||
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = paste0("Download-Skript nicht gefunden:\n", PFAD_DOWNLOAD_SKRIPT)))
|
||
}
|
||
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = paste0("Pseudonym-Skript nicht gefunden:\n", PFAD_PSEUDONYM_SKRIPT)))
|
||
}
|
||
|
||
# Schritt 1: Download-Skript sourcen
|
||
ok_dl = tryCatch({
|
||
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
|
||
list(ok = TRUE)
|
||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||
if (!ok_dl$ok) return(list(typ = "skript_fehler", meldung = ok_dl$msg))
|
||
|
||
# Schritt 2: pseudonyme.db suchen (bis zu 5 Ebenen ueber dem Pseudonym-Skript)
|
||
db_ordner = local({
|
||
ordner = dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE))
|
||
gefunden = NULL
|
||
for (i in 1:5) {
|
||
if (file.exists(file.path(ordner, "pseudonyme.db"))) { gefunden = ordner; break }
|
||
elternteil = dirname(ordner)
|
||
if (elternteil == ordner) break
|
||
ordner = elternteil
|
||
}
|
||
gefunden
|
||
})
|
||
if (is.null(db_ordner)) return(list(typ = "db_nicht_gefunden"))
|
||
|
||
# Schritt 3: Pseudonym-Skript sourcen (relativer DB-Zugriff, daher setwd + on.exit)
|
||
alter_wd = getwd()
|
||
on.exit(setwd(alter_wd), add = TRUE)
|
||
setwd(db_ordner)
|
||
ok_ps = tryCatch({
|
||
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
|
||
list(ok = TRUE)
|
||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||
if (!ok_ps$ok) return(list(typ = "skript_fehler", meldung = ok_ps$msg))
|
||
|
||
if (!exists("daten_vds27", envir = .GlobalEnv) || !exists("pseudo", envir = .GlobalEnv)) {
|
||
return(list(typ = "daten_fehlen"))
|
||
}
|
||
|
||
daten = get("daten_vds27", envir = .GlobalEnv)
|
||
pseudo_df = get("pseudo", envir = .GlobalEnv)
|
||
|
||
# Bei Bedarf zur Diagnose aktivieren (zeigt das tatsaechliche Exportformat
|
||
# der mc-Item-Spalten in der R-Konsole):
|
||
# print(str(daten$vds27_01))
|
||
|
||
if (!("session" %in% names(daten))) {
|
||
return(list(typ = "daten_fehlen",
|
||
meldung = "Erwartete Spalte 'session' nicht in 'daten_vds27' gefunden."))
|
||
}
|
||
|
||
# Schritt 4: Chiffre-Rueckaufloesung, falls Pseudonym eingegeben wurde
|
||
if (nchar(trimws(input$pseudonym)) > 0) {
|
||
pw_treffer = pseudo_df[pseudo_df$pseudonym == trimws(input$pseudonym), ]
|
||
if (nrow(pw_treffer) > 0) chiffre = toupper(trimws(pw_treffer$chiffre[1]))
|
||
}
|
||
|
||
# Schritt 5: Chiffre -> moegliche Pseudonyme (Session-IDs)
|
||
treffer_ps = pseudo_df[toupper(trimws(pseudo_df$chiffre)) == chiffre, ]
|
||
if (nrow(treffer_ps) == 0) return(list(typ = "chiffre_nicht_gefunden", chiffre = chiffre))
|
||
|
||
alle_session_ids = unique(treffer_ps$pseudonym)
|
||
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
|
||
|
||
# Schritt 6: passende Datensaetze in daten_vds27 finden
|
||
treffer_daten = daten[daten$session %in% alle_session_ids, ]
|
||
if (nrow(treffer_daten) == 0) return(list(typ = "keine_daten", chiffre = chiffre))
|
||
|
||
mehrfach_warnung = NULL
|
||
if (nrow(treffer_daten) > 1) {
|
||
n = nrow(treffer_daten)
|
||
if ("created" %in% names(treffer_daten)) {
|
||
treffer_daten = treffer_daten[order(treffer_daten$created, decreasing = TRUE), ]
|
||
}
|
||
treffer_daten = treffer_daten[1, , drop = FALSE]
|
||
mehrfach_warnung = paste0(
|
||
"Mehrere Ausfüllungen gefunden (", n, " Einträge) – es wird die neueste angezeigt."
|
||
)
|
||
}
|
||
zeile = treffer_daten[1, , drop = FALSE]
|
||
|
||
ausfuelldatum = tryCatch(
|
||
format(as.POSIXct(zeile[["created"]][1]), "%d.%m.%Y"),
|
||
error = function(e) format(Sys.Date(), "%d.%m.%Y")
|
||
)
|
||
|
||
# Schritt 7: Faktor-Auswertung
|
||
faktor_ergebnisse = lapply(FAKTOR_REIHENFOLGE, function(fname) {
|
||
idx = which(VDS27_ITEMS$faktor == fname)
|
||
items_df = do.call(rbind, lapply(idx, function(i) {
|
||
feld = VDS27_ITEMS$feld[i]
|
||
spalte_voll = daten[[feld]]
|
||
wert_roh = if (feld %in% names(zeile)) zeile[[feld]][1] else NA
|
||
score = if (!is.null(spalte_voll)) extrahiere_score(spalte_voll, wert_roh) else NA_real_
|
||
itemtext = if (!is.null(spalte_voll))
|
||
vds27_item_label(spalte_voll, paste0("Item ", VDS27_ITEMS$nr[i]))
|
||
else
|
||
paste0("Item ", VDS27_ITEMS$nr[i])
|
||
data.frame(nr = VDS27_ITEMS$nr[i], feld = feld, itemtext = itemtext,
|
||
score = score, stringsAsFactors = FALSE)
|
||
}))
|
||
fs = vds27_faktor_auswerten(items_df$score)
|
||
c(list(faktor = fname, items = items_df), fs)
|
||
})
|
||
names(faktor_ergebnisse) = FAKTOR_REIHENFOLGE
|
||
|
||
profil_df = data.frame(
|
||
faktor = FAKTOR_REIHENFOLGE,
|
||
mittelwert = sapply(faktor_ergebnisse, function(fe) fe$mittelwert),
|
||
stringsAsFactors = FALSE
|
||
)
|
||
profil_df$profilwert = vds27_profilwert(profil_df$mittelwert)
|
||
|
||
# Schritt 8: Rangfolge-Felder (deskriptiv)
|
||
rang_ergebnisse = lapply(VDS27_RANG_FELDER, function(rf) {
|
||
spalte_voll = daten[[rf$feld]]
|
||
wert_roh = if (rf$feld %in% names(zeile)) zeile[[rf$feld]][1] else NA
|
||
wert_text = if (!is.null(spalte_voll)) vds27_wahl_text(spalte_voll, wert_roh) else NA_character_
|
||
list(titel = rf$titel, wert = wert_text)
|
||
})
|
||
|
||
list(
|
||
typ = "erfolg",
|
||
chiffre = chiffre,
|
||
ausfuelldatum = ausfuelldatum,
|
||
mehrfach_warnung = mehrfach_warnung,
|
||
faktor_ergebnisse = faktor_ergebnisse,
|
||
profil_df = profil_df,
|
||
rang_ergebnisse = rang_ergebnisse
|
||
)
|
||
})
|
||
|
||
vds27_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_vds27' oder 'pseudo'.",
|
||
"chiffre_nicht_gefunden" = paste0("Chiffre '", d$chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden."),
|
||
"keine_daten" = paste0("Kein VDS27-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", vds27_fehlermeldung(d))
|
||
})
|
||
|
||
output$warnung_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis()
|
||
if (d$typ != "erfolg") return(NULL)
|
||
if (!is.null(d$mehrfach_warnung)) div(class = "alert-warnung", d$mehrfach_warnung)
|
||
})
|
||
|
||
output$ergebnis_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis()
|
||
if (d$typ != "erfolg") return(NULL)
|
||
|
||
faktor_tabelle_zeilen = lapply(d$faktor_ergebnisse, function(fe) {
|
||
tags$tr(
|
||
tags$td(fe$faktor),
|
||
tags$td(fe$n_gesamt),
|
||
tags$td(if (is.na(fe$mittelwert)) "–" else format(round(fe$mittelwert, 2), nsmall = 2)),
|
||
tags$td(if (is.na(fe$mittelwert)) "–" else format(round(vds27_profilwert(fe$mittelwert), 2), nsmall = 2))
|
||
)
|
||
})
|
||
faktor_tabelle = tags$table(class = "faktor-tabelle",
|
||
tags$thead(tags$tr(
|
||
tags$th("Faktor"), tags$th("Itemanzahl"),
|
||
tags$th("Mittelwert (0–5)"), tags$th("Profilwert (0–3)")
|
||
)),
|
||
tags$tbody(faktor_tabelle_zeilen)
|
||
)
|
||
|
||
item_karten = lapply(d$faktor_ergebnisse, function(fe) {
|
||
items_ui = lapply(seq_len(nrow(fe$items)), function(r) {
|
||
zeile = fe$items[r, ]
|
||
div(class = "item-zeile",
|
||
div(class = "item-nr", paste0(zeile$nr, ".")),
|
||
div(class = "item-text", zeile$itemtext),
|
||
span(class = "item-wert", style = vds27_badge_style(zeile$score),
|
||
if (is.na(zeile$score)) "k. A." else paste0(zeile$score, " / 5"))
|
||
)
|
||
})
|
||
div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", fe$faktor),
|
||
if (!is.na(fe$mittelwert) && fe$n_vorhanden < fe$n_gesamt)
|
||
div(class = "alert-warnung",
|
||
paste0("Unvollständig ausgefüllt: Faktor-Score basiert auf ", fe$n_vorhanden,
|
||
" von ", fe$n_gesamt, " Items.")),
|
||
div(items_ui)
|
||
)
|
||
})
|
||
|
||
rang_ui = lapply(d$rang_ergebnisse, function(rg) {
|
||
div(class = "freitext-block",
|
||
div(class = "freitext-frage", rg$titel),
|
||
div(class = "freitext-antwort", if (is.na(rg$wert)) "keine Angabe" else rg$wert)
|
||
)
|
||
})
|
||
|
||
rang_karte = div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Rangfolge (deskriptiv)"),
|
||
div(class = "hinweis-rang",
|
||
"Durch die Patientin/den Patienten angegeben. Rein deskriptiv, fließt nicht in die Faktor-Mittelwerte ein."),
|
||
rang_ui
|
||
)
|
||
|
||
tagList(
|
||
div(class = "abschnitt-karte",
|
||
div(class = "meta-block",
|
||
tags$strong("Chiffre: "), d$chiffre,
|
||
tags$span(" | ", style = "color:#ccc;"),
|
||
tags$strong("Ausfülldatum: "), d$ausfuelldatum
|
||
)
|
||
),
|
||
div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Profil der 6 Bedürfnisbereiche"),
|
||
plotOutput("profil_plot", height = "340px"),
|
||
tags$hr(),
|
||
faktor_tabelle
|
||
),
|
||
item_karten,
|
||
rang_karte,
|
||
div(class = "hinweis-langform", VDS27_LANGFORM_HINWEIS),
|
||
div(class = "disclaimer-zeile", VDS27_DISCLAIMER)
|
||
)
|
||
})
|
||
|
||
output$profil_plot = renderPlot({
|
||
req(input$btn_suchen)
|
||
d = ergebnis()
|
||
req(d$typ == "erfolg")
|
||
vds27_profil_plot(d$profil_df)
|
||
}, 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("VDS27_", 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_vds27_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)
|