1091 lines
40 KiB
R
1091 lines
40 KiB
R
# Präambel ####
|
||
|
||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_edeq.R" # liefert beim Sourcen: daten_edeq
|
||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert beim Sourcen: pseudo
|
||
AKZENT_FARBE = "#8B2635"
|
||
|
||
EDEQ_DISCLAIMER = paste0(
|
||
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
|
||
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ",
|
||
"Die Einordnung gegen Referenzgruppen ist ein deskriptiver Vergleich, kein validierter Cutoff."
|
||
)
|
||
|
||
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 ####
|
||
|
||
# Ob formr bei mc-Items den Choice-TEXT oder eine haven-labelled (dbl+lbl) Spalte mit
|
||
# Zahlenwert+Label exportiert, ist fuer diese formr-Installation nicht gegen echte
|
||
# Exportdaten verifiziert. Beide Faelle werden hier robust abgedeckt.
|
||
hole_choice_text = function(spalte) {
|
||
if (haven::is.labelled(spalte)) {
|
||
return(as.character(haven::as_factor(spalte)))
|
||
}
|
||
return(as.character(spalte))
|
||
}
|
||
|
||
# Vereinheitlicht Gedankenstrich-Varianten und Umlaute fuer robuste Lookup-Vergleiche,
|
||
# da die xlsx-Choice-Texte lange Gedankenstriche ("–") verwenden.
|
||
normalisiere_text = function(text) {
|
||
text = gsub("[‐-―]", "-", text)
|
||
text = gsub("ä", "ae", text); text = gsub("ö", "oe", text); text = gsub("ü", "ue", text)
|
||
text = gsub("Ä", "Ae", text); text = gsub("Ö", "Oe", text); text = gsub("Ü", "Ue", text)
|
||
text = gsub("ß", "ss", text)
|
||
trimws(text)
|
||
}
|
||
|
||
recode_lookup = function(spalte, lookup_tabelle) {
|
||
text = normalisiere_text(hole_choice_text(spalte))
|
||
namen = normalisiere_text(names(lookup_tabelle))
|
||
werte = unname(lookup_tabelle)[match(text, namen)]
|
||
if (all(is.na(werte)) && !all(is.na(text))) {
|
||
warning("Keine der Choice-Texte konnte der Lookup-Tabelle zugeordnet werden - Item-Kodierung pruefen.")
|
||
}
|
||
as.numeric(werte)
|
||
}
|
||
|
||
recode_digit_prefix = function(spalte) {
|
||
text = trimws(hole_choice_text(spalte))
|
||
ziffer = regmatches(text, regexpr("^[0-6]", text))
|
||
fehlt = lengths(regmatches(text, gregexpr("^[0-6]", text))) == 0
|
||
ziffer[fehlt] = NA
|
||
as.numeric(ziffer)
|
||
}
|
||
|
||
lookup_tage = c(
|
||
"kein Tag" = 0, "1-5 Tage" = 1, "6-12 Tage" = 2, "13-15 Tage" = 3,
|
||
"16-22 Tage" = 4, "23-27 Tage" = 5, "jeden Tag" = 6
|
||
)
|
||
lookup_item20 = c(
|
||
"niemals" = 0, "in seltenen Faellen" = 1,
|
||
"in weniger als der Haelfte der Faelle" = 2, "in der Haelfte der Faelle" = 3,
|
||
"in mehr als der Haelfte der Faelle" = 4, "in den meisten Faellen" = 5,
|
||
"jedes Mal" = 6
|
||
)
|
||
|
||
# Rekodiert ein Item mit der angegebenen Methode ("tage", "item20", "digit_prefix").
|
||
# Liefert bei durchgaengig nicht auswertbarem Rohwert NA plus einen Warnhinweis, statt
|
||
# stillschweigend weiterzurechnen.
|
||
edeq_recode_item = function(spalte, methode) {
|
||
roh_leer = all(is.na(hole_choice_text(spalte)) | trimws(hole_choice_text(spalte)) == "")
|
||
wert = switch(methode,
|
||
"tage" = recode_lookup(spalte, lookup_tage),
|
||
"item20" = recode_lookup(spalte, lookup_item20),
|
||
"digit_prefix" = recode_digit_prefix(spalte),
|
||
stop("Unbekannte Recoding-Methode: ", methode)
|
||
)
|
||
list(wert = wert, unerwartet = is.na(wert) && !roh_leer)
|
||
}
|
||
|
||
edeq_finde_datumsspalte = function(daten, zeile) {
|
||
kandidaten = c("created", "modified", "expired")
|
||
for (k in kandidaten) {
|
||
if (k %in% names(daten)) {
|
||
wert = zeile[[k]][1]
|
||
if (!is.null(wert) && !is.na(wert)) return(k)
|
||
}
|
||
}
|
||
NA_character_
|
||
}
|
||
|
||
edeq_parse_datum = function(roh_wert) {
|
||
tryCatch({
|
||
d = as.POSIXct(roh_wert)
|
||
if (is.na(d)) return(NULL)
|
||
d
|
||
}, error = function(e) NULL)
|
||
}
|
||
|
||
# Dezimaltrennzeichen robust behandeln: Nutzereingaben koennen Komma oder Punkt sein.
|
||
parse_dezimal = function(x) {
|
||
if (is.null(x) || length(x) == 0 || is.na(x[1])) return(NA_real_)
|
||
as.numeric(gsub(",", ".", trimws(as.character(x[1]))))
|
||
}
|
||
|
||
# Die Rohdaten der Studienteilnehmenden koennen nachtraeglich nicht korrigiert werden.
|
||
# Ein Wert ausserhalb 1.0-2.5 m wird deshalb nicht nur als unplausibel markiert, sondern
|
||
# zusaetzlich geprueft, ob er als Zentimeterangabe (100-250) plausibel ist - dann
|
||
# automatisch durch 100 geteilt und sichtbar als Umrechnung gekennzeichnet, statt den
|
||
# BMI ersatzlos wegzulassen.
|
||
normalisiere_groesse = function(roh_wert) {
|
||
if (is.na(roh_wert)) {
|
||
return(list(meter = NA_real_, konvertiert = FALSE, unplausibel = FALSE))
|
||
}
|
||
if (roh_wert >= 1.0 && roh_wert <= 2.5) {
|
||
return(list(meter = roh_wert, konvertiert = FALSE, unplausibel = FALSE))
|
||
}
|
||
if (roh_wert >= 100 && roh_wert <= 250) {
|
||
return(list(meter = roh_wert / 100, konvertiert = TRUE, unplausibel = FALSE))
|
||
}
|
||
list(meter = NA_real_, konvertiert = FALSE, unplausibel = TRUE)
|
||
}
|
||
|
||
# Bleibt die Groesse auch nach normalisiere_groesse() unplausibel, kann eine manuelle
|
||
# Eingabe im UI nachgetragen werden (siehe bmi_block_ui im Server-Abschnitt). Diese
|
||
# Funktion kombiniert Rohdaten-BMI und manuelle Eingabe an einer zentralen Stelle,
|
||
# damit Bildschirmanzeige und Word-Export exakt denselben Wert verwenden.
|
||
edeq_bmi_effektiv = function(erg, groesse_manuell) {
|
||
if (!is.na(erg$bmi)) {
|
||
return(list(bmi = erg$bmi, groesse_m = erg$groesse_m, manuell = FALSE, gueltig = TRUE))
|
||
}
|
||
if (!isTRUE(erg$groesse_unplausibel)) {
|
||
return(list(bmi = NA_real_, groesse_m = NA_real_, manuell = FALSE, gueltig = FALSE))
|
||
}
|
||
if (is.null(groesse_manuell) || is.na(groesse_manuell) ||
|
||
groesse_manuell < 1.0 || groesse_manuell > 2.5) {
|
||
return(list(bmi = NA_real_, groesse_m = NA_real_, manuell = FALSE, gueltig = FALSE))
|
||
}
|
||
if (is.na(erg$gewicht_kg)) {
|
||
return(list(bmi = NA_real_, groesse_m = groesse_manuell, manuell = TRUE, gueltig = FALSE))
|
||
}
|
||
list(bmi = erg$gewicht_kg / (groesse_manuell ^ 2), groesse_m = groesse_manuell,
|
||
manuell = TRUE, gueltig = TRUE)
|
||
}
|
||
|
||
|
||
# Datenaufbereitung ####
|
||
|
||
# Statische Referenztabelle aus dem EDE-Q-Manual (Hilbert & Tuschen-Caffier, 2006),
|
||
# Tabelle 2, S. 6. Keine eigene Berechnung, keine Interpolation.
|
||
referenzgruppen = data.frame(
|
||
gruppe = c("Anorexia Nervosa", "Bulimia Nervosa", "Atypische Essstoerungen", "Nicht-essgestoert"),
|
||
n = c(105, 55, 54, 409),
|
||
restraint_m = c(4.07, 2.90, 3.02, 1.27), restraint_sd = c(1.74, 1.69, 1.83, 1.33),
|
||
ec_m = c(3.39, 2.89, 2.60, 0.76), ec_sd = c(1.43, 1.40, 1.51, 1.08),
|
||
wc_m = c(3.69, 3.19, 3.73, 1.66), wc_sd = c(1.66, 1.87, 1.54, 1.42),
|
||
sc_m = c(4.07, 3.73, 4.19, 2.08), sc_sd = c(1.51, 1.86, 1.54, 1.61),
|
||
gesamt_m = c(3.81, 3.18, 3.39, 1.44), gesamt_sd = c(1.43, 1.57, 1.38, 1.22),
|
||
stringsAsFactors = FALSE
|
||
)
|
||
|
||
# Kennzahl-Key -> Spaltenpraefix in referenzgruppen, fuer die z-Wert-Tabelle und die
|
||
# Positionsdarstellungen gemeinsam genutzt.
|
||
EDEQ_KENNZAHLEN = data.frame(
|
||
key = c("restraint", "ec", "wc", "sc", "gesamt"),
|
||
label = c("Restraint", "Eating Concern", "Weight Concern", "Shape Concern", "EDE-Q Gesamt"),
|
||
stringsAsFactors = FALSE
|
||
)
|
||
|
||
# Gruppenlabels stehen als Legende (nicht als Inline-Text auf dem Zahlenstrahl), da bei
|
||
# eng beieinanderliegenden Gruppenmittelwerten (z.B. Bulimia Nervosa/Atypische
|
||
# Essstoerungen) Inline-Text unabhaengig von der konkreten Kennzahl kollidieren kann.
|
||
erstelle_gauge_edeq = function(kennzahl_key, kennzahl_label, individueller_wert) {
|
||
|
||
ref = referenzgruppen
|
||
ref$m = ref[[paste0(kennzahl_key, "_m")]]
|
||
ref$farbe = c("#B71C1C", "#E65100", "#F9A825", "#2E7D32")
|
||
ref$gruppe = factor(ref$gruppe, levels = ref$gruppe)
|
||
|
||
p = ggplot() +
|
||
geom_vline(data = ref, aes(xintercept = m, color = gruppe),
|
||
linetype = "dashed", linewidth = 0.8) +
|
||
scale_color_manual(values = setNames(ref$farbe, ref$gruppe), name = NULL) +
|
||
scale_x_continuous(limits = c(0, 6), expand = c(0, 0), breaks = 0:6) +
|
||
scale_y_continuous(limits = c(-0.3, 1.0), expand = c(0, 0)) +
|
||
labs(x = paste0(kennzahl_label, " (0-6)"), y = NULL) +
|
||
theme_minimal(base_size = 11) +
|
||
theme(
|
||
axis.text.y = element_blank(),
|
||
axis.ticks.y = element_blank(),
|
||
panel.grid = element_blank(),
|
||
legend.position = "bottom",
|
||
legend.text = element_text(size = 7.5),
|
||
legend.key.width = unit(0.8, "line"),
|
||
legend.margin = margin(t = -6),
|
||
plot.background = element_rect(fill = "white", colour = NA),
|
||
panel.background = element_rect(fill = "white", colour = NA),
|
||
axis.line.x = element_line(colour = "#cccccc", linewidth = 0.5),
|
||
axis.text.x = element_text(colour = "#666666", size = 9)
|
||
) +
|
||
guides(color = guide_legend(nrow = 2, byrow = TRUE))
|
||
|
||
if (!is.na(individueller_wert)) {
|
||
p = p +
|
||
geom_segment(aes(x = individueller_wert, xend = individueller_wert,
|
||
y = -0.1, yend = 1.0),
|
||
colour = AKZENT_FARBE, linewidth = 2.2, lineend = "round") +
|
||
annotate("text", x = individueller_wert, y = -0.22,
|
||
label = sprintf("%.2f", individueller_wert),
|
||
colour = AKZENT_FARBE, fontface = "bold", size = 3.6)
|
||
}
|
||
|
||
p
|
||
}
|
||
|
||
|
||
# UI ####
|
||
|
||
app_css = "
|
||
body {
|
||
font-family: 'Segoe UI', Helvetica, Arial, sans-serif;
|
||
background-color: #f4f4f4;
|
||
color: #222;
|
||
font-size: 14px;
|
||
}
|
||
|
||
.app-header {
|
||
background-color: #8B2635;
|
||
color: white;
|
||
padding: 15px 22px 13px;
|
||
margin-bottom: 18px;
|
||
border-radius: 5px;
|
||
}
|
||
.app-header h2 { margin: 0; font-size: 1.4em; font-weight: 700; }
|
||
.app-header p { margin: 4px 0 0; font-size: 0.87em; opacity: 0.88; }
|
||
|
||
.input-panel {
|
||
display: flex;
|
||
align-items: flex-end;
|
||
gap: 10px;
|
||
background: white;
|
||
border-radius: 6px;
|
||
padding: 14px 18px;
|
||
margin-bottom: 16px;
|
||
box-shadow: 0 1px 4px rgba(0,0,0,0.09);
|
||
flex-wrap: wrap;
|
||
}
|
||
.input-panel .form-group { margin-bottom: 0; }
|
||
|
||
.btn-laden {
|
||
background-color: #8B2635 !important;
|
||
border-color: #7A2030 !important;
|
||
color: white !important;
|
||
font-weight: 600;
|
||
padding: 6px 18px;
|
||
border-radius: 4px;
|
||
letter-spacing: 0.02em;
|
||
white-space: nowrap;
|
||
}
|
||
.btn-laden:hover, .btn-laden:focus {
|
||
background-color: #6E1E29 !important;
|
||
border-color: #6E1E29 !important;
|
||
outline: none;
|
||
box-shadow: 0 0 0 2px rgba(139,38,53,0.3) !important;
|
||
}
|
||
|
||
.abschnitt-karte {
|
||
background: white;
|
||
border-radius: 6px;
|
||
padding: 16px 20px;
|
||
margin-bottom: 14px;
|
||
box-shadow: 0 1px 4px rgba(0,0,0,0.09);
|
||
}
|
||
.abschnitt-titel {
|
||
color: #8B2635;
|
||
margin-top: 0;
|
||
margin-bottom: 12px;
|
||
font-size: 1em;
|
||
font-weight: 700;
|
||
letter-spacing: 0.01em;
|
||
}
|
||
|
||
.kopf-info {
|
||
color: #555;
|
||
font-size: 0.92em;
|
||
padding-bottom: 10px;
|
||
border-bottom: 1px solid #eee;
|
||
margin-bottom: 8px;
|
||
}
|
||
.kopf-info b { color: #333; }
|
||
|
||
.alert-warnung {
|
||
background-color: #FFFDE7;
|
||
border-left: 4px solid #F9A825;
|
||
border-radius: 3px;
|
||
padding: 9px 12px;
|
||
margin-bottom: 10px;
|
||
font-size: 0.88em;
|
||
color: #555;
|
||
line-height: 1.45;
|
||
}
|
||
|
||
.alert-fehler {
|
||
background-color: #FEECEB;
|
||
border-left: 4px solid #C62828;
|
||
border-radius: 4px;
|
||
padding: 13px 16px;
|
||
margin-bottom: 12px;
|
||
}
|
||
.alert-fehler h4 { color: #C62828; margin-top: 0; margin-bottom: 8px; }
|
||
.alert-fehler p, .alert-fehler li { color: #444; font-size: 0.92em; }
|
||
|
||
table.tabelle-kennzahlen {
|
||
width: 100%; border-collapse: collapse; font-size: 0.92em;
|
||
}
|
||
table.tabelle-kennzahlen th, table.tabelle-kennzahlen td {
|
||
padding: 6px 10px; text-align: right; border-bottom: 1px solid #eee;
|
||
}
|
||
table.tabelle-kennzahlen th:first-child, table.tabelle-kennzahlen td:first-child {
|
||
text-align: left;
|
||
}
|
||
table.tabelle-kennzahlen th {
|
||
color: #8B2635; font-weight: 700; border-bottom: 2px solid #8B2635;
|
||
}
|
||
|
||
.item-zeile {
|
||
display: flex;
|
||
align-items: baseline;
|
||
gap: 10px;
|
||
padding: 7px 0;
|
||
border-bottom: 1px solid #f0f0f0;
|
||
}
|
||
.item-zeile:last-child { border-bottom: none; }
|
||
.item-nr { font-weight: 700; color: #8B2635; min-width: 26px; flex-shrink: 0; }
|
||
.item-text { flex: 1; color: #333; font-size: 0.92em; }
|
||
|
||
.disclaimer-text {
|
||
font-size: 0.82em; color: #777; font-style: italic;
|
||
margin-top: 10px; border-top: 1px solid rgba(0,0,0,.1); padding-top: 8px;
|
||
}
|
||
|
||
.desk-zeile {
|
||
display: flex; gap: 8px; align-items: baseline;
|
||
padding: 4px 0; color: #444; font-size: 0.93em;
|
||
}
|
||
.desk-label { font-weight: 600; color: #333; min-width: 200px; }
|
||
|
||
.start-hinweis {
|
||
text-align: center;
|
||
color: #bbb;
|
||
padding: 40px 0;
|
||
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("EDE-Q Auswertung"),
|
||
tags$p("Eating Disorder Examination-Questionnaire • dt. Version (Hilbert & Tuschen-Caffier, 2006) • Einzelfall-Auswertung")
|
||
),
|
||
|
||
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("ergebnis_ui")
|
||
)
|
||
|
||
|
||
# Word-Export ####
|
||
|
||
erstelle_edeq_docx = function(erg) {
|
||
|
||
fmt_titel = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18)
|
||
fmt_meta = fp_text(color = "#555555", bold = FALSE, font.size = 10)
|
||
fmt_warn = fp_text(color = "#B8860B", italic = TRUE, font.size = 9)
|
||
fmt_abschn = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 12, underlined = TRUE)
|
||
fmt_label = fp_text(bold = TRUE, font.size = 10)
|
||
fmt_normal = fp_text(font.size = 10)
|
||
fmt_disclaimer = fp_text(color = "#888888", italic = TRUE, font.size = 9)
|
||
|
||
doc = read_docx()
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("EDE-Q Auswertung", fmt_titel)))
|
||
doc = body_add_fpar(doc, fpar(ftext(
|
||
paste0("Chiffre: ", erg$chiffre,
|
||
" Ausfuelldatum: ", erg$ausfuelldatum,
|
||
" Erstellt: ", format(Sys.Date(), "%d.%m.%Y")),
|
||
fmt_meta
|
||
)))
|
||
|
||
if (!is.null(erg$warnung_mehrfach)) {
|
||
doc = body_add_fpar(doc, fpar(ftext(paste0("Hinweis: ", erg$warnung_mehrfach), fmt_warn)))
|
||
}
|
||
if (isTRUE(erg$ausfuelldatum_fallback)) {
|
||
doc = body_add_fpar(doc, fpar(ftext(
|
||
"Hinweis: Ausfuelldatum nicht in Rohdaten gefunden, Anzeigedatum verwendet.", fmt_warn
|
||
)))
|
||
}
|
||
|
||
doc = body_add_par(doc, "")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Subskalen- und Gesamtmittelwerte", fmt_abschn)))
|
||
tab_kennzahlen = data.frame(
|
||
Kennzahl = EDEQ_KENNZAHLEN$label,
|
||
Wert = sapply(EDEQ_KENNZAHLEN$key, function(k) {
|
||
v = erg$kennzahlen[[k]]
|
||
if (is.na(v)) "nicht berechenbar" else sprintf("%.2f", v)
|
||
}),
|
||
stringsAsFactors = FALSE
|
||
)
|
||
doc = body_add_table(doc, tab_kennzahlen, style = "table_template")
|
||
doc = body_add_par(doc, "")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Referenzgruppen-Vergleich (z-Werte)", fmt_abschn)))
|
||
doc = body_add_fpar(doc, fpar(ftext(
|
||
"Deskriptiver Vergleich, kein validierter Cutoff.", fmt_warn
|
||
)))
|
||
tab_z = data.frame(Kennzahl = EDEQ_KENNZAHLEN$label, stringsAsFactors = FALSE)
|
||
for (g in referenzgruppen$gruppe) {
|
||
tab_z[[g]] = sapply(erg$z_werte[[g]], function(z) {
|
||
if (is.na(z)) "-" else sprintf("%.2f", z)
|
||
})
|
||
}
|
||
doc = body_add_table(doc, tab_z, style = "table_template")
|
||
doc = body_add_par(doc, "")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext(
|
||
"Kernverhaltensitems 13-18 (Einzelitem-Auswertung, keine Subskala)", fmt_abschn
|
||
)))
|
||
for (it in erg$kernitems) {
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext(paste0(it$label, ": "), fmt_label),
|
||
ftext(it$anzeige, fmt_normal)
|
||
))
|
||
}
|
||
doc = body_add_par(doc, "")
|
||
|
||
if (!is.na(erg$bmi)) {
|
||
doc = body_add_fpar(doc, fpar(ftext("BMI", fmt_abschn)))
|
||
if (isTRUE(erg$groesse_konvertiert)) {
|
||
doc = body_add_fpar(doc, fpar(ftext(sprintf(
|
||
"Hinweis: Groesse als Zentimeterangabe erkannt und automatisch umgerechnet (verwendet: %.2f m).",
|
||
erg$groesse_m
|
||
), fmt_warn)))
|
||
}
|
||
if (isTRUE(erg$groesse_manuell_verwendet)) {
|
||
doc = body_add_fpar(doc, fpar(ftext(sprintf(
|
||
"Hinweis: Groesse manuell nachgetragen (verwendet: %.2f m), da der Rohwert unplausibel war.",
|
||
erg$groesse_m
|
||
), fmt_warn)))
|
||
}
|
||
doc = body_add_fpar(doc, fpar(ftext(sprintf("%.1f kg/m²", erg$bmi), fmt_normal)))
|
||
doc = body_add_par(doc, "")
|
||
}
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext(EDEQ_DISCLAIMER, fmt_disclaimer)))
|
||
|
||
doc
|
||
}
|
||
|
||
|
||
# Server ####
|
||
|
||
server = function(input, output, session) {
|
||
# --- pseudonym-support-injection v1 ---
|
||
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)))
|
||
}
|
||
})
|
||
|
||
# Die beiden externen Skripte werden bewusst NICHT beim App-Start gesourct, sondern
|
||
# erst hier, beim Klick auf "Auswerten" (Source-bei-Klick-Muster).
|
||
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"))
|
||
}
|
||
|
||
if (!(nchar(trimws(input$pseudonym)) > 0 || grepl("^[A-Z][0-9]{6}$", chiffre))) {
|
||
return(list(typ = "format_fehler", chiffre = chiffre))
|
||
}
|
||
|
||
pfadfehler = character(0)
|
||
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
|
||
pfadfehler = c(pfadfehler,
|
||
paste0("Download-Skript nicht gefunden: >>", PFAD_DOWNLOAD_SKRIPT, "<<"))
|
||
}
|
||
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
|
||
pfadfehler = c(pfadfehler,
|
||
paste0("Pseudonym-Skript nicht gefunden: >>", PFAD_PSEUDONYM_SKRIPT, "<<"))
|
||
}
|
||
if (length(pfadfehler) > 0) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = paste("Bitte Pfade am Kopf der app.R anpassen:",
|
||
paste(pfadfehler, collapse = "\n"), sep = "\n")))
|
||
}
|
||
|
||
ok_download = tryCatch({
|
||
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
|
||
list(ok = TRUE)
|
||
}, error = function(e) list(ok = FALSE, msg = conditionMessage(e)))
|
||
if (!ok_download$ok) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = paste0("Fehler im Download-Skript (",
|
||
basename(PFAD_DOWNLOAD_SKRIPT), "):\n", ok_download$msg)))
|
||
}
|
||
|
||
# Ordner mit pseudonyme.db suchen, ausgehend vom Pseudonym-Skript-Ordner, bis zu
|
||
# 5 Ebenen nach oben.
|
||
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 = "skript_fehler",
|
||
meldung = paste0(
|
||
"pseudonyme.db nicht gefunden.\n",
|
||
"Gesucht ausgehend vom Pseudonym-Skript-Ordner bis zu 5 Ebenen nach oben.\n",
|
||
"Bitte sicherstellen, dass pseudonyme.db im selben oder einem ",
|
||
"uebergeordneten Ordner liegt."
|
||
)))
|
||
}
|
||
|
||
# add = TRUE ist Pflicht, sonst wuerden ggf. bereits registrierte on.exit()-Handler
|
||
# ueberschrieben statt ergaenzt.
|
||
ok_pseudonym = tryCatch({
|
||
alter_wd = getwd()
|
||
on.exit(setwd(alter_wd), add = TRUE)
|
||
setwd(db_ordner)
|
||
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
|
||
if (nchar(trimws(input$pseudonym)) > 0) {
|
||
.pw_wert = trimws(input$pseudonym)
|
||
.pw_tab = get("pseudo", envir = .GlobalEnv)
|
||
.pw_treffer = .pw_tab[.pw_tab$pseudonym == .pw_wert, ]
|
||
if (nrow(.pw_treffer) > 0) chiffre = toupper(trimws(.pw_treffer$chiffre[1]))
|
||
}
|
||
list(ok = TRUE)
|
||
}, error = function(e) list(ok = FALSE, msg = conditionMessage(e)))
|
||
if (!ok_pseudonym$ok) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = paste0("Fehler im Pseudonym-Skript (",
|
||
basename(PFAD_PSEUDONYM_SKRIPT), "):\n", ok_pseudonym$msg)))
|
||
}
|
||
|
||
if (!exists("daten_edeq", envir = .GlobalEnv)) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = paste0("Objekt 'daten_edeq' fehlt nach dem Sourcen von:\n",
|
||
PFAD_DOWNLOAD_SKRIPT)))
|
||
}
|
||
if (!exists("pseudo", envir = .GlobalEnv)) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = paste0("Objekt 'pseudo' fehlt nach dem Sourcen von:\n",
|
||
PFAD_PSEUDONYM_SKRIPT)))
|
||
}
|
||
|
||
dat_edeq = get("daten_edeq", envir = .GlobalEnv)
|
||
dat_ps = get("pseudo", envir = .GlobalEnv)
|
||
|
||
ps_treffer = dat_ps[dat_ps$chiffre == chiffre, , drop = FALSE]
|
||
if (nrow(ps_treffer) == 0) {
|
||
return(list(typ = "chiffre_nicht_gefunden", chiffre = chiffre))
|
||
}
|
||
alle_session_ids = unique(as.character(ps_treffer$pseudonym))
|
||
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
|
||
|
||
if (!("session" %in% names(dat_edeq))) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = paste0(
|
||
"Spalte 'session' in 'daten_edeq' nicht gefunden. Der erwartete Spaltenname ",
|
||
"fuer die formr-Session-ID ist am echten Export noch nicht verifiziert - ",
|
||
"bitte tatsaechlichen Spaltennamen in get_data_edeq.R bzw. hier pruefen."
|
||
)))
|
||
}
|
||
|
||
edeq_treffer = dat_edeq[dat_edeq$session %in% alle_session_ids, , drop = FALSE]
|
||
if (nrow(edeq_treffer) == 0) {
|
||
return(list(typ = "keine_daten", chiffre = chiffre))
|
||
}
|
||
|
||
# Mehrfachtreffer (Bogen mehrfach ausgefuellt): nicht stillschweigend den ersten
|
||
# nehmen, sondern den neuesten (nach Ausfuelldatum) waehlen und sichtbar warnen.
|
||
warnung_mehrfach = NULL
|
||
spalte_datum = edeq_finde_datumsspalte(dat_edeq, edeq_treffer[1, , drop = FALSE])
|
||
if (nrow(edeq_treffer) > 1) {
|
||
n_ausfuell = nrow(edeq_treffer)
|
||
if (!is.na(spalte_datum)) {
|
||
reihenfolge = order(
|
||
vapply(seq_len(n_ausfuell), function(i) {
|
||
d = edeq_parse_datum(edeq_treffer[[spalte_datum]][i])
|
||
if (is.null(d)) -Inf else as.numeric(d)
|
||
}, numeric(1)),
|
||
decreasing = TRUE
|
||
)
|
||
edeq_treffer = edeq_treffer[reihenfolge, , drop = FALSE]
|
||
}
|
||
datum_neuestes = if (!is.na(spalte_datum)) {
|
||
d = edeq_parse_datum(edeq_treffer[[spalte_datum]][1])
|
||
if (!is.null(d)) format(d, "%d.%m.%Y %H:%M") else "unbekanntes Datum"
|
||
} else "unbekanntes Datum"
|
||
warnung_mehrfach = paste0(
|
||
"Es wurden ", n_ausfuell, " Ausfuellungen gefunden, es wird die neueste vom ",
|
||
datum_neuestes, " angezeigt."
|
||
)
|
||
edeq_treffer = edeq_treffer[1, , drop = FALSE]
|
||
}
|
||
|
||
zeile = edeq_treffer[1, , drop = FALSE]
|
||
|
||
spalte_datum = edeq_finde_datumsspalte(dat_edeq, zeile)
|
||
datum_geparst = if (!is.na(spalte_datum)) edeq_parse_datum(zeile[[spalte_datum]][1]) else NULL
|
||
ausfuelldatum_fallback = is.null(datum_geparst)
|
||
ausfuelldatum = if (!ausfuelldatum_fallback) format(datum_geparst, "%d.%m.%Y") else
|
||
format(Sys.Date(), "%d.%m.%Y")
|
||
ausfuelldatum_dateikennung = if (!ausfuelldatum_fallback) format(datum_geparst, "%Y%m%d") else
|
||
format(Sys.Date(), "%Y%m%d")
|
||
|
||
# Recoding aller benoetigten Items. Methode pro Item gemaess Scoring-Spezifikation.
|
||
item_methoden = list(
|
||
edeq_01_r = "tage", edeq_02_r = "tage", edeq_03_r = "tage",
|
||
edeq_04_r = "tage", edeq_05_r = "tage",
|
||
edeq_06_sc = "tage", edeq_07_ec = "tage", edeq_08_wcsc = "tage",
|
||
edeq_09_ec = "tage", edeq_10_sc = "tage", edeq_11_sc = "tage",
|
||
edeq_12_wc = "tage",
|
||
edeq_19_ec = "tage",
|
||
edeq_20_ec = "item20",
|
||
edeq_21_ec = "digit_prefix", edeq_22_wc = "digit_prefix",
|
||
edeq_23_sc = "digit_prefix", edeq_24_wc = "digit_prefix",
|
||
edeq_25_wc = "digit_prefix", edeq_26_sc = "digit_prefix",
|
||
edeq_27_sc = "digit_prefix", edeq_28_sc = "digit_prefix"
|
||
)
|
||
fehlende_item_spalten = names(item_methoden)[!(names(item_methoden) %in% names(dat_edeq))]
|
||
if (length(fehlende_item_spalten) > 0) {
|
||
return(list(typ = "skript_fehler",
|
||
meldung = paste0(
|
||
"Folgende erwartete Item-Spalten fehlen in 'daten_edeq': ",
|
||
paste(fehlende_item_spalten, collapse = ", "), "."
|
||
)))
|
||
}
|
||
|
||
item_werte = list()
|
||
item_unerwartet = character(0)
|
||
for (var in names(item_methoden)) {
|
||
res = edeq_recode_item(zeile[[var]], item_methoden[[var]])
|
||
item_werte[[var]] = res$wert
|
||
if (isTRUE(res$unerwartet)) item_unerwartet = c(item_unerwartet, var)
|
||
}
|
||
|
||
# Subskalen als Mittelwerte (kein Summenscore). Ein Item mit unerwarteter
|
||
# Kodierung fuehrt dazu, dass die betroffene(n) Subskala(en) als "nicht
|
||
# berechenbar" ausgegeben werden, statt einen falschen Wert stillzuschweigend
|
||
# zu berechnen.
|
||
subskalen_items = list(
|
||
restraint = c("edeq_01_r", "edeq_02_r", "edeq_03_r", "edeq_04_r", "edeq_05_r"),
|
||
ec = c("edeq_07_ec", "edeq_09_ec", "edeq_19_ec", "edeq_20_ec", "edeq_21_ec"),
|
||
wc = c("edeq_08_wcsc", "edeq_12_wc", "edeq_22_wc", "edeq_24_wc", "edeq_25_wc"),
|
||
sc = c("edeq_06_sc", "edeq_08_wcsc", "edeq_10_sc", "edeq_11_sc",
|
||
"edeq_23_sc", "edeq_26_sc", "edeq_27_sc", "edeq_28_sc")
|
||
)
|
||
|
||
berechne_mittelwert = function(vars) {
|
||
werte = unlist(item_werte[vars])
|
||
if (any(vars %in% item_unerwartet)) return(NA_real_)
|
||
if (any(is.na(werte))) return(NA_real_)
|
||
mean(werte)
|
||
}
|
||
|
||
kennzahlen = list(
|
||
restraint = berechne_mittelwert(subskalen_items$restraint),
|
||
ec = berechne_mittelwert(subskalen_items$ec),
|
||
wc = berechne_mittelwert(subskalen_items$wc),
|
||
sc = berechne_mittelwert(subskalen_items$sc)
|
||
)
|
||
subskalen_ok = !any(sapply(kennzahlen, is.na))
|
||
kennzahlen$gesamt = if (subskalen_ok) {
|
||
mean(c(kennzahlen$restraint, kennzahlen$ec, kennzahlen$wc, kennzahlen$sc))
|
||
} else NA_real_
|
||
|
||
# z-Werte je Kennzahl und Referenzgruppe.
|
||
z_werte = list()
|
||
for (g in seq_len(nrow(referenzgruppen))) {
|
||
gname = referenzgruppen$gruppe[g]
|
||
z_werte[[gname]] = sapply(EDEQ_KENNZAHLEN$key, function(k) {
|
||
v = kennzahlen[[k]]
|
||
if (is.na(v)) return(NA_real_)
|
||
(v - referenzgruppen[[paste0(k, "_m")]][g]) / referenzgruppen[[paste0(k, "_sd")]][g]
|
||
})
|
||
names(z_werte[[gname]]) = EDEQ_KENNZAHLEN$key
|
||
}
|
||
|
||
# Kernverhaltensitems 13-18: direkte Einzelitem-Uebernahme, keine Aggregation.
|
||
kernitem_labels = c(
|
||
edeq_13 = "Subjektive Essanfaelle (Item 13)",
|
||
edeq_14 = "Situationen mit Kontrollverlust (Item 14)",
|
||
edeq_15 = "Objektive Essanfaelle (Item 15)",
|
||
edeq_16 = "Selbstinduziertes Erbrechen (Item 16)",
|
||
edeq_17 = "Abfuehrmitteleinnahme (Item 17)",
|
||
edeq_18 = "Zwanghaftes/getriebenes Sporttreiben (Item 18)"
|
||
)
|
||
kernitems = lapply(names(kernitem_labels), function(var) {
|
||
roh = if (var %in% names(dat_edeq)) zeile[[var]][1] else NA
|
||
wert = suppressWarnings(as.numeric(roh))
|
||
list(
|
||
var = var,
|
||
label = kernitem_labels[[var]],
|
||
wert = wert,
|
||
anzeige = if (is.na(wert)) "k. A." else as.character(wert)
|
||
)
|
||
})
|
||
|
||
# Zusatzangaben, deskriptiv.
|
||
geschlecht = if ("edeq_geschlecht" %in% names(dat_edeq))
|
||
hole_choice_text(zeile[["edeq_geschlecht"]])[1] else NA_character_
|
||
amenorrhoe = if ("edeq_amenorrhoe" %in% names(dat_edeq))
|
||
hole_choice_text(zeile[["edeq_amenorrhoe"]])[1] else NA_character_
|
||
amenorrhoe_anzahl = if ("edeq_amenorrhoe_anzahl" %in% names(dat_edeq))
|
||
suppressWarnings(as.numeric(zeile[["edeq_amenorrhoe_anzahl"]][1])) else NA_real_
|
||
pille = if ("edeq_pille" %in% names(dat_edeq))
|
||
hole_choice_text(zeile[["edeq_pille"]])[1] else NA_character_
|
||
|
||
# BMI, nur wenn beide Werte vorhanden und Groesse plausibel (1.0-2.5 m, oder als
|
||
# Zentimeterangabe 100-250 automatisch umgerechnet, siehe normalisiere_groesse()).
|
||
gewicht_kg = if ("edeq_gewicht" %in% names(dat_edeq)) parse_dezimal(zeile[["edeq_gewicht"]][1]) else NA_real_
|
||
groesse_roh = if ("edeq_groesse" %in% names(dat_edeq)) parse_dezimal(zeile[["edeq_groesse"]][1]) else NA_real_
|
||
groesse_info = normalisiere_groesse(groesse_roh)
|
||
groesse_m = groesse_info$meter
|
||
groesse_konvertiert = groesse_info$konvertiert
|
||
groesse_unplausibel = groesse_info$unplausibel
|
||
bmi = if (!is.na(gewicht_kg) && !is.na(groesse_m)) {
|
||
gewicht_kg / (groesse_m ^ 2)
|
||
} else NA_real_
|
||
|
||
list(
|
||
typ = "ergebnis",
|
||
chiffre = chiffre,
|
||
ausfuelldatum = ausfuelldatum,
|
||
ausfuelldatum_fallback = ausfuelldatum_fallback,
|
||
ausfuelldatum_dateikennung = ausfuelldatum_dateikennung,
|
||
warnung_mehrfach = warnung_mehrfach,
|
||
item_unerwartet = item_unerwartet,
|
||
kennzahlen = kennzahlen,
|
||
z_werte = z_werte,
|
||
kernitems = kernitems,
|
||
geschlecht = geschlecht,
|
||
amenorrhoe = amenorrhoe,
|
||
amenorrhoe_anzahl = amenorrhoe_anzahl,
|
||
pille = pille,
|
||
gewicht_kg = gewicht_kg,
|
||
groesse_roh = groesse_roh,
|
||
groesse_m = groesse_m,
|
||
groesse_konvertiert = groesse_konvertiert,
|
||
groesse_unplausibel = groesse_unplausibel,
|
||
groesse_manuell_verwendet = FALSE,
|
||
bmi = bmi
|
||
)
|
||
})
|
||
|
||
|
||
output$ergebnis_ui = renderUI({
|
||
|
||
if (input$btn_suchen == 0) {
|
||
return(div(class = "start-hinweis",
|
||
"Patientenchiffre eingeben und auf \"Auswerten\" klicken."
|
||
))
|
||
}
|
||
|
||
erg = ergebnis_r()
|
||
|
||
if (erg$typ == "skript_fehler") {
|
||
return(div(class = "alert-fehler",
|
||
tags$h4("Konfigurationsfehler"),
|
||
tags$pre(style = "font-size:0.88em; white-space:pre-wrap;", erg$meldung)
|
||
))
|
||
}
|
||
|
||
if (erg$typ == "leere_eingabe") {
|
||
return(div(class = "alert-warnung", "Bitte eine Patientenchiffre eingeben."))
|
||
}
|
||
|
||
if (erg$typ == "format_fehler") {
|
||
return(div(class = "alert-warnung",
|
||
"Ungueltige Chiffre. Erwartet wird ein Grossbuchstabe gefolgt von 6 Ziffern, ",
|
||
"z.B. P000123."
|
||
))
|
||
}
|
||
|
||
if (erg$typ == "chiffre_nicht_gefunden") {
|
||
return(div(class = "alert-fehler",
|
||
tags$h4("Chiffre nicht gefunden"),
|
||
tags$p("Die Chiffre ", tags$b(paste0("«", erg$chiffre, "»")),
|
||
" ist in der Pseudonymtabelle nicht vorhanden."),
|
||
tags$p("Bitte Schreibweise pruefen oder Pseudonymtabelle aktualisieren.")
|
||
))
|
||
}
|
||
|
||
if (erg$typ == "keine_daten") {
|
||
return(div(class = "alert-fehler",
|
||
tags$h4("Kein EDE-Q-Datensatz gefunden"),
|
||
tags$p("Zur Chiffre ", tags$b(paste0("«", erg$chiffre, "»")),
|
||
" existiert ein Pseudonymeintrag, aber kein Datensatz in ",
|
||
tags$code("daten_edeq"), "."),
|
||
tags$p("Moegliche Ursachen: Bogen noch nicht ausgefuellt, ",
|
||
"oder Daten noch nicht heruntergeladen.")
|
||
))
|
||
}
|
||
|
||
# typ == "ergebnis"
|
||
|
||
kopf_block = div(class = "abschnitt-karte",
|
||
div(class = "kopf-info",
|
||
tags$b("Chiffre: "), erg$chiffre, " ",
|
||
tags$b("Ausfuelldatum: "), erg$ausfuelldatum
|
||
),
|
||
if (!is.null(erg$warnung_mehrfach))
|
||
div(class = "alert-warnung", "⚠ Hinweis: ", erg$warnung_mehrfach),
|
||
if (isTRUE(erg$ausfuelldatum_fallback))
|
||
div(class = "alert-warnung",
|
||
"⚠ Ausfuelldatum nicht in Rohdaten gefunden, Anzeigedatum verwendet."),
|
||
if (length(erg$item_unerwartet) > 0)
|
||
div(class = "alert-warnung",
|
||
"⚠ Item-Kodierung unerwartet, Wert nicht auswertbar bei: ",
|
||
paste(erg$item_unerwartet, collapse = ", "),
|
||
". Betroffene Subskala(en) als \"nicht berechenbar\" ausgewiesen.")
|
||
)
|
||
|
||
tab_kennzahlen_zeilen = lapply(EDEQ_KENNZAHLEN$key, function(k) {
|
||
idx = match(k, EDEQ_KENNZAHLEN$key)
|
||
v = erg$kennzahlen[[k]]
|
||
tags$tr(
|
||
tags$td(EDEQ_KENNZAHLEN$label[idx]),
|
||
tags$td(if (is.na(v)) "nicht berechenbar" else sprintf("%.2f", v))
|
||
)
|
||
})
|
||
kennzahlen_block = div(class = "abschnitt-karte",
|
||
tags$h4(class = "abschnitt-titel", "Subskalen- und Gesamtmittelwerte"),
|
||
tags$table(class = "tabelle-kennzahlen",
|
||
tags$thead(tags$tr(tags$th("Kennzahl"), tags$th("Mittelwert (0-6)"))),
|
||
tags$tbody(tab_kennzahlen_zeilen)
|
||
)
|
||
)
|
||
|
||
tab_z_kopf = tags$tr(
|
||
tags$th("Kennzahl"), tags$th("Ihr Wert"),
|
||
lapply(referenzgruppen$gruppe, function(g) tags$th(g))
|
||
)
|
||
tab_z_zeilen = lapply(EDEQ_KENNZAHLEN$key, function(k) {
|
||
idx = match(k, EDEQ_KENNZAHLEN$key)
|
||
v = erg$kennzahlen[[k]]
|
||
tags$tr(
|
||
tags$td(EDEQ_KENNZAHLEN$label[idx]),
|
||
tags$td(if (is.na(v)) "-" else sprintf("%.2f", v)),
|
||
lapply(referenzgruppen$gruppe, function(g) {
|
||
z = erg$z_werte[[g]][[k]]
|
||
tags$td(if (is.na(z)) "-" else sprintf("%.2f", z))
|
||
})
|
||
)
|
||
})
|
||
|
||
gauge_plots = lapply(EDEQ_KENNZAHLEN$key, function(k) {
|
||
idx = match(k, EDEQ_KENNZAHLEN$key)
|
||
plotname = paste0("gauge_", k)
|
||
column(6, plotOutput(plotname, height = "150px"))
|
||
})
|
||
|
||
referenz_block = div(class = "abschnitt-karte",
|
||
tags$h4(class = "abschnitt-titel", "Referenzgruppen-Vergleich (z-Werte)"),
|
||
tags$p(style = "font-size:0.85em; color:#888; font-style:italic;",
|
||
"Deskriptiver Vergleich, kein validierter Cutoff."),
|
||
div(style = "overflow-x:auto;",
|
||
tags$table(class = "tabelle-kennzahlen",
|
||
tags$thead(tab_z_kopf),
|
||
tags$tbody(tab_z_zeilen)
|
||
)
|
||
),
|
||
tags$hr(),
|
||
fluidRow(gauge_plots)
|
||
)
|
||
|
||
kernitem_zeilen = lapply(erg$kernitems, function(it) {
|
||
div(class = "item-zeile",
|
||
div(class = "item-text", it$label),
|
||
tags$b(it$anzeige)
|
||
)
|
||
})
|
||
kernitem_block = div(class = "abschnitt-karte",
|
||
tags$h4(class = "abschnitt-titel",
|
||
"Kernverhaltensitems 13-18 (Einzelitem-Auswertung, keine Subskala)"),
|
||
div(kernitem_zeilen)
|
||
)
|
||
|
||
# BMI-Anzeige ist ein eigener uiOutput (statt hier inline), damit bei unplausibler
|
||
# Groesse ein manuelles Eingabefeld angeboten werden kann, dessen Ergebnis separat
|
||
# (reaktiv auf die manuelle Eingabe) nachberechnet wird, ohne das gesamte
|
||
# Ergebnis-Panel bei jedem Tastendruck neu zu erzeugen.
|
||
bmi_block = uiOutput("bmi_block_ui")
|
||
|
||
zusatz_block = div(class = "abschnitt-karte",
|
||
tags$h4(class = "abschnitt-titel", "Zusatzangaben"),
|
||
div(class = "desk-zeile",
|
||
div(class = "desk-label", "Geschlecht:"),
|
||
div(if (is.na(erg$geschlecht)) "k. A." else erg$geschlecht)
|
||
),
|
||
if (!is.na(erg$geschlecht) && erg$geschlecht == "weiblich") tagList(
|
||
div(class = "desk-zeile",
|
||
div(class = "desk-label", "Amenorrhoe:"),
|
||
div(if (is.na(erg$amenorrhoe)) "k. A." else erg$amenorrhoe)
|
||
),
|
||
if (!is.na(erg$amenorrhoe) && erg$amenorrhoe == "JA")
|
||
div(class = "desk-zeile",
|
||
div(class = "desk-label", "Anzahl Monate Amenorrhoe:"),
|
||
div(if (is.na(erg$amenorrhoe_anzahl)) "k. A." else as.character(erg$amenorrhoe_anzahl))
|
||
),
|
||
div(class = "desk-zeile",
|
||
div(class = "desk-label", "Hormonelle Verhuetung (Pille):"),
|
||
div(if (is.na(erg$pille)) "k. A." else erg$pille)
|
||
)
|
||
)
|
||
)
|
||
|
||
disclaimer_block = div(class = "abschnitt-karte",
|
||
div(class = "disclaimer-text", EDEQ_DISCLAIMER)
|
||
)
|
||
|
||
tagList(kopf_block, kennzahlen_block, referenz_block, kernitem_block,
|
||
bmi_block, zusatz_block, disclaimer_block)
|
||
})
|
||
|
||
# Ein renderPlot je Kennzahl (Restraint/EC/WC/SC/Gesamt), da plotOutput-IDs statisch
|
||
# in der UI-Funktion angelegt werden.
|
||
lapply(EDEQ_KENNZAHLEN$key, function(k) {
|
||
idx = match(k, EDEQ_KENNZAHLEN$key)
|
||
local({
|
||
kk = k
|
||
ll = EDEQ_KENNZAHLEN$label[idx]
|
||
output[[paste0("gauge_", kk)]] = renderPlot({
|
||
req(input$btn_suchen > 0)
|
||
erg = ergebnis_r()
|
||
req(erg$typ == "ergebnis")
|
||
erstelle_gauge_edeq(kk, ll, erg$kennzahlen[[kk]])
|
||
}, bg = "white")
|
||
})
|
||
})
|
||
|
||
# bmi_block_ui haengt NUR an ergebnis_r() (nicht an input$groesse_manuell), damit das
|
||
# numericInput bei unplausibler Groesse nur einmal pro Klick auf "Auswerten" erzeugt
|
||
# wird und beim Tippen nicht staendig neu aufgebaut/zurueckgesetzt wird. Die eigentliche
|
||
# BMI-Nachberechnung aus der manuellen Eingabe passiert separat in bmi_manuell_ui.
|
||
output$bmi_block_ui = renderUI({
|
||
req(input$btn_suchen > 0)
|
||
erg = ergebnis_r()
|
||
req(erg$typ == "ergebnis")
|
||
|
||
if (!is.na(erg$bmi)) {
|
||
return(div(class = "abschnitt-karte",
|
||
tags$h4(class = "abschnitt-titel", "BMI"),
|
||
if (isTRUE(erg$groesse_konvertiert))
|
||
div(class = "alert-warnung",
|
||
sprintf("Groesse als Zentimeterangabe erkannt und automatisch umgerechnet (verwendet: %.2f m).",
|
||
erg$groesse_m)),
|
||
tags$span(sprintf("%.1f kg/m²", erg$bmi))
|
||
))
|
||
}
|
||
|
||
if (isTRUE(erg$groesse_unplausibel)) {
|
||
return(div(class = "abschnitt-karte",
|
||
tags$h4(class = "abschnitt-titel", "BMI"),
|
||
div(class = "alert-warnung",
|
||
sprintf("Groesse unplausibel (Rohwert: %s), automatische BMI-Berechnung nicht moeglich.",
|
||
if (is.na(erg$groesse_roh)) "k. A." else as.character(erg$groesse_roh))),
|
||
div(style = "margin-top:10px;",
|
||
numericInput("groesse_manuell",
|
||
"Groesse manuell eingeben (Meter, z.B. 1.75)",
|
||
value = NA, min = 1.0, max = 2.5, step = 0.01, width = "260px")
|
||
),
|
||
uiOutput("bmi_manuell_ui")
|
||
))
|
||
}
|
||
|
||
NULL
|
||
})
|
||
|
||
output$bmi_manuell_ui = renderUI({
|
||
erg = ergebnis_r()
|
||
req(erg$typ == "ergebnis", isTRUE(erg$groesse_unplausibel))
|
||
if (is.null(input$groesse_manuell) || is.na(input$groesse_manuell)) return(NULL)
|
||
|
||
res = edeq_bmi_effektiv(erg, input$groesse_manuell)
|
||
if (!res$gueltig) {
|
||
msg = if (is.na(erg$gewicht_kg))
|
||
"Kein Gewicht in den Rohdaten vorhanden - BMI kann auch mit manueller Groesse nicht berechnet werden."
|
||
else
|
||
"Bitte Groesse in Metern zwischen 1.0 und 2.5 eingeben (z.B. 1.75)."
|
||
return(div(class = "alert-warnung", msg))
|
||
}
|
||
|
||
div(style = "margin-top:8px;",
|
||
tags$span(sprintf("%.1f kg/m²", res$bmi)),
|
||
div(class = "alert-warnung", "Manuell eingegebene Groesse verwendet (nicht aus den Rohdaten).")
|
||
)
|
||
})
|
||
|
||
output$download_word = downloadHandler(
|
||
filename = function() {
|
||
erg = ergebnis_r()
|
||
if (is.null(erg) || erg$typ != "ergebnis") return("EDEQ_Auswertung.docx")
|
||
chiffre_esc = gsub("[^A-Za-z0-9_-]", "_", erg$chiffre)
|
||
paste0("EDEQ_", chiffre_esc, "_", erg$ausfuelldatum_dateikennung, ".docx")
|
||
},
|
||
content = function(file) {
|
||
req(ergebnis_r()$typ == "ergebnis")
|
||
erg = ergebnis_r()
|
||
|
||
# Falls die Rohdaten-Groesse unplausibel war und eine manuelle Eingabe vorliegt,
|
||
# denselben effektiven BMI wie auf dem Bildschirm auch im Word-Export verwenden.
|
||
if (is.na(erg$bmi) && isTRUE(erg$groesse_unplausibel)) {
|
||
res = edeq_bmi_effektiv(erg, input$groesse_manuell)
|
||
if (isTRUE(res$gueltig)) {
|
||
erg$bmi = res$bmi
|
||
erg$groesse_m = res$groesse_m
|
||
erg$groesse_manuell_verwendet = TRUE
|
||
}
|
||
}
|
||
|
||
doc = erstelle_edeq_docx(erg)
|
||
print(doc, target = file)
|
||
}
|
||
)
|
||
}
|
||
|
||
|
||
# Start ####
|
||
|
||
shinyApp(ui = ui, server = server)
|