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

1034 lines
37 KiB
R
Raw Blame History

# Präambel ####
AKZENT_FARBE = "#8B2635"
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_scl90r.R"
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
SCL90R_DISCLAIMER = paste0(
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
"keine klinische Diagnose. T-Zonen (T<60 / 60-70 / >70) sind heuristische ",
"Orientierungshilfen, keine klinisch validierten Grenzwerte. ",
"Die Interpretation der Ergebnisse obliegt der behandelnden Person."
)
library(shiny)
library(dplyr)
library(ggplot2)
library(haven)
library(officer)
library(rvg)
# Infrastruktur ####
APP_VERZEICHNIS = normalizePath(getwd())
norm_dir = APP_VERZEICHNIS
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 ####
# VLOOKUP-Bereichsabgleich: naechstkleinerer Rohwert, Clamping nach oben
lookup_twert = function(rohwert, tabelle, spalte) {
if (is.null(tabelle) || !(spalte %in% names(tabelle))) return(NA)
if (is.na(rohwert)) return(NA)
kandidaten = tabelle[tabelle$rohwert <= rohwert, ]
if (nrow(kandidaten) == 0) return(NA)
zeile = kandidaten[which.max(kandidaten$rohwert), ]
wert = zeile[[spalte]]
if (length(wert) == 0 || is.na(wert) || wert == "") return(NA)
as.numeric(wert)
}
norm_spalte = function(geschlecht_num, geschlecht_labels, bildung_num, bildung_labels) {
if (is.null(geschlecht_labels) || is.null(bildung_labels)) return("m_gesamt")
tryCatch({
g_factor = haven::as_factor(structure(geschlecht_num,
labels = geschlecht_labels,
class = "haven_labelled"))
b_factor = haven::as_factor(structure(bildung_num,
labels = bildung_labels,
class = "haven_labelled"))
g_lbl = tolower(as.character(g_factor))
b_lbl = tolower(as.character(b_factor))
g_code = if (grepl("weibl|female|frau|f$", g_lbl)) "f" else "m"
b_code = if (grepl("haupt|real|main|secondary", b_lbl)) "haupt_real"
else if (grepl("abitur|abi|high|gymn", b_lbl)) "abitur"
else if (grepl("hochschul|universit|uni|college|degree", b_lbl)) "hochschule"
else "gesamt"
paste0(g_code, "_", b_code)
}, error = function(e) "m_gesamt")
}
rohwert_aus_item = function(x) {
if (is.null(x) || (length(x) == 1 && is.na(x))) return(NA_real_)
val = as.numeric(x)
if (!is.na(val) && val >= 0 && val <= 4) return(val)
lbls = attr(x, "labels")
if (!is.null(lbls)) {
lbl_namen = names(lbls)
for (i in seq_along(lbl_namen)) {
m = regmatches(lbl_namen[i], regexpr("^(\\d+)\\)", lbl_namen[i]))
if (length(m) > 0 && lbls[[i]] == as.numeric(x)) {
return(as.numeric(sub("\\).*", "", m)))
}
}
}
val
}
berechne_auswertung = function(zeile, norm_spalten_name) {
items = sapply(1:90, function(i) {
col = sprintf("scl90_item%02d", i)
if (col %in% names(zeile)) rohwert_aus_item(zeile[[col]]) else NA_real_
})
names(items) = sprintf("%02d", 1:90)
ergebnis = list()
ergebnis$items = items
for (sk in names(subskalen)[names(subskalen) != "Zusatzitems"]) {
idx = subskalen[[sk]]
werte = items[sprintf("%02d", idx)]
summe = sum(werte, na.rm = TRUE)
n_ok = sum(!is.na(werte))
skalenwert = if (n_ok > 0) summe / n_ok else NA_real_
twert = lookup_twert(summe, normtabellen[[sk]], norm_spalten_name)
ergebnis[[paste0("summe_", sk)]] = summe
ergebnis[[paste0("n_items_", sk)]] = n_ok
ergebnis[[paste0("skwert_", sk)]] = skalenwert
ergebnis[[paste0("twert_", sk)]] = twert
}
gs = sum(items, na.rm = TRUE)
missing_items = sum(is.na(items))
gsi = if ((90 - missing_items) > 0) gs / (90 - missing_items) else NA_real_
pst = sum(items > 0, na.rm = TRUE)
psdi = if (pst > 0) gs / pst else NA_real_
ergebnis$GS = gs
ergebnis$missing_items = missing_items
ergebnis$GSI = gsi
ergebnis$PST = pst
ergebnis$PSDI = psdi
ergebnis$T_GSI = lookup_twert(gs, normtabellen$GSI, norm_spalten_name)
ergebnis$T_PST = lookup_twert(pst, normtabellen$PST, norm_spalten_name)
ergebnis$T_PSDI = lookup_twert(psdi, normtabellen$PSDI, norm_spalten_name)
ergebnis
}
lade_normtabellen = function() {
tabs = list()
for (nm in names(norm_dateinamen)) {
pfad = file.path(norm_dir, norm_dateinamen[[nm]])
if (file.exists(pfad)) {
tabs[[nm]] = read.csv(pfad, stringsAsFactors = FALSE)
}
}
tabs
}
twert_anzeige = function(t) {
if (is.na(t)) return(tags$span(class = "na-hinweis", "nicht normiert"))
tags$strong(round(t))
}
twert_zone = function(t) {
if (is.na(t)) return("")
if (t < 60) "unauffällig (T < 60)"
else if (t <= 70) "erhöht (T 60-70)"
else "deutlich erhöht (T > 70)"
}
skwert_fmt = function(x) if (is.na(x)) "-" else sprintf("%.2f", x)
gauge_plot = function(t_wert, akzent) {
df_zonen = data.frame(
xmin = c(20, 60, 70),
xmax = c(60, 70, 90),
farbe = c("#d4edda", "#fff3cd", "#f8d7da"),
label = c("unauffällig", "erhöht", "deutlich erhöht")
)
p = ggplot() +
geom_rect(data = df_zonen,
aes(xmin = xmin, xmax = xmax, ymin = 0, ymax = 1, fill = farbe),
color = "white", linewidth = 0.3) +
scale_fill_identity() +
geom_text(data = df_zonen,
aes(x = (xmin + xmax) / 2, y = 0.5, label = label),
size = 3, color = "#555") +
scale_x_continuous(limits = c(20, 90), breaks = c(20, 30, 40, 50, 60, 70, 80, 90)) +
scale_y_continuous(limits = c(0, 1.4)) +
theme_void() +
theme(axis.text.x = element_text(size = 9, color = "#555"),
axis.ticks.x = element_line(color = "#aaa"),
axis.ticks.length = unit(3, "pt"),
panel.grid = element_blank()) +
labs(x = "T-Wert", y = NULL)
if (!is.na(t_wert)) {
t_clip = max(20, min(90, as.numeric(t_wert)))
p = p +
geom_segment(aes(x = t_clip, xend = t_clip, y = 0, yend = 1.2),
color = akzent, linewidth = 1.5) +
geom_point(aes(x = t_clip, y = 1.2), color = akzent, size = 4, shape = 25, fill = akzent) +
geom_text(aes(x = t_clip, y = 1.35, label = paste0("T = ", round(t_clip))),
color = akzent, size = 3.5, fontface = "bold")
}
p
}
profil_plot = function(auswertung, akzent) {
skalen_reihenfolge = c("Somatisierung", "Zwanghaftigkeit", "Unsicherheit",
"Depressivitaet", "Aengstlichkeit", "Aggressivitaet",
"Phobie", "Paranoia", "Psychotizismus", "GSI")
kurz_labels = c("Soma", "Zwang", "Unsich.", "Depr.", "Angst",
"Aggr.", "Phobie", "Paranoia", "Psychot.", "GSI")
t_werte = c(
sapply(skalen_reihenfolge[-10], function(sk) {
v = auswertung[[paste0("twert_", sk)]]
if (is.null(v)) NA_real_ else as.numeric(v)
}),
as.numeric(auswertung$T_GSI)
)
df = data.frame(
skala = factor(kurz_labels, levels = kurz_labels),
t_wert = t_werte,
stringsAsFactors = FALSE
)
df_ok = df[!is.na(df$t_wert), ]
p = ggplot(df, aes(x = skala, y = t_wert, group = 1)) +
annotate("rect", xmin = -Inf, xmax = Inf, ymin = 40, ymax = 60,
fill = "#00aa44", alpha = 0.15) +
geom_hline(yintercept = 40, linetype = "dashed", color = "#bbb", linewidth = 0.6) +
geom_hline(yintercept = 60, linetype = "dashed", color = "#aaa", linewidth = 0.6) +
geom_hline(yintercept = 70, linetype = "dashed", color = "#888", linewidth = 0.6) +
annotate("text", x = 10.4, y = 40, label = "T=40", size = 2.8, color = "#999",
hjust = 0, vjust = -0.3) +
annotate("text", x = 10.4, y = 60, label = "T=60", size = 2.8, color = "#888",
hjust = 0, vjust = -0.3) +
annotate("text", x = 10.4, y = 70, label = "T=70", size = 2.8, color = "#666",
hjust = 0, vjust = -0.3) +
scale_y_continuous(limits = c(20, 90), breaks = seq(20, 90, 10)) +
scale_x_discrete(drop = FALSE) +
coord_cartesian(clip = "off") +
theme_minimal(base_size = 11) +
theme(axis.text.x = element_text(angle = 35, hjust = 1, size = 9),
panel.grid.minor = element_blank(),
panel.grid.major.x = element_blank(),
plot.margin = margin(5, 55, 5, 5)) +
labs(x = NULL, y = "T-Wert",
caption = "T=40 / T=60 / T=70 sind heuristische Schwellen, keine klinischen Grenzwerte.")
if (nrow(df_ok) >= 2) {
p = p + geom_line(data = df_ok, color = akzent, linewidth = 0.9)
}
p = p + geom_point(data = df_ok, color = akzent, size = 3.5)
p
}
badge_html = function(stufe) {
s = as.character(stufe)
tags$span(class = paste0("stufe-badge stufe-badge-", s), s)
}
skala_items_html = function(item_nummern, items) {
tagList(lapply(item_nummern, function(i) {
nr = sprintf("%02d", i)
rw = items[[nr]]
rw_s = if (is.null(rw) || is.na(rw)) NA_integer_ else as.integer(rw)
st = if (is.na(rw_s)) "-" else stufen_texte[[as.character(rw_s)]]
div(class = "item-zeile",
tags$span(class = "item-nr", nr),
tags$span(class = "item-text", scl90_itemtexte[[nr]]),
tags$span(class = "item-stufentext", st),
if (!is.na(rw_s)) badge_html(rw_s) else tags$span(class = "na-hinweis", "?")
)
}))
}
# Datenaufbereitung ####
scl90_itemtexte = c(
"01" = "Kopfschmerzen",
"02" = "Nervositat oder innerem Zittern",
"03" = "Immer wieder auftauchenden unangenehmen Gedanken, Worten oder Ideen, die Ihnen nicht aus dem Kopf gehen.",
"04" = "Ohnmachts- und Schwindelgefuhle",
"05" = "Verminderung Ihres Interesses oder Ihrer Freude an Sexualitat",
"06" = "allzu kritischer Einstellung gegenuber anderen",
"07" = "der Idee, dass irgend jemand Macht uber Ihre Gedanken hat",
"08" = "dem Gefuhl, dass andere an den meisten Ihrer Schwierigkeiten Schuld sind",
"09" = "Gedachtnisschwierigkeiten",
"10" = "Beunruhigung wegen Achtlosigkeit und Nachlassigkeit",
"11" = "dem Gefuhl, leicht reizbar oder verargerbar zu sein",
"12" = "Herz- und Brustschmerzen",
"13" = "Furcht auf offenen Platzen oder Strassen",
"14" = "Energielosigkeit oder Verlangsamung in den Bewegungen oder im Denken",
"15" = "Gedanken, sich das Leben zu nehmen",
"16" = "Horen von Stimmen, die sonst keiner hort",
"17" = "Zittern",
"18" = "dem Gefuhl, dass man den meisten Menschen nicht trauen kann",
"19" = "schlechtem Appetit",
"20" = "Neigung zum Weinen",
"21" = "Schuchternheit oder Unbeholfenheit im Umgang mit dem anderen Geschlecht",
"22" = "der Befurchtung, ertappt oder erwischt zu werden",
"23" = "plotzlichem Erschrecken ohne Grund",
"24" = "Gefuhlsausbruchen, denen gegenuber Sie machtlos waren",
"25" = "Befurchtungen, wenn Sie alleine aus dem Haus gehen",
"26" = "Selbstvorwurfen uber bestimmten Dingen",
"27" = "Kreuzschmerzen",
"28" = "dem Gefuhl, dass es Ihnen schwer fallt etwas anzufangen",
"29" = "Einsamkeitsgefuhlen",
"30" = "Schwermut",
"31" = "dem Gefuhl, sich zu viele Sorgen machen zu mussen",
"32" = "dem Gefuhl, sich fur nichts zu interessieren",
"33" = "Furchtsamkeit",
"34" = "Verletzlichkeit in Gefuhlsdingen",
"35" = "der Idee, dass andere Leute von Ihren geheimsten Gedanken wissen",
"36" = "dem Gefuhl, dass andere Sie nicht verstehen oder teilnahmslos sind",
"37" = "dem Gefuhl, dass die Leute unfreundlich sind oder Sie nicht leiden konnen",
"38" = "die Notwendigkeit, alles sehr langsam zu tun, um sicher zu sein, dass alles richtig wird",
"39" = "Herzklopfen oder Herzjagen",
"40" = "Ubelkeit oder Magenverstimmung",
"41" = "Minderwertigkeitsgefuhlen gegenuber anderen",
"42" = "Muskelschmerzen (Muskelkater, Gliederreissen)",
"43" = "dem Gefuhl, dass andere Sie beobachten oder uber Sie reden",
"44" = "Einschlafschwierigkeiten",
"45" = "dem Zwang, wieder und wieder nachzukontrollieren, was sie tun",
"46" = "Schwierigkeiten, sich zu entscheiden",
"47" = "Furcht vor Fahrten in Bus, Strassenbahn, U-Bahn oder Zug",
"48" = "Schwierigkeiten beim Atmen",
"49" = "Hitzewallungen oder Kalteschauern",
"50" = "der Notwendigkeit, bestimmte Dinge, Orte oder Tatigkeiten zu meiden, weil Sie durch diese erschreckt werden",
"51" = "Leere im Kopf",
"52" = "Taubheit oder Kribbeln in einzelnen Korperteilen",
"53" = "dem Gefuhl, einen Klumpen (Kloss) im Hals zu haben",
"54" = "einem Gefuhl der Hoffnungslosigkeit angesichts der Zukunft",
"55" = "Konzentrationsschwierigkeiten",
"56" = "Schwachegefuhlen in einzelnen Korperteilen",
"57" = "dem Gefuhl, gespannt oder aufgeregt zu sein",
"58" = "Schweregefuhl in Armen oder Beinen",
"59" = "Gedanken an den Tod oder ans Sterben",
"60" = "dem Drang, sich zu uberessen",
"61" = "einem unbehaglichen Gefuhl, wenn Leute Sie beobachten oder uber Sie reden",
"62" = "dem Auftauchen von Gedanken, die nicht Ihre eigenen sind",
"63" = "dem Drang, jemanden zu schlagen, zu verletzen oder ihm Schmerz zuzufugen",
"64" = "fruhem Erwachen am Morgen",
"65" = "zwanghafter Wiederholung derselben Tatigkeiten wie Beruhren, Zahlen, Waschen",
"66" = "unruhigem oder gestortem Schlaf",
"67" = "den Drang, Dinge zu zerbrechen oder zu zerschmettern",
"68" = "Ideen oder Anschauungen, die andere nicht mit Ihnen teilen",
"69" = "starker Befangenheit im Umgang mit anderen",
"70" = "Abneigung gegen Menschenmengen, z. B. beim Einkaufen oder im Kino",
"71" = "einem Gefuhl, dass alles sehr anstrengend wird",
"72" = "Schreck- oder Panikanfallen",
"73" = "Unbehagen beim Essen oder Trinken in der Offentlichkeit",
"74" = "der Neigung, immer wieder in Erorterungen und Auseinandersetzungen zu geraten",
"75" = "Nervositat, wenn Sie allein gelassen werden",
"76" = "mangelnder Anerkennung Ihrer Leistungen durch andere",
"77" = "Einsamkeitsgefuhlen, selbst wenn Sie in Gesellschaft sind",
"78" = "so starker Ruhelosigkeit, dass Sie nicht stillsitzen konnen",
"79" = "dem Gefuhl, wertlos zu sein",
"80" = "dem Gefuhl, dass etwas Schlimmes passieren wird",
"81" = "dem Bedurfnis laut zu schreien oder mit Gegenstanden zu werfen",
"82" = "der Furcht, in der Offentlichkeit in Ohnmacht zu fallen",
"83" = "dem Gefuhl, dass die Leute Sie ausnutzen, wenn Sie es zulassen wurden",
"84" = "sexuelle Vorstellungen, die ziemlich unangenehm fur Sie sind",
"85" = "dem Gedanken, dass Sie fur Ihre Sunden bestraft werden sollten",
"86" = "schreckenerregenden Gedanken und Vorstellungen",
"87" = "dem Gedanken, dass etwas ernstlich mit Ihrem Korper nicht in Ordnung ist",
"88" = "dem Eindruck, sich einer anderen Person nie so richtig nahe fuhlen zu konnen",
"89" = "Schuldgefuhlen",
"90" = "dem Gedanken, dass irgendetwas mit Ihrem Verstand nicht in Ordnung ist"
)
subskalen = list(
Somatisierung = c(1, 4, 12, 27, 40, 42, 48, 49, 52, 53, 56, 58),
Zwanghaftigkeit = c(3, 9, 10, 28, 38, 45, 46, 51, 55, 65),
Unsicherheit = c(6, 21, 34, 36, 37, 41, 61, 69, 73),
Depressivitaet = c(5, 14, 15, 20, 22, 26, 29, 30, 31, 32, 54, 71, 79),
Aengstlichkeit = c(2, 17, 23, 33, 39, 57, 72, 78, 80, 86),
Aggressivitaet = c(11, 24, 63, 67, 74, 81),
Phobie = c(13, 25, 47, 50, 70, 75, 82),
Paranoia = c(8, 18, 43, 68, 76, 83),
Psychotizismus = c(7, 16, 35, 62, 77, 84, 85, 87, 88, 90),
Zusatzitems = c(19, 44, 59, 60, 64, 66, 89)
)
subskalen_namen_lang = c(
Somatisierung = "Somatisierung",
Zwanghaftigkeit = "Zwanghaftigkeit",
Unsicherheit = "Unsicherheit im Sozialkontakt",
Depressivitaet = "Depressivitat",
Aengstlichkeit = "Angstlichkeit",
Aggressivitaet = "Aggressivitat/Feindseligkeit",
Phobie = "Phobische Angst",
Paranoia = "Paranoides Denken",
Psychotizismus = "Psychotizismus"
)
norm_dateinamen = c(
Somatisierung = "norm_somatisierung.csv",
Zwanghaftigkeit = "norm_zwanghaftigkeit.csv",
Unsicherheit = "norm_unsicherheit.csv",
Depressivitaet = "norm_depressivitaet.csv",
Aengstlichkeit = "norm_aengstlichkeit.csv",
Aggressivitaet = "norm_aggressivitaet.csv",
Phobie = "norm_phobie.csv",
Paranoia = "norm_paranoia.csv",
Psychotizismus = "norm_psychotizismus.csv",
GSI = "norm_gsi.csv",
PST = "norm_pst.csv",
PSDI = "norm_psdi.csv"
)
stufen_texte = c("0" = "uberhaupt nicht", "1" = "ein wenig", "2" = "ziemlich",
"3" = "stark", "4" = "sehr stark")
normtabellen = lade_normtabellen()
# UI ####
app_css = "
body { font-family: 'Segoe UI', Helvetica, Arial, sans-serif; background: #f5f5f5;
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: 20px;
margin-bottom: 18px;
box-shadow: 0 1px 4px rgba(0,0,0,0.10);
}
.abschnitt-titel {
color: #8B2635;
margin-top: 0;
margin-bottom: 12px;
font-size: 1em;
font-weight: 700;
}
.alert-warnung {
background: #fff8dc;
border-left: 4px solid #e6a817;
padding: 10px 14px;
border-radius: 4px;
margin-bottom: 12px;
font-size: 0.9em;
}
.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 { color: #444; font-size: 0.92em; }
.kritisch-block {
background: #fff0f0;
border-left: 5px solid #cc0000;
border-radius: 4px;
padding: 14px 18px;
margin-bottom: 12px;
}
.kritisch-block h4 { color: #cc0000; margin-top: 0; }
.disclaimer { font-size: 0.82em; color: #888; margin-top: 6px; font-style: italic; }
.kw-tabelle td, .kw-tabelle th { padding: 6px 12px; border-bottom: 1px solid #eee; }
.kw-tabelle th { background: #f0f0f0; font-weight: 600; }
.kw-tabelle { width: 100%; border-collapse: collapse; }
.stufe-badge {
display: inline-block;
padding: 2px 8px;
border-radius: 10px;
font-weight: 600;
font-size: 0.85em;
min-width: 22px;
text-align: center;
}
.stufe-badge-0 { background: #d4edda; color: #155724; }
.stufe-badge-1 { background: #ffe0e6; color: #7a2030; }
.stufe-badge-2 { background: #f08080; color: #fff; }
.stufe-badge-3 { background: #cc0000; color: #fff; }
.stufe-badge-4 { background: #7a0000; color: #fff; }
.item-zeile {
display: flex;
align-items: flex-start;
gap: 10px;
padding: 5px 0;
border-bottom: 1px solid #f0f0f0;
font-size: 0.9em;
}
.item-nr { min-width: 28px; color: #888; font-weight: 600; }
.item-text { flex: 1; }
.item-stufentext { color: #666; font-size: 0.88em; min-width: 100px; }
.na-hinweis { color: #999; font-style: italic; }
"
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("SCL-90-R Auswertung"),
tags$p("Symptom-Checkliste-90-R • Einzelfall-Auswertung")
),
div(style = "max-width: 1600px; margin: auto; padding: 0 16px;",
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_docx", "Word-Export (.docx)")
)
),
uiOutput("warnung_ui"),
uiOutput("kritisch_ui"),
uiOutput("global_ui"),
uiOutput("profil_ui"),
uiOutput("subskalen_items_ui")
)
)
# Word-Export ####
erstelle_scl90r_docx = function(chiffre, datum_str, auswertung, norm_spalten_name) {
grau_fp = fp_text(color = "#555555", font.size = 11)
rot_fp = fp_text(color = "#CC0000", bold = TRUE, font.size = 11)
normal_fp = fp_text(font.size = 11)
klein_fp = fp_text(font.size = 9, color = "#666666", italic = TRUE)
stufen_farben = c("0" = "#d4edda", "1" = "#ffe0e6", "2" = "#f08080",
"3" = "#cc0000", "4" = "#7a0000")
stufen_text_farben = c("0" = "#155724", "1" = "#7a2030", "2" = "#ffffff",
"3" = "#ffffff", "4" = "#ffffff")
doc = read_docx()
doc = body_add_fpar(doc, fpar(
ftext("SCL-90-R Auswertung", fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18))
))
doc = body_add_fpar(doc, fpar(
ftext(paste0("Chiffre: ", chiffre, " | Ausfuelldatum: ", datum_str,
" | Erstellt: ", format(Sys.Date(), "%d.%m.%Y")), grau_fp)
))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(
ftext("Globalkennwerte", fp_text(bold = TRUE, font.size = 13))
))
gsi_t = if (is.na(auswertung$T_GSI)) "nicht normiert" else as.character(round(auswertung$T_GSI))
pst_t = if (is.na(auswertung$T_PST)) "nicht normiert" else as.character(round(auswertung$T_PST))
psdi_t = if (is.na(auswertung$T_PSDI)) "nicht normiert" else as.character(round(auswertung$T_PSDI))
for (zeile in list(
c("GSI", skwert_fmt(auswertung$GSI), gsi_t),
c("PST", as.character(auswertung$PST), pst_t),
c("PSDI", skwert_fmt(auswertung$PSDI), psdi_t)
)) {
doc = body_add_fpar(doc, fpar(
ftext(sprintf("%-6s Wert: %-8s T-Wert: %s", zeile[1], zeile[2], zeile[3]), normal_fp)
))
}
doc = body_add_par(doc, "", style = "Normal")
# rvg zeichnet das Profildiagramm als DrawingML-Vektorgrafik in Word
doc = body_add_gg(doc, value = profil_plot(auswertung, AKZENT_FARBE),
width = 6, height = 3)
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(
ftext("Subskalen", fp_text(bold = TRUE, font.size = 12))
))
skalen9 = c("Somatisierung", "Zwanghaftigkeit", "Unsicherheit", "Depressivitaet",
"Aengstlichkeit", "Aggressivitaet", "Phobie", "Paranoia", "Psychotizismus")
for (sk in skalen9) {
sw = skwert_fmt(auswertung[[paste0("skwert_", sk)]])
tv = auswertung[[paste0("twert_", sk)]]
tv_s = if (is.null(tv) || is.na(tv)) "nicht normiert" else as.character(round(tv))
doc = body_add_fpar(doc, fpar(
ftext(sprintf("%-38s MW: %-6s T: %s", subskalen_namen_lang[[sk]], sw, tv_s), grau_fp)
))
}
doc = body_add_par(doc, "", style = "Normal")
kritisch_items = list(
list(nr = "15", text = scl90_itemtexte[["15"]]),
list(nr = "59", text = scl90_itemtexte[["59"]])
)
hat_kritisch = FALSE
for (ki in kritisch_items) {
rw = auswertung$items[[ki$nr]]
if (!is.na(rw) && rw >= 1) {
if (!hat_kritisch) {
doc = body_add_fpar(doc, fpar(
ftext("Kritische Items", fp_text(color = "#CC0000", bold = TRUE, font.size = 12))
))
hat_kritisch = TRUE
}
st = stufen_texte[[as.character(as.integer(rw))]]
doc = body_add_fpar(doc, fpar(ftext(paste0("Item ", ki$nr, ": ", ki$text), rot_fp)))
doc = body_add_fpar(doc, fpar(ftext(paste0("Antwort: ", as.integer(rw), " - ", st), normal_fp)))
doc = body_add_fpar(doc, fpar(ftext("Kein automatisiertes klinisches Urteil.", klein_fp)))
doc = body_add_par(doc, "", style = "Normal")
}
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(
ftext("Items nach Subskala", fp_text(bold = TRUE, font.size = 12))
))
alle_abschnitte = c(setdiff(names(subskalen), "Zusatzitems"), "Zusatzitems")
for (sk in alle_abschnitte) {
sk_label = if (sk == "Zusatzitems") "Zusatzitems" else subskalen_namen_lang[[sk]]
doc = body_add_fpar(doc, fpar(
ftext(sk_label, fp_text(bold = TRUE, font.size = 10, color = AKZENT_FARBE))
))
for (i in subskalen[[sk]]) {
nr = sprintf("%02d", i)
rw = auswertung$items[[nr]]
rw_s = if (is.null(rw) || is.na(rw)) NA_integer_ else as.integer(rw)
st = if (is.na(rw_s)) "?" else stufen_texte[[as.character(rw_s)]]
rw_str = if (is.na(rw_s)) "?" else as.character(rw_s)
bg_col = if (!is.na(rw_s)) stufen_farben[[rw_str]] else "#eeeeee"
tx_col = if (!is.na(rw_s)) stufen_text_farben[[rw_str]] else "#555555"
doc = body_add_fpar(doc, fpar(
ftext(nr, fp_text(font.size = 9, color = "#888888")),
ftext(" ", fp_text(font.size = 9)),
ftext(scl90_itemtexte[[nr]], fp_text(font.size = 9)),
ftext(paste0(" [", rw_str, " - ", st, "]"),
fp_text(font.size = 9, color = tx_col, shading.color = bg_col))
))
}
doc = body_add_par(doc, "", style = "Normal")
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(SCL90R_DISCLAIMER, klein_fp)))
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)))
}
})
auswertungs_daten = eventReactive(input$btn_suchen, {
chiffre = toupper(trimws(input$chiffre))
if ((nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0)) {
return(list(fehler = "Bitte eine Chiffre eingeben."))
}
if (!(nchar(trimws(input$pseudonym)) > 0 || grepl("^[A-Z][0-9]{6}$", chiffre))) {
return(list(fehler = paste0(
"Ungueltige Chiffre. Erwartet wird ein Grossbuchstabe gefolgt von 6 Ziffern, ",
"z.B. P000123.")))
}
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
return(list(fehler = paste0("Download-Skript nicht gefunden:\n", PFAD_DOWNLOAD_SKRIPT)))
}
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
return(list(fehler = paste0("Pseudonym-Skript nicht gefunden:\n", PFAD_PSEUDONYM_SKRIPT)))
}
tryCatch(
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE),
error = function(e) stop(paste0("Fehler im Download-Skript: ", conditionMessage(e)))
)
if (!exists("daten_scl90r", envir = .GlobalEnv)) {
return(list(fehler = "Variable 'daten_scl90r' wurde vom Download-Skript nicht bereitgestellt."))
}
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(fehler = "Datei 'pseudonyme.db' wurde nicht gefunden (bis 5 Ebenen aufwaerts gesucht)."))
}
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(fehler = paste0("Fehler im Pseudonym-Skript: ", conditionMessage(e)))
})
if (is.list(ok_ps)) return(ok_ps)
if (!exists("pseudo", envir = .GlobalEnv)) {
return(list(fehler = "Variable 'pseudo' wurde vom Pseudonym-Skript nicht bereitgestellt."))
}
dat_ps = get("pseudo", envir = .GlobalEnv)
daten_scl90r = get("daten_scl90r", envir = .GlobalEnv)
# tolower()-Vergleich ist intentional: Chiffren in pseudonyme.db koennen gemischte
# Gross-/Kleinschreibung haben; toupper() auf Input-Seite allein reicht nicht aus.
treffer_pseudo = dat_ps[tolower(trimws(dat_ps$chiffre)) == tolower(chiffre), ]
if (nrow(treffer_pseudo) == 0) {
return(list(fehler = "Chiffre nicht gefunden."))
}
alle_session_ids = unique(treffer_pseudo$pseudonym)
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
treffer_daten = daten_scl90r[daten_scl90r$session %in% alle_session_ids, ]
if (nrow(treffer_daten) == 0) {
return(list(fehler = paste0(
"Keine SCL-90-R-Daten gefunden. (",
length(alle_session_ids), " Pseudonym(e) geprueft)")))
}
warnung = NULL
if (nrow(treffer_daten) > 1) {
if ("created" %in% names(treffer_daten)) {
created_vals = as.POSIXct(treffer_daten$created, tz = "UTC")
neueste_idx = which.max(created_vals)
datum_s = format(created_vals[neueste_idx], "%d.%m.%Y %H:%M")
warnung = paste0("Mehrere Eintraege gefunden. Zeige den neuesten vom ", datum_s, ".")
treffer_daten = treffer_daten[neueste_idx, , drop = FALSE]
} else {
warnung = "Mehrere Eintraege gefunden. Zeige den ersten Eintrag."
treffer_daten = treffer_daten[1, , drop = FALSE]
}
}
zeile = as.list(treffer_daten[1, ])
g_val = if ("scl90_geschlecht" %in% names(zeile)) zeile$scl90_geschlecht else NA
b_val = if ("scl90_bildung" %in% names(zeile)) zeile$scl90_bildung else NA
g_labels = attr(treffer_daten$scl90_geschlecht, "labels")
b_labels = attr(treffer_daten$scl90_bildung, "labels")
ns_name = norm_spalte(g_val, g_labels, b_val, b_labels)
ergebnis = berechne_auswertung(zeile, ns_name)
datum_anzeige = if ("created" %in% names(zeile) && !is.na(zeile$created)) {
format(as.POSIXct(zeile$created, tz = "UTC"), "%d.%m.%Y")
} else format(Sys.Date(), "%d.%m.%Y")
list(
ok = TRUE,
auswertung = ergebnis,
chiffre = chiffre,
datum_str = datum_anzeige,
ns_name = ns_name,
warnung = warnung
)
})
output$warnung_ui = renderUI({
d = auswertungs_daten()
if (!is.null(d$fehler)) {
return(div(class = "alert-fehler",
tags$h4("Fehler"),
tags$p(d$fehler)))
}
if (!is.null(d$warnung)) {
div(class = "alert-warnung", d$warnung)
}
})
output$kritisch_ui = renderUI({
d = auswertungs_daten()
if (is.null(d$ok)) return(NULL)
aw = d$auswertung
ki_liste = list(
list(nr = "15", text = scl90_itemtexte[["15"]]),
list(nr = "59", text = scl90_itemtexte[["59"]])
)
bloecke = lapply(ki_liste, function(ki) {
rw = aw$items[[ki$nr]]
if (!is.na(rw) && rw >= 1) {
st = stufen_texte[[as.character(as.integer(rw))]]
div(class = "kritisch-block",
tags$h4(paste0("Item ", ki$nr, ": ", ki$text)),
tags$p(paste0("Antwort: ", as.integer(rw), " - ", st)),
tags$p(class = "disclaimer", "Kein automatisiertes klinisches Urteil.")
)
}
})
bloecke = Filter(Negate(is.null), bloecke)
if (length(bloecke) > 0) div(class = "abschnitt-karte", do.call(tagList, bloecke))
})
output$global_ui = renderUI({
d = auswertungs_daten()
if (is.null(d$ok)) return(NULL)
aw = d$auswertung
psdi_hinweis = if (is.na(aw$PSDI) && aw$PST == 0) {
tags$p(class = "na-hinweis", "PSDI: nicht berechenbar (PST = 0, keine belasteten Items).")
} else NULL
tagList(
div(class = "abschnitt-karte",
tags$h4(class = "abschnitt-titel", "Globalkennwerte"),
tags$table(class = "kw-tabelle",
tags$thead(tags$tr(
tags$th("Kennwert"), tags$th("Wert"), tags$th("T-Wert"), tags$th("Einordnung")
)),
tags$tbody(
tags$tr(
tags$td("GSI (Global Severity Index)"),
tags$td(skwert_fmt(aw$GSI)),
tags$td(twert_anzeige(aw$T_GSI)),
tags$td(twert_zone(aw$T_GSI))
),
tags$tr(
tags$td("PST (Positive Symptom Total)"),
tags$td(aw$PST),
tags$td(twert_anzeige(aw$T_PST)),
tags$td(twert_zone(aw$T_PST))
),
tags$tr(
tags$td("PSDI (Positive Symptom Distress Index)"),
tags$td(skwert_fmt(aw$PSDI)),
tags$td(twert_anzeige(aw$T_PSDI)),
tags$td(twert_zone(aw$T_PSDI))
)
)
),
psdi_hinweis,
tags$p(class = "disclaimer",
paste0("Normierungsspalte: ", d$ns_name, ".")),
tags$hr(),
tags$h5("GSI T-Wert - Uberblick"),
plotOutput("gauge_plot", height = "90px")
)
)
})
output$gauge_plot = renderPlot({
d = auswertungs_daten()
if (is.null(d$ok)) return(NULL)
gauge_plot(d$auswertung$T_GSI, AKZENT_FARBE)
}, bg = "white")
output$profil_ui = renderUI({
d = auswertungs_daten()
if (is.null(d$ok)) return(NULL)
aw = d$auswertung
skalen9 = c("Somatisierung", "Zwanghaftigkeit", "Unsicherheit", "Depressivitaet",
"Aengstlichkeit", "Aggressivitaet", "Phobie", "Paranoia", "Psychotizismus")
zeilen = lapply(skalen9, function(sk) {
sw = skwert_fmt(aw[[paste0("skwert_", sk)]])
tv = aw[[paste0("twert_", sk)]]
tags$tr(
tags$td(subskalen_namen_lang[[sk]]),
tags$td(sw),
tags$td(twert_anzeige(tv)),
tags$td(twert_zone(tv))
)
})
div(class = "abschnitt-karte",
tags$h4(class = "abschnitt-titel", "Subskalen-Profil"),
plotOutput("profil_plot", height = "320px"),
tags$br(),
tags$table(class = "kw-tabelle",
tags$thead(tags$tr(
tags$th("Subskala"), tags$th("Mittelwert"), tags$th("T-Wert"), tags$th("Einordnung")
)),
tags$tbody(do.call(tagList, zeilen))
)
)
})
output$profil_plot = renderPlot({
d = auswertungs_daten()
if (is.null(d$ok)) return(NULL)
profil_plot(d$auswertung, AKZENT_FARBE)
}, bg = "white")
skalen9_liste = c("Somatisierung", "Zwanghaftigkeit", "Unsicherheit", "Depressivitaet",
"Aengstlichkeit", "Aggressivitaet", "Phobie", "Paranoia", "Psychotizismus")
output$subskalen_items_ui = renderUI({
d = auswertungs_daten()
if (is.null(d$ok)) return(NULL)
aw = d$auswertung
sk_panels = lapply(skalen9_liste, function(sk) {
tv = aw[[paste0("twert_", sk)]]
sw = skwert_fmt(aw[[paste0("skwert_", sk)]])
zone = twert_zone(tv)
gauge_id = paste0("gauge_sk_", sk)
div(class = "abschnitt-karte",
tags$h4(class = "abschnitt-titel", subskalen_namen_lang[[sk]]),
tags$p(
tags$strong(paste0("Mittelwert: ", sw, " | T-Wert: ")),
twert_anzeige(tv),
if (nchar(zone) > 0) tags$span(style = "color:#666; margin-left:8px;", paste0("(", zone, ")"))
),
plotOutput(gauge_id, height = "80px"),
tags$div(style = "margin-top:10px;",
skala_items_html(subskalen[[sk]], aw$items)
)
)
})
zusatz_panel = div(class = "abschnitt-karte",
tags$h4(class = "abschnitt-titel", "Zusatzitems"),
tags$p(style = "color:#888; font-size:0.88em;",
"Zusatzitems fliessen in GSI/PST/PSDI ein, bilden keine eigene Subskala."),
skala_items_html(subskalen[["Zusatzitems"]], aw$items)
)
do.call(tagList, c(sk_panels, list(zusatz_panel)))
})
observe({
d = auswertungs_daten()
if (is.null(d$ok)) return()
aw = d$auswertung
for (sk in skalen9_liste) {
local({
sk_ = sk
output[[paste0("gauge_sk_", sk_)]] = renderPlot({
gauge_plot(aw[[paste0("twert_", sk_)]], AKZENT_FARBE)
}, bg = "white")
})
}
})
output$download_docx = downloadHandler(
filename = function() {
d = auswertungs_daten()
if (is.null(d$ok)) return("SCL90R_Auswertung.docx")
ausfuelldatum_fn = format(as.Date(d$datum_str, "%d.%m.%Y"), "%Y%m%d")
paste0("SCL90R_", d$chiffre, "_", ausfuelldatum_fn, ".docx")
},
content = function(file) {
d = auswertungs_daten()
req(isTRUE(d$ok))
doc = erstelle_scl90r_docx(d$chiffre, d$datum_str, d$auswertung, d$ns_name)
print(doc, target = file)
}
)
}
# Start ####
shinyApp(ui = ui, server = server)
Reference in a new issue View git blame Copy permalink