server/DiagnostikApps
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
DiagnostikApps/EDI-2/app.R
Jonas Karneboge 3cba772836 Initial commit
2026-09-22 18:35:43 +02:00

1094 lines
40 KiB
R
Raw Blame History

# Präambel ####
AKZENT_FARBE = "#8B2635"
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_edi2.R"
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
PFAD_NORMTABELLEN = "normtabellen"
EDI2_DISCLAIMER = paste0(
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt keine ",
"klinische Diagnose. Die Interpretation obliegt der behandelnden Person. Es gibt keinen ",
"festen klinischen Cutoff-Wert; die Einordnung erfolgt ausschliesslich relativ zur ",
"gewaehlten Referenzgruppe (Perzentilrang)."
)
EDI2_GESAMTWERT_HINWEIS = paste0(
"Das Testmanual weist ausdruecklich darauf hin, dass ein Gesamtwert ueber alle elf Skalen ",
"'inhaltlich nicht mehr sinnvoll zu interpretieren' sei. Der Gesamtwert wird hier auf ",
"Nutzerwunsch dennoch angezeigt, mit diesem woertlichen Manual-Hinweis versehen."
)
library(shiny)
library(dplyr)
library(tidyr)
library(ggplot2)
library(haven)
library(officer)
library(DBI)
library(RSQLite)
# 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)
PFAD_NORMTABELLEN = normalizePath(absPath(PFAD_NORMTABELLEN), mustWork = FALSE)
# Helper ####
# Formr-Itemtexte enthalten eine escapete fuehrende Nummer ("1\\. Text...") und
# Markdown-Sternchen. Ueberall verwendet, wo Itemtext oder Intro-Text angezeigt wird.
bereinige_markdown = function(text) {
if (is.null(text) || length(text) == 0 || is.na(text)) return(NA_character_)
text = as.character(text)
text = gsub("^\\d+\\\\\\.\\s*", "", text)
text = gsub("\\*\\*", "", text)
trimws(text)
}
edi2_kategorien = c("nie", "selten", "manchmal", "oft", "normalerweise", "immer")
edi2_kategorien_norm = tolower(trimws(edi2_kategorien))
# Rohwert 1-6 wird ueber das labels-Attribut der Originalspalte abgeleitet (nie=1 ...
# immer=6), nicht ueber eine angenommene feste numerische Kodierung. Fallback: eine
# bereits numerische Zahl 1-6 wird direkt uebernommen. Alles andere -> NA (sichtbar
# gemacht, nicht stillschweigend auf einen Default gesetzt).
edi2_stufe_aus_item = function(spalte_orig, wert) {
if (is.null(wert) || length(wert) == 0 || is.na(wert)) {
return(list(stufe = NA_integer_, antwort = NA_character_))
}
if (haven::is.labelled(spalte_orig)) {
lbl = attr(spalte_orig, "labels")
if (!is.null(lbl) && length(lbl) > 0) {
pos = which(as.numeric(lbl) == as.numeric(wert))
if (length(pos) > 0) {
antwort_text = trimws(as.character(names(lbl)[pos[1]]))
stufe = match(tolower(antwort_text), edi2_kategorien_norm)
if (!is.na(stufe)) return(list(stufe = as.integer(stufe), antwort = antwort_text))
}
}
}
wert_num = suppressWarnings(as.numeric(wert))
if (!is.na(wert_num) && wert_num %in% 1:6) {
return(list(stufe = as.integer(wert_num), antwort = edi2_kategorien[wert_num]))
}
list(stufe = NA_integer_, antwort = NA_character_)
}
# Skalenzuordnung wird aus dem Spaltennamen abgeleitet (Suffix nach dem letzten
# Unterstrich), nicht hart codiert - robuster und spiegelt exakt die xlsx-Struktur wider.
edi2_baue_item_map = function(daten) {
spalten = names(daten)
treffer = grep("^edi2_[0-9]{2}_[a-z]+$", spalten, value = TRUE)
if (length(treffer) == 0) {
stop("Keine EDI-2-Item-Spalten (Muster 'edi2_NN_kuerzel') in den Daten gefunden.")
}
nr = as.integer(sub("^edi2_([0-9]{2})_[a-z]+$", "\\1", treffer))
skala = sub("^edi2_[0-9]{2}_([a-z]+)$", "\\1", treffer)
item_map = data.frame(nr = nr, spalte = treffer, skala = skala, stringsAsFactors = FALSE)
item_map = item_map[order(item_map$nr), , drop = FALSE]
if (nrow(item_map) != 91 || !setequal(item_map$nr, 1:91)) {
stop(paste0("Erwartet werden 91 EDI-2-Items (edi2_01_.. bis edi2_91_..), gefunden: ",
nrow(item_map), "."))
}
item_map
}
# Konservative Annahme des App-Bauers, nicht aus dem Manual belegt: enthaelt eine Skala
# auch nur ein fehlendes Item, wird sie nicht berechnet (keine Schaetzung/Hochrechnung).
edi2_berechne_skalenwert = function(items, item_map, skala_kuerzel, umkehr_items) {
idx = item_map$nr[item_map$skala == skala_kuerzel]
stufen = sapply(idx, function(nr) items[[nr]]$stufe)
if (any(is.na(stufen))) {
return(list(rohwert = NA_integer_, auswertbar = FALSE))
}
roh = sapply(idx, function(nr) {
s = items[[nr]]$stufe
if (nr %in% umkehr_items) 7L - s else s
})
list(rohwert = as.integer(sum(roh)), auswertbar = TRUE)
}
# Generische lineare Interpolation zwischen den nicht-NA Stuetzpunkten einer Skala in
# einer Normtabelle. Deckt die drei bekannten Dateneigenheiten der Normtabellen (siehe
# Datenaufbereitung) ab, ohne sie tabellen-/skalenspezifisch hart zu codieren:
# NA-Stuetzpunkte werden generell uebersprungen (springt zum naechsten verfuegbaren
# Stuetzpunkt), eine an der Spitze (P99) fehlende Stuetzstelle wird als "im Original
# nicht ausgewertet" gekennzeichnet, und ein nicht-monotoner Abschnitt in der
# Quelltabelle wird erkannt und mit Hinweistext versehen statt korrigiert (der
# Tabellenwert wird so verwendet, wie er dasteht).
edi2_perzentil_lookup = function(rohwert, tabelle, skala) {
if (is.null(rohwert) || is.na(rohwert)) {
return(list(text = "nicht auswertbar (fehlende Antwort)", numeric = NA_real_,
hinweis_nonmonoton = FALSE))
}
if (is.null(tabelle) || !(skala %in% names(tabelle))) {
return(list(text = "nicht auswertbar (Normtabelle/Skala fehlt)", numeric = NA_real_,
hinweis_nonmonoton = FALSE))
}
perzentil_max_struktur = max(tabelle$perzentil, na.rm = TRUE)
p99_zelle = tabelle[[skala]][tabelle$perzentil == perzentil_max_struktur]
p99_original_fehlt = length(p99_zelle) == 0 || is.na(p99_zelle[1])
tab = data.frame(perzentil = tabelle$perzentil, wert = tabelle[[skala]])
tab = tab[!is.na(tab$wert), , drop = FALSE]
tab = tab[order(tab$perzentil), , drop = FALSE]
if (nrow(tab) == 0) {
return(list(text = "nicht auswertbar (keine Stuetzpunkte)", numeric = NA_real_,
hinweis_nonmonoton = FALSE))
}
idx_min = which.min(tab$wert)
if (rohwert <= tab$wert[idx_min]) {
return(list(text = paste0("< ", tab$perzentil[idx_min], ". Perzentil"),
numeric = NA_real_, hinweis_nonmonoton = FALSE))
}
if (nrow(tab) >= 2) {
# Absteigend ab dem hoechsten Perzentil-Paar durchsucht: faellt ein Rohwert in den
# Ueberschneidungsbereich zweier Segmente (moeglich, wenn ein spaeteres Segment durch
# einen nicht-monotonen Sprung wie bei b3/Skala i einen kleineren Wertebereich als sein
# Vorgaenger-Segment abdeckt), soll das dem Tabellenende naechste Segment - und damit
# der nicht-monotone Sprung selbst - erkannt werden, statt still durch das fruehere,
# "unauffaellige" Segment ueberdeckt zu werden.
for (i in seq(nrow(tab) - 1, 1, by = -1)) {
w_unten = tab$wert[i]; w_oben = tab$wert[i + 1]
lo = min(w_unten, w_oben); hi = max(w_unten, w_oben)
if (rohwert >= lo && rohwert <= hi) {
p_unten = tab$perzentil[i]; p_oben = tab$perzentil[i + 1]
nonmonoton = w_oben < w_unten
p_interp = if (w_oben == w_unten) p_unten else
p_unten + (rohwert - w_unten) / (w_oben - w_unten) * (p_oben - p_unten)
return(list(text = paste0(round(p_interp, 1), ". Perzentil"),
numeric = p_interp, hinweis_nonmonoton = nonmonoton))
}
}
}
idx_max = which.max(tab$wert)
zusatz = if (p99_original_fehlt) {
" (obere Grenze fuer diese Skala im Original nicht ausgewertet)"
} else ""
list(text = paste0("> ", tab$perzentil[idx_max], ". Perzentil", zusatz),
numeric = NA_real_, hinweis_nonmonoton = FALSE)
}
# Gruppiert die 91 Items fuer die Itemliste (UI und Word-Export) nach Skala (kanonische
# Reihenfolge aus edi2_skalennamen) und sortiert innerhalb jeder Skala absteigend nach
# Antwortwert (Items ohne zuordenbaren Wert ans Ende der jeweiligen Skala).
edi2_gruppiere_items_nach_skala = function(items) {
lapply(names(edi2_skalennamen), function(sk) {
items_sk = Filter(function(it) identical(it$skala, sk), items)
sortierschluessel = sapply(items_sk, function(it) if (is.na(it$stufe)) 7L else 6L - it$stufe)
items_sk = items_sk[order(sortierschluessel)]
list(skala = sk, name = unname(edi2_skalennamen[sk]), items = items_sk)
})
}
# Datenaufbereitung ####
# Strukturprotokoll des Nutzers, item-fuer-item gegen die Itemtexte plausibilisiert
# (jedes gelistete Item positiv/adaptiv formuliert, jedes nicht gelistete negativ/
# pathologisch). Rohwert-Umpolung 7 - Rohwert. Nicht selbst veraendern.
edi2_umkehr_items = c(1, 12, 15, 17, 19, 20, 22, 23, 26, 30, 31, 37, 39, 42, 50, 55, 57,
58, 62, 69, 71, 73, 76, 80, 89, 91)
# Volle Skalenbezeichnungen aus etablierter EDI-2-Literatur, nicht direkt aus dem vom
# Nutzer gelieferten Strukturprotokoll-Auszug bestaetigt. Bei Bedarf hier austauschen.
# Reihenfolge = kanonische EDI-2-Skalenreihenfolge, dient auch als Anzeigereihenfolge.
edi2_skalennamen = c(
ss = "Schlankheitsstreben",
b = "Bulimie",
uk = "Unzufriedenheit mit dem Koerper",
i = "Ineffektivitaet",
p = "Perfektionismus",
m = "Misstrauen",
iw = "Interozeptive Wahrnehmung",
ae = "Angst vor dem Erwachsenwerden",
a = "Askese",
ir = "Impulsregulation",
su = "Soziale Unsicherheit"
)
edi2_normtabellen_meta = data.frame(
key = c("frauen_kontrolle", "maenner_kontrolle", "an_restriktiv", "an_purging", "bulimia"),
datei = c("b1_frauen_kontrolle.csv", "b2_maenner_kontrolle.csv", "b3_an_restriktiv.csv",
"b4_an_purging.csv", "b5_bulimia.csv"),
label = c("weibliche Kontrollgruppe (n=186)", "maennliche Kontrollgruppe (n=102)",
"Anorexia nervosa, restriktiver Typ (n=146)",
"Anorexia nervosa, purging Typ (n=100)", "Bulimia nervosa (n=217)"),
stringsAsFactors = FALSE
)
edi2_normtabellen = list()
edi2_normtabellen_fehler = character(0)
for (i in seq_len(nrow(edi2_normtabellen_meta))) {
key = edi2_normtabellen_meta$key[i]
datei = edi2_normtabellen_meta$datei[i]
pfad = file.path(PFAD_NORMTABELLEN, datei)
if (!file.exists(pfad)) {
edi2_normtabellen_fehler = c(edi2_normtabellen_fehler,
paste0(datei, " (erwartet unter ", pfad, ")"))
next
}
eingelesen = tryCatch(
list(ok = TRUE, tab = read.csv(pfad, na.strings = c("", "NA", "-", "—"),
stringsAsFactors = FALSE)),
error = function(e) list(ok = FALSE, msg = e$message)
)
if (isTRUE(eingelesen$ok)) {
edi2_normtabellen[[key]] = eingelesen$tab
} else {
edi2_normtabellen_fehler = c(edi2_normtabellen_fehler,
paste0(datei, ": Lesefehler (", eingelesen$msg, ")"))
}
}
edi2_erwartete_normtabellen_spalten = c("perzentil", names(edi2_skalennamen), "gesamt")
for (key in names(edi2_normtabellen)) {
tab = edi2_normtabellen[[key]]
fehlende_spalten = setdiff(edi2_erwartete_normtabellen_spalten, names(tab))
if (length(fehlende_spalten) > 0) {
datei_name = edi2_normtabellen_meta$datei[edi2_normtabellen_meta$key == key]
edi2_normtabellen_fehler = c(edi2_normtabellen_fehler,
paste0(datei_name, ": fehlende Spalte(n) ", paste(fehlende_spalten, collapse = ", ")))
edi2_normtabellen[[key]] = NULL
}
}
# a7_skalenwerte_gruppen.csv dient nur als deskriptive Zusatzangabe (M/SD je
# Referenzgruppe), nicht fuer den Perzentilrang-Lookup. Angenommenes Format (in dieser
# Session nicht am Original verifizierbar): Long-Format mit Spalten gruppe, skala, m, sd,
# wobei "gruppe" dieselben Schluessel wie edi2_normtabellen_meta$key verwendet. Falls das
# tatsaechliche Dateiformat abweicht, hier anpassen - die App bleibt in diesem Fall
# nutzbar, zeigt aber "nicht verfuegbar" statt M/SD.
PFAD_A7 = file.path(PFAD_NORMTABELLEN, "a7_skalenwerte_gruppen.csv")
edi2_a7 = NULL
edi2_a7_verfuegbar = FALSE
if (file.exists(PFAD_A7)) {
edi2_a7_roh = tryCatch(read.csv(PFAD_A7, stringsAsFactors = FALSE), error = function(e) NULL)
if (!is.null(edi2_a7_roh)) {
names(edi2_a7_roh) = tolower(trimws(names(edi2_a7_roh)))
if (all(c("gruppe", "skala", "m", "sd") %in% names(edi2_a7_roh))) {
edi2_a7 = edi2_a7_roh
edi2_a7_verfuegbar = TRUE
}
}
}
edi2_a7_lookup = function(gruppe_key, skala_kuerzel) {
if (!edi2_a7_verfuegbar) return(NULL)
z = edi2_a7[edi2_a7$gruppe == gruppe_key & edi2_a7$skala == skala_kuerzel, ]
if (nrow(z) == 0) return(NULL)
list(m = suppressWarnings(as.numeric(z$m[1])), sd = suppressWarnings(as.numeric(z$sd[1])))
}
# 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: 14px;
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; }
.kritischer-block {
background-color: #6D0000;
color: white;
border-radius: 5px;
padding: 16px 20px;
margin-bottom: 16px;
border-left: 6px solid #FF6B6B;
}
.kritischer-block h4 { margin: 0 0 10px; font-size: 1.1em; font-weight: 700; }
.kritischer-block .antwort-text {
background: rgba(255,255,255,0.12);
border-radius: 3px;
padding: 8px 11px;
margin: 7px 0;
font-size: 0.94em;
line-height: 1.5;
}
.kritischer-block .disclaimer {
margin-top: 11px;
font-size: 0.83em;
opacity: 0.85;
font-style: italic;
}
.kritisches-item {
border: 2px solid #B71C1C !important;
border-radius: 4px;
background-color: #FEECEB;
padding-left: 8px !important;
}
.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; }
.skalen-grid {
display: grid;
grid-template-columns: repeat(auto-fit, minmax(270px, 1fr));
gap: 14px;
margin-bottom: 14px;
}
.skala-titel { color: #8B2635; font-weight: 700; font-size: 0.98em; margin-bottom: 6px; }
.skala-rohwert { font-size: 1.7em; font-weight: 800; color: #333; display: block; }
.skala-perzentil { font-size: 0.95em; font-weight: 600; color: #8B2635; display: block; margin-top: 2px; }
.skala-referenz { font-size: 0.8em; color: #888; margin-top: 6px; }
.skala-hinweis {
font-size: 0.78em; color: #B8860B; margin-top: 6px; font-style: italic; line-height: 1.4;
}
.gesamtwert-karte {
background: #FFF8F0;
border: 1px solid #F0DCC0;
border-radius: 6px;
padding: 16px 20px;
margin-bottom: 14px;
}
.gesamtwert-zahl { font-size: 2.2em; font-weight: 800; color: #8B2635; display: block; }
.gesamtwert-hinweis {
font-size: 0.86em;
color: #7A5C1E;
background: #FFF3D6;
border-radius: 4px;
padding: 8px 11px;
margin-top: 8px;
line-height: 1.5;
}
.item-zeile {
display: flex;
align-items: flex-start;
gap: 10px;
padding: 7px 4px;
border-bottom: 1px solid #F0F0F0;
}
.item-nr { font-weight: 700; color: #8B2635; min-width: 28px; flex-shrink: 0; }
.item-text { flex: 1; color: #333; font-size: 0.92em; line-height: 1.4; }
.item-antwort { display: flex; align-items: baseline; gap: 8px; flex-shrink: 0; }
.item-skala { color: #999; font-size: 0.8em; min-width: 26px; text-align: right; }
.item-skala-titel {
color: #8B2635;
font-weight: 700;
font-size: 0.88em;
text-transform: uppercase;
letter-spacing: 0.02em;
margin-top: 16px;
margin-bottom: 4px;
padding-bottom: 3px;
border-bottom: 1px solid #eee;
}
.stufe-badge {
display: inline-block;
border-radius: 3px;
padding: 2px 9px;
font-size: 0.85em;
font-weight: 700;
min-width: 90px;
text-align: center;
}
.stufe-badge-1 { background-color: #C8E6C9; color: #1B5E20; }
.stufe-badge-2 { background-color: #E6F0C2; color: #4E6B1F; }
.stufe-badge-3 { background-color: #F5E6C8; color: #8A6D3B; }
.stufe-badge-4 { background-color: #F8CFC0; color: #A13B22; }
.stufe-badge-5 { background-color: #F3A6A6; color: #8B1A1A; }
.stufe-badge-6 { background-color: #B71C1C; color: white; }
.stufe-badge-na { background-color: #bbb; color: white; }
.disclaimer-fuss {
font-size: 0.82em;
color: #888;
font-style: italic;
margin-top: 10px;
line-height: 1.5;
}
.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$style(HTML(app_css))),
div(class = "app-header",
tags$h2("EDI-2 (Eating Disorder Inventory-2)"),
tags$p("Deutsche Fassung • Einzelfall-Auswertung mit Normtabellen (Perzentilrang)")
),
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%")
),
div(style = "min-width: 260px;",
selectInput("vergleichsgruppe", label = "Vergleichsgruppe",
choices = setNames(edi2_normtabellen_meta$key, edi2_normtabellen_meta$label),
selected = "frauen_kontrolle", width = "100%")
),
actionButton("btn_suchen", "Auswerten", class = "btn btn-primary btn-laden"),
div(style = "margin-left: auto;",
downloadButton("download_word", "Word-Export (.docx)")
)
),
uiOutput("normtabellen_start_fehler_ui"),
uiOutput("ergebnis_ui")
)
# Word-Export ####
erstelle_edi2_docx = function(erg, auswertung, vergleichsgruppe_label) {
stufe_bg = function(stufe) {
if (is.na(stufe)) return("#EEEEEE")
switch(as.character(stufe),
"1" = "#C8E6C9", "2" = "#E6F0C2", "3" = "#F5E6C8",
"4" = "#F8CFC0", "5" = "#F3A6A6", "6" = "#B71C1C", "#EEEEEE")
}
stufe_fg = function(stufe) {
if (is.na(stufe) || stufe < 6L) "#333333" else "#FFFFFF"
}
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 = 13, underlined = TRUE)
fmt_skala_l = fp_text(color = "#333333", bold = TRUE, font.size = 10)
fmt_skala_v = fp_text(color = "#555555", bold = FALSE, font.size = 10)
fmt_gesamt_l = fp_text(color = "#888888", bold = FALSE, font.size = 10)
fmt_gesamt = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18)
fmt_gesamthin = fp_text(color = "#7A5C1E", italic = TRUE, font.size = 9)
fmt_item_nr = fp_text(color = "#888888", bold = TRUE, font.size = 10)
fmt_item_tit = fp_text(color = "#333333", bold = FALSE, font.size = 10)
fmt_disclaimer = fp_text(color = "#888888", italic = TRUE, font.size = 9)
fmt_krit_titel = fp_text(color = "#B71C1C", bold = TRUE, font.size = 12)
fmt_krit_text = fp_text(color = "#B71C1C", font.size = 10)
fmt_krit_note = fp_text(color = "#888888", italic = TRUE, font.size = 9)
doc = read_docx()
doc = body_add_fpar(doc, fpar(ftext("EDI-2 Auswertung", fmt_titel)))
doc = body_add_fpar(doc, fpar(ftext(
paste0("Chiffre: ", erg$chiffre,
" Ausfuelldatum: ", erg$ausfuelldatum,
" Geschlecht: ", if (is.na(erg$geschlecht)) "nicht zuordenbar" else erg$geschlecht,
" Vergleichsgruppe: ", vergleichsgruppe_label),
fmt_meta
)))
if (!is.null(erg$warnung_mehrfach)) {
doc = body_add_fpar(doc, fpar(ftext(paste0("Hinweis: ", erg$warnung_mehrfach), fmt_warn)))
}
if (erg$n_nicht_zuordenbar > 0) {
doc = body_add_fpar(doc, fpar(ftext(
paste0(erg$n_nicht_zuordenbar, " von 91 Items nicht zuordenbar."), fmt_warn)))
}
doc = body_add_par(doc, "")
if (erg$kritisch_flag) {
doc = body_add_fpar(doc, fpar(ftext(
"Kritisches Item 90 - bitte gesondert beachten", fmt_krit_titel)))
doc = body_add_fpar(doc, fpar(ftext(erg$item90$text, fmt_krit_text)))
doc = body_add_fpar(doc, fpar(ftext(
paste0("Gewaehlte Antwort: ", erg$item90$antwort), fmt_krit_text)))
doc = body_add_fpar(doc, fpar(ftext(
"(Kein automatisiertes klinisches Urteil, bei Bedarf zeitnah persoenliche Ruecksprache halten.)",
fmt_krit_note)))
doc = body_add_par(doc, "")
}
doc = body_add_fpar(doc, fpar(ftext("Skalenwerte (Rohwertsumme, Perzentilrang)", fmt_abschn)))
for (row in auswertung) {
doc = body_add_fpar(doc, fpar(
ftext(paste0(row$name, ": "), fmt_skala_l),
ftext(paste0("Rohwert ", if (is.na(row$rohwert)) "nicht auswertbar" else row$rohwert,
" - ", row$perzentil_text), fmt_skala_v)
))
if (!is.null(row$referenz_text)) {
doc = body_add_fpar(doc, fpar(ftext(row$referenz_text, fmt_disclaimer)))
}
if (isTRUE(row$hinweis_nonmonoton)) {
doc = body_add_fpar(doc, fpar(ftext(
paste0("Hinweis: In diesem Wertebereich ist die Quelltabelle selbst nicht monoton ",
"(Originalquelle), der interpolierte Perzentilrang ist mit Vorsicht zu ",
"interpretieren."), fmt_warn)))
}
}
doc = body_add_par(doc, "")
doc = body_add_fpar(doc, fpar(ftext("Gesamtwert", fmt_abschn)))
doc = body_add_fpar(doc, fpar(
ftext("Summe aller elf Skalen: ", fmt_gesamt_l),
ftext(if (is.na(erg$gesamtwert)) "nicht auswertbar" else as.character(erg$gesamtwert),
fmt_gesamt)
))
doc = body_add_fpar(doc, fpar(ftext(EDI2_GESAMTWERT_HINWEIS, fmt_gesamthin)))
doc = body_add_par(doc, "")
doc = body_add_fpar(doc, fpar(ftext(
"Einzelitems (91 Items, nach Skala geclustert, innerhalb absteigend nach Antwortwert sortiert)",
fmt_abschn)))
fmt_skala_gruppe = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 10.5)
item_gruppen_docx = edi2_gruppiere_items_nach_skala(erg$items)
for (gruppe in item_gruppen_docx) {
doc = body_add_fpar(doc, fpar(ftext(
paste0(gruppe$name, " (", toupper(gruppe$skala), ")"), fmt_skala_gruppe)))
for (it in gruppe$items) {
stufe_text = if (is.na(it$stufe)) "?" else paste0(edi2_kategorien[it$stufe], " (", it$stufe, ")")
prefix = if (it$nr == 90) "[Item 90 - kritisch] " else ""
doc = body_add_fpar(doc, fpar(
ftext(sprintf("%2d. %s", it$nr, prefix), fmt_item_nr),
ftext(paste0(it$text, " "), fmt_item_tit),
ftext(paste0(" ", stufe_text, " "),
fp_text(color = stufe_fg(it$stufe), bold = TRUE, font.size = 9,
shading.color = stufe_bg(it$stufe)))
))
}
}
doc = body_add_par(doc, "")
doc = body_add_fpar(doc, fpar(ftext(EDI2_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)))
}
})
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_dl = tryCatch({
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE); TRUE
}, error = function(e) {
list(typ = "skript_fehler",
meldung = paste0("Fehler im Download-Skript (",
basename(PFAD_DOWNLOAD_SKRIPT), "):\n", e$message))
})
if (is.list(ok_dl)) return(ok_dl)
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."
)))
}
ok_ps = 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]))
}; TRUE
}, error = function(e) {
list(typ = "skript_fehler",
meldung = paste0("Fehler im Pseudonym-Skript (",
basename(PFAD_PSEUDONYM_SKRIPT), "):\n", e$message))
})
if (is.list(ok_ps)) return(ok_ps)
if (!exists("daten_edi2", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = paste0("Objekt 'daten_edi2' 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_edi = get("daten_edi2", 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)
edi_treffer = dat_edi[dat_edi$session %in% alle_session_ids, , drop = FALSE]
if (nrow(edi_treffer) == 0) {
return(list(typ = "session_nicht_gefunden",
chiffre = chiffre,
session_id = paste(alle_session_ids, collapse = ", ")))
}
warnung_mehrfach = NULL
if (nrow(edi_treffer) > 1) {
n_ausfuell = nrow(edi_treffer)
edi_treffer = edi_treffer %>% arrange(desc(created)) %>% slice(1)
datum_neu = format(as.POSIXct(edi_treffer$created[1]),
"%d.%m.%Y %H:%M", tz = "Europe/Berlin")
warnung_mehrfach = paste0(
n_ausfuell, " Ausfuellungen gefunden. ",
"Es wird die neueste angezeigt (", datum_neu, ")."
)
}
zeile = edi_treffer[1, , drop = FALSE]
ausfuelldatum = format(as.POSIXct(zeile$created[1]), "%d.%m.%Y", tz = "Europe/Berlin")
item_map_res = tryCatch(list(ok = TRUE, map = edi2_baue_item_map(dat_edi)),
error = function(e) list(ok = FALSE, msg = e$message))
if (!isTRUE(item_map_res$ok)) {
return(list(typ = "skript_fehler",
meldung = paste0("Problem mit der Item-Struktur von daten_edi2:\n", item_map_res$msg)))
}
item_map = item_map_res$map
geschlecht_roh = zeile[["edi2_geschlecht"]][1]
spalte_gsch = dat_edi[["edi2_geschlecht"]]
geschlecht_txt = if (haven::is.labelled(spalte_gsch)) {
lbl = attr(spalte_gsch, "labels")
pos = which(as.numeric(lbl) == as.numeric(geschlecht_roh))
if (length(pos) > 0) trimws(as.character(names(lbl)[pos[1]])) else NA_character_
} else {
trimws(as.character(geschlecht_roh))
}
geschlecht = if (!is.na(geschlecht_txt) && grepl("^weiblich$", geschlecht_txt, ignore.case = TRUE)) {
"weiblich"
} else if (!is.na(geschlecht_txt) && grepl("^m(a|ä)nnlich$", geschlecht_txt, ignore.case = TRUE)) {
"maennlich"
} else {
NA_character_
}
items = lapply(seq_len(91), function(nr) {
spalte_name = item_map$spalte[item_map$nr == nr]
skala = item_map$skala[item_map$nr == nr]
spalte_orig = dat_edi[[spalte_name]]
wert = zeile[[spalte_name]][1]
item_label_roh = attr(spalte_orig, "label")
item_text = if (!is.null(item_label_roh) && !is.na(item_label_roh)) {
bereinige_markdown(item_label_roh)
} else {
paste0("Item ", nr)
}
sr = edi2_stufe_aus_item(spalte_orig, wert)
list(nr = nr, spalte = spalte_name, skala = skala, text = item_text,
stufe = sr$stufe, antwort = sr$antwort)
})
n_nicht_zuordenbar = sum(sapply(items, function(it) is.na(it$stufe)))
skalenwerte = lapply(names(edi2_skalennamen), function(sk) {
edi2_berechne_skalenwert(items, item_map, sk, edi2_umkehr_items)
})
names(skalenwerte) = names(edi2_skalennamen)
alle_auswertbar = all(sapply(skalenwerte, function(s) s$auswertbar))
gesamtwert = if (alle_auswertbar) {
as.integer(sum(sapply(skalenwerte, function(s) s$rohwert)))
} else NA_integer_
item90 = items[[90]]
kritisch_flag = !is.na(item90$stufe) && item90$stufe >= 4L
list(
typ = "ergebnis",
chiffre = chiffre,
ausfuelldatum = ausfuelldatum,
warnung_mehrfach = warnung_mehrfach,
geschlecht = geschlecht,
items = items,
n_nicht_zuordenbar = n_nicht_zuordenbar,
skalenwerte = skalenwerte,
gesamtwert = gesamtwert,
item90 = item90,
kritisch_flag = kritisch_flag
)
})
# Vorbelegung der Vergleichsgruppe anhand von edi2_geschlecht - eine fachliche
# Entscheidung der auswertenden Person, daher nur Vorschlag, frei umstellbar.
observeEvent(ergebnis_r(), {
erg = ergebnis_r()
if (!identical(erg$typ, "ergebnis")) return()
vorschlag = if (identical(erg$geschlecht, "weiblich")) {
"frauen_kontrolle"
} else if (identical(erg$geschlecht, "maennlich")) {
"maenner_kontrolle"
} else NULL
if (!is.null(vorschlag)) {
updateSelectInput(session, "vergleichsgruppe", selected = vorschlag)
}
})
auswertung_r = reactive({
erg = tryCatch(ergebnis_r(), error = function(e) NULL)
if (is.null(erg) || !identical(erg$typ, "ergebnis")) return(NULL)
gruppe_key = input$vergleichsgruppe
tabelle = edi2_normtabellen[[gruppe_key]]
gruppe_label = edi2_normtabellen_meta$label[edi2_normtabellen_meta$key == gruppe_key]
lapply(names(edi2_skalennamen), function(sk) {
rohwert = erg$skalenwerte[[sk]]$rohwert
lk = edi2_perzentil_lookup(rohwert, tabelle, sk)
ref = edi2_a7_lookup(gruppe_key, sk)
referenz_text = if (!is.null(ref) && !is.na(ref$m) && !is.na(ref$sd)) {
paste0("Referenzgruppe M = ", round(ref$m, 1), ", SD = ", round(ref$sd, 1),
" (deskriptive Zusatzangabe, kein eigenstaendiger Normwert)")
} else {
"M/SD der Referenzgruppe nicht verfuegbar"
}
list(skala = sk, name = unname(edi2_skalennamen[sk]), rohwert = rohwert,
perzentil_text = lk$text, hinweis_nonmonoton = lk$hinweis_nonmonoton,
referenz_text = referenz_text, gruppe_label = gruppe_label)
})
})
output$normtabellen_start_fehler_ui = renderUI({
if (length(edi2_normtabellen_fehler) == 0) return(NULL)
div(class = "alert-fehler",
tags$h4("Normtabellen unvollstaendig"),
tags$p("Folgende Normtabellen in ", tags$code(PFAD_NORMTABELLEN),
" fehlen oder sind fehlerhaft. Betroffene Perzentilraenge sind bis zur ",
"Behebung nicht auswertbar:"),
tags$ul(lapply(edi2_normtabellen_fehler, tags$li))
)
})
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 == "session_nicht_gefunden") {
return(div(class = "alert-fehler",
tags$h4("Kein EDI-2-Datensatz gefunden"),
tags$p("Zur Chiffre ", tags$b(paste0("«", erg$chiffre, "»")),
" existiert ein Pseudonymeintrag, aber kein Datensatz in ",
tags$code("daten_edi2"), "."),
tags$p("Moegliche Ursachen: Bogen noch nicht ausgefuellt, ",
"oder Daten noch nicht heruntergeladen.")
))
}
auswertung = auswertung_r()
kritischer_block = if (erg$kritisch_flag) {
div(class = "kritischer-block",
tags$h4("Bitte Item 90 gesondert beachten"),
tags$p(erg$item90$text),
div(class = "antwort-text",
tags$b("Gewaehlte Antwort: "), erg$item90$antwort
),
tags$p(class = "disclaimer",
"Dieser Hinweis ist kein automatisiertes klinisches Urteil, sondern ein ",
"Aufmerksamkeitshinweis fuer die behandelnde Person. Bei Bedarf zeitnah ",
"persoenliche Ruecksprache halten."
)
)
} else NULL
kopf_block = div(class = "abschnitt-karte",
div(class = "kopf-info",
tags$b("Chiffre: "), erg$chiffre, " ",
tags$b("Ausfuelldatum: "), erg$ausfuelldatum, " ",
tags$b("Geschlecht: "), if (is.na(erg$geschlecht)) "nicht zuordenbar" else erg$geschlecht, " ",
tags$b("Vergleichsgruppe: "),
edi2_normtabellen_meta$label[edi2_normtabellen_meta$key == input$vergleichsgruppe]
),
if (!is.null(erg$warnung_mehrfach))
div(class = "alert-warnung", "⚠ Hinweis: ", erg$warnung_mehrfach),
if (erg$n_nicht_zuordenbar > 0)
div(class = "alert-warnung", "⚠ ", erg$n_nicht_zuordenbar,
" von 91 Items nicht zuordenbar (Antwortwert weder als bekannter Text ",
"noch als Zahl 1-6 erkennbar).")
)
skalen_karten = lapply(auswertung, function(row) {
div(class = "abschnitt-karte",
div(class = "skala-titel", row$name, " (", toupper(row$skala), ")"),
tags$span(class = "skala-rohwert",
if (is.na(row$rohwert)) "nicht auswertbar (fehlende Antwort)" else row$rohwert),
tags$span(class = "skala-perzentil", row$perzentil_text),
div(class = "skala-referenz", row$referenz_text),
if (isTRUE(row$hinweis_nonmonoton))
div(class = "skala-hinweis",
"Hinweis: In diesem Wertebereich ist die Quelltabelle selbst nicht monoton ",
"(Originalquelle), der interpolierte Perzentilrang ist mit Vorsicht zu ",
"interpretieren."
)
)
})
gesamtwert_block = div(class = "gesamtwert-karte",
div(class = "skala-titel", "Gesamtwert (Summe aller elf Skalen)"),
tags$span(class = "gesamtwert-zahl",
if (is.na(erg$gesamtwert)) "nicht auswertbar" else erg$gesamtwert),
div(class = "gesamtwert-hinweis", EDI2_GESAMTWERT_HINWEIS)
)
item_zeile_erstellen = function(it) {
if (is.na(it$stufe)) {
badge_class = "stufe-badge stufe-badge-na"
badge_text = "?"
} else {
badge_class = paste0("stufe-badge stufe-badge-", it$stufe)
badge_text = edi2_kategorien[it$stufe]
}
div(class = paste0("item-zeile", if (it$nr == 90) " kritisches-item" else ""),
tags$span(class = "item-nr", paste0(it$nr, ".")),
tags$span(class = "item-text", it$text),
div(class = "item-antwort",
tags$span(class = badge_class, badge_text),
tags$span(class = "item-skala", toupper(it$skala))
)
)
}
item_gruppen = edi2_gruppiere_items_nach_skala(erg$items)
item_gruppen_blocks = lapply(item_gruppen, function(gruppe) {
tagList(
div(class = "item-skala-titel", gruppe$name, " (", toupper(gruppe$skala), ")"),
lapply(gruppe$items, item_zeile_erstellen)
)
})
item_block = div(class = "abschnitt-karte",
tags$h4(class = "abschnitt-titel",
"Einzelitems (91 Items, nach Skala geclustert, innerhalb absteigend nach Antwortwert sortiert)"),
item_gruppen_blocks
)
tagList(
kritischer_block,
kopf_block,
div(class = "skalen-grid", skalen_karten),
gesamtwert_block,
item_block,
div(class = "disclaimer-fuss", EDI2_DISCLAIMER)
)
})
output$download_word = downloadHandler(
filename = function() {
erg = ergebnis_r()
if (is.null(erg) || erg$typ != "ergebnis") return("EDI2_Auswertung.docx")
chiffre_esc = gsub("[^A-Za-z0-9_-]", "_", erg$chiffre)
ausfuelldatum_fn = format(as.Date(erg$ausfuelldatum, "%d.%m.%Y"), "%Y%m%d")
paste0("EDI2_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
},
content = function(file) {
req(ergebnis_r()$typ == "ergebnis")
erg = ergebnis_r()
auswertung = auswertung_r()
gruppe_label = edi2_normtabellen_meta$label[edi2_normtabellen_meta$key == input$vergleichsgruppe]
doc = erstelle_edi2_docx(erg, auswertung, gruppe_label)
print(doc, target = file)
}
)
}
# Start ####
shinyApp(ui = ui, server = server)
Reference in a new issue View git blame Copy permalink