DiagnostikApps/LSAS/app.R
2026-09-22 18:35:43 +02:00

545 lines
19 KiB
R
Raw Permalink Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

# Präambel ####
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_lsas.R"
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
AKZENT_FARBE = "#8B2635"
LSAS_DISCLAIMER = paste0(
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person."
)
library(shiny)
library(dplyr)
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)
# Helper ####
ITEM_TEXTE = c(
"In der Öffentlichkeit telefonieren",
"An einer Aktivität in einer kleinen Gruppe teilnehmen",
"In der Öffentlichkeit essen",
"In der Öffentlichkeit trinken",
"Mit einem Vorgesetzten oder einer Autoritätsperson sprechen",
"Vor Publikum auftreten, handeln oder sprechen",
"Zu einem Fest oder einer Party gehen",
"Bei der Arbeit beobachtet werden",
"Beim Schreiben beobachtet werden",
"Mit jemandem telefonieren, den Sie kaum kennen",
"Mit jemandem sprechen, den Sie kaum kennen",
"Mit Fremden zusammentreffen",
"Eine öffentliche Toilette besuchen",
"Einen Raum betreten, in dem andere bereits sitzen",
"Im Mittelpunkt der Aufmerksamkeit stehen",
"Ohne Vorbereitung auf einer Veranstaltung sprechen",
"An einem Test teilnehmen",
"Gegenüber jemandem, den Sie kaum kennen, Ihre fehlende Zustimmung äußern",
"Jemanden, den Sie wenig kennen, direkt in die Augen schauen",
"Vor einer Gruppe einen vorbereiteten mündlichen Bericht geben",
"Eine Liebes- oder Intimbeziehung aufnehmen",
"Waren in einem Geschäft umtauschen",
"Ein Fest oder eine Party geben",
"Dem hohen Druck eines Verkäufers widerstehen"
)
STUFE_FARBEN = c("0" = "#4CAF50", "1" = "#F9A825", "2" = "#EF6C00", "3" = "#C62828")
STUFE_TEXT_FARBEN = c("0" = "#FFFFFF", "1" = "#333333", "2" = "#FFFFFF", "3" = "#FFFFFF")
lsas_klassifikation = function(score) {
if (score < 30) return(list(text = "kein klinisch relevanter Befund", farbe = "#388E3C"))
if (score <= 51) return(list(text = "leichte soziale Angst", farbe = "#7CB342"))
if (score <= 67) return(list(text = "moderate soziale Angst", farbe = "#F9A825"))
if (score <= 82) return(list(text = "deutliche soziale Angst", farbe = "#EF6C00"))
if (score <= 95) return(list(text = "schwere soziale Angst", farbe = "#C62828"))
list(text = "sehr schwere soziale Angst", farbe = "#4A0000")
}
lsas_stufe = function(wert) {
as.numeric(wert) - 1
}
ankertext_angst = function(stufe) {
anker = c("0" = "keine", "1" = "gering", "2" = "mäßig", "3" = "stark")
unname(anker[as.character(stufe)])
}
ankertext_vermeidung = function(stufe) {
anker = c("0" = "nie", "1" = "selten (bis 33 %)",
"2" = "häufig (bis 66 %)", "3" = "fast immer")
unname(anker[as.character(stufe)])
}
item_reihenfolge = function(stufen_angst, stufen_vermeidung) {
order(-stufen_angst, -stufen_vermeidung)
}
make_gauge_lsas = function(score) {
zonen = data.frame(
xmin = c(0, 30, 52, 68, 83, 96),
xmax = c(30, 52, 68, 83, 96, 144),
farbe = c("#388E3C", "#7CB342", "#F9A825", "#EF6C00", "#C62828", "#4A0000"),
stringsAsFactors = FALSE
)
ggplot() +
geom_rect(data = zonen,
aes(xmin = xmin, xmax = xmax, ymin = 0, ymax = 1, fill = farbe),
color = "white", linewidth = 0.6) +
scale_fill_identity() +
geom_segment(aes(x = score, xend = score, y = 0, yend = 1.15),
color = "#212121", linewidth = 1) +
geom_point(aes(x = score, y = 1.28), shape = 17, size = 4, color = "#212121") +
scale_x_continuous(limits = c(0, 144), expand = c(0, 0),
breaks = c(0, 30, 52, 68, 83, 96, 144)) +
scale_y_continuous(limits = c(0, 1.5), expand = c(0, 0)) +
theme_minimal(base_size = 10) +
theme(
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
panel.grid = element_blank(),
axis.title = element_blank(),
axis.text.x = element_text(color = "#555555"),
plot.margin = margin(t = 8, r = 12, b = 0, l = 12),
plot.background = element_rect(fill = "white", color = NA),
panel.background = element_rect(fill = "white", color = NA)
)
}
# UI ####
app_css = "
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f4f4f4; color: #222; }
.app-header {
background: #8B2635; color: white; padding: 16px 22px 13px;
margin-bottom: 18px; border-radius: 0 0 6px 6px;
}
.app-header h2 { margin: 0; font-size: 1.45rem; font-weight: 700; }
.input-panel {
display: flex; align-items: flex-end; gap: 12px; flex-wrap: wrap;
background: white; border-radius: 6px; padding: 14px 20px;
margin: 0 16px 16px 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
}
.input-panel .form-group { margin-bottom: 0; }
.btn-laden {
background: #8B2635 !important; border-color: #8B2635 !important;
color: white !important; font-weight: 600 !important;
padding: 8px 20px !important; border-radius: 4px !important;
}
.btn-laden:hover { background: #6d1e29 !important; border-color: #6d1e29 !important; }
.alert-fehler {
background: #FEECEB; border-left: 5px solid #C62828; color: #B71C1C;
padding: 12px 16px; border-radius: 4px; margin: 0 16px 16px 16px; font-weight: 500;
}
.alert-warnung {
background: #FFF8E1; border-left: 5px solid #F9A825; color: #7A5B00;
padding: 10px 16px; border-radius: 4px; margin: 0 16px 16px 16px; font-size: 0.93em;
}
.alert-hinweis {
background: #E8F5E9; border-left: 5px solid #388E3C; color: #1B5E20;
padding: 12px 16px; border-radius: 4px; margin-bottom: 16px; font-size: 0.93em;
line-height: 1.5;
}
.abschnitt-karte {
background: white; border-radius: 6px; padding: 18px 22px;
margin: 0 16px 16px 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
}
.abschnitt-titel {
color: #8B2635; font-size: 1.1rem; font-weight: 700;
border-bottom: 2px solid #8B2635; padding-bottom: 8px; margin-bottom: 14px;
}
.meta-zeile { color: #555; font-size: 0.95em; margin-bottom: 12px; }
.meta-zeile b { color: #222; }
.meta-zeile span.sep { color: #ccc; margin: 0 8px; }
.klassifikation-badge { font-size: 1.2rem; font-weight: 800; margin: 6px 0 14px; }
.item-zeile {
display: flex; align-items: flex-start; gap: 10px; flex-wrap: wrap;
padding: 7px 0; border-bottom: 1px solid #f0f0f0;
}
.item-nr { font-weight: 700; color: #8B2635; min-width: 30px; flex-shrink: 0; }
.item-text { flex: 1; min-width: 220px; color: #333; font-size: 0.92em; }
.stufe-badge {
border-radius: 4px; padding: 2px 10px; font-weight: 700;
font-size: 0.82em; white-space: nowrap; display: inline-block; flex-shrink: 0;
}
.stufe-badge-0 { background: #4CAF50; color: white; }
.stufe-badge-1 { background: #F9A825; color: #333333; }
.stufe-badge-2 { background: #EF6C00; color: white; }
.stufe-badge-3 { background: #C62828; color: white; }
"
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("Liebowitz-Skala (LSAS)")
),
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_lsas_docx = function(erg) {
doc = read_docx()
fp_titel = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18)
fp_meta = fp_text(color = "#555555", font.size = 10)
fp_abschnitt = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 13)
fp_normal = fp_text(font.size = 10)
fp_hinweis = fp_text(color = "#388E3C", font.size = 10)
fp_disclaimer = fp_text(color = "#777777", italic = TRUE, font.size = 9)
fp_klasse = fp_text(color = erg$klasse_farbe, bold = TRUE, font.size = 13)
doc = body_add_fpar(doc, fpar(ftext("Liebowitz-Skala (LSAS)", fp_titel)))
doc = body_add_fpar(doc, fpar(ftext(
paste0("Chiffre: ", erg$chiffre,
" | Datum: ", erg$ausfuelldatum,
" | Gesamtscore: ", erg$sum_gesamt, " / 144",
" | Angst: ", erg$sum_angst, " / 72",
" | Vermeidung: ", erg$sum_vermeidung, " / 72"),
fp_meta
)))
doc = body_add_fpar(doc, fpar(ftext(erg$klasse, fp_klasse)))
if (erg$sum_gesamt < 35) {
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(paste0(
"Der Gesamtwert liegt unterhalb des validierten Remissions-Grenzwerts ",
"von 35 Punkten (Klimek et al., 2018; Sensitivität .83, Spezifität .82). ",
"Dies kann auf eine zurückgegangene soziale Angststörung hinweisen."
), fp_hinweis)))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(
"Einzelitems (sortiert nach Schweregrad: Angst, dann Vermeidung)", fp_abschnitt
)))
reihenfolge = item_reihenfolge(erg$stufen_angst, erg$stufen_vermeidung)
for (i in reihenfolge) {
stufe_a = erg$stufen_angst[i]
stufe_v = erg$stufen_vermeidung[i]
fp_badge_a = fp_text(
color = STUFE_TEXT_FARBEN[[as.character(stufe_a)]],
bold = TRUE,
shading.color = STUFE_FARBEN[[as.character(stufe_a)]],
font.size = 9
)
fp_badge_v = fp_text(
color = STUFE_TEXT_FARBEN[[as.character(stufe_v)]],
bold = TRUE,
shading.color = STUFE_FARBEN[[as.character(stufe_v)]],
font.size = 9
)
doc = body_add_fpar(doc, fpar(
ftext(paste0(sprintf("%02d", i), " | ", ITEM_TEXTE[i], " | "), fp_normal),
ftext(paste0(" Angst: ", stufe_a, " ", ankertext_angst(stufe_a), " "), fp_badge_a),
ftext(" ", fp_normal),
ftext(paste0(" Vermeidung: ", stufe_v, " ", ankertext_vermeidung(stufe_v), " "), fp_badge_v)
))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(LSAS_DISCLAIMER, fp_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)))
}
})
erg_aktuell = eventReactive(input$btn_suchen, {
chiffre = toupper(trimws(input$chiffre))
if (!(nchar(trimws(input$pseudonym)) > 0 || grepl("^[A-Z][0-9]{6}$", chiffre))) {
return(list(typ = "format_fehler", chiffre = chiffre))
}
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
return(list(typ = "pfad_fehler", pfad = PFAD_DOWNLOAD_SKRIPT))
}
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
return(list(typ = "pfad_fehler", pfad = PFAD_PSEUDONYM_SKRIPT))
}
ok_dl = tryCatch({
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
list(ok = TRUE)
}, error = function(e) list(ok = FALSE, msg = e$message))
if (!ok_dl$ok) {
return(list(typ = "skript_fehler", meldung = ok_dl$msg))
}
if (!exists("daten_lsas", envir = .GlobalEnv) ||
!is.data.frame(get("daten_lsas", envir = .GlobalEnv))) {
return(list(typ = "daten_fehler"))
}
daten_lsas = get("daten_lsas", envir = .GlobalEnv)
db_ordner = local({
ordner = dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE))
gefunden = NULL
for (i in 1:5) {
if (file.exists(file.path(ordner, "pseudonyme.db"))) {
gefunden = ordner
break
}
elternteil = dirname(ordner)
if (elternteil == ordner) break
ordner = elternteil
}
gefunden
})
if (is.null(db_ordner)) {
return(list(typ = "db_fehler"))
}
alter_wd = getwd()
on.exit(setwd(alter_wd), add = TRUE)
setwd(db_ordner)
ok_ps = tryCatch({
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 = e$message))
if (!ok_ps$ok) {
return(list(typ = "skript_fehler", meldung = ok_ps$msg))
}
if (!exists("pseudo", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = "Objekt 'pseudo' nach dem Sourcen nicht gefunden."))
}
pseudo = get("pseudo", envir = .GlobalEnv)
treffer = pseudo[toupper(pseudo$chiffre) == chiffre, ]
if (nrow(treffer) == 0) {
return(list(typ = "chiffre_nicht_gefunden", chiffre = chiffre))
}
session_id = treffer$pseudonym[1]
if (nchar(trimws(input$pseudonym)) > 0) session_id = trimws(input$pseudonym)
zeilen = daten_lsas[daten_lsas$session == session_id, ]
if (nrow(zeilen) == 0) {
return(list(typ = "session_nicht_gefunden"))
}
mehrere_n = NULL
if (nrow(zeilen) > 1) {
mehrere_n = nrow(zeilen)
zeilen = zeilen[order(zeilen$created, decreasing = TRUE), ]
}
zeile = zeilen[1, , drop = FALSE]
stufen_angst = sapply(1:24, function(i) {
as.integer(lsas_stufe(zeile[[sprintf("a%02d", i)]]))
})
stufen_vermeidung = sapply(1:24, function(i) {
as.integer(lsas_stufe(zeile[[sprintf("v%02d", i)]]))
})
sum_angst = sum(stufen_angst)
sum_vermeidung = sum(stufen_vermeidung)
sum_gesamt = sum_angst + sum_vermeidung
klass = lsas_klassifikation(sum_gesamt)
ausfuelldatum = format(as.Date(zeile$created[1]), "%d.%m.%Y")
typ_final = if (!is.null(mehrere_n)) "mehrere_treffer_warnung" else "ok"
list(
typ = typ_final,
n = mehrere_n,
chiffre = chiffre,
ausfuelldatum = ausfuelldatum,
sum_gesamt = sum_gesamt,
sum_angst = sum_angst,
sum_vermeidung = sum_vermeidung,
klasse = klass$text,
klasse_farbe = klass$farbe,
stufen_angst = stufen_angst,
stufen_vermeidung = stufen_vermeidung
)
})
baue_item_liste_kombiniert = function(stufen_angst, stufen_vermeidung) {
reihenfolge = item_reihenfolge(stufen_angst, stufen_vermeidung)
lapply(reihenfolge, function(i) {
stufe_a = stufen_angst[i]
stufe_v = stufen_vermeidung[i]
div(class = "item-zeile",
div(class = "item-nr", sprintf("%02d", i)),
div(class = "item-text", ITEM_TEXTE[i]),
span(class = paste0("stufe-badge stufe-badge-", stufe_a),
paste0("Angst: ", ankertext_angst(stufe_a))),
span(class = paste0("stufe-badge stufe-badge-", stufe_v),
paste0("Vermeidung: ", ankertext_vermeidung(stufe_v)))
)
})
}
baue_ergebnis_anzeige = function(erg) {
tagList(
div(class = "abschnitt-karte",
div(class = "meta-zeile",
tags$b("Chiffre: "), erg$chiffre,
tags$span(class = "sep", "|"),
tags$b("Ausfülldatum: "), erg$ausfuelldatum,
tags$span(class = "sep", "|"),
tags$b("Gesamtscore: "), paste0(erg$sum_gesamt, " / 144"),
tags$span(class = "sep", "|"),
tags$b("Angst: "), paste0(erg$sum_angst, " / 72"),
tags$span(class = "sep", "|"),
tags$b("Vermeidung: "), paste0(erg$sum_vermeidung, " / 72")
),
div(class = "klassifikation-badge", style = paste0("color:", erg$klasse_farbe, ";"),
erg$klasse
),
if (erg$sum_gesamt < 35) {
div(class = "alert-hinweis", paste0(
"Der Gesamtwert liegt unterhalb des validierten Remissions-Grenzwerts ",
"von 35 Punkten (Klimek et al., 2018; Sensitivität .83, Spezifität .82). ",
"Dies kann auf eine zurückgegangene soziale Angststörung hinweisen."
))
},
plotOutput("gauge_plot", height = "80px")
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel",
"Einzelitems (sortiert nach Schweregrad: Angst, dann Vermeidung)"),
baue_item_liste_kombiniert(erg$stufen_angst, erg$stufen_vermeidung)
)
)
}
output$ergebnis_ui = renderUI({
erg = erg_aktuell()
if (is.null(erg)) return(NULL)
switch(erg$typ,
"format_fehler" = div(class = "alert-fehler",
"Ungültiges Chiffre-Format (erwartet: P000123)"
),
"pfad_fehler" = div(class = "alert-fehler",
paste0("Skript-Pfad nicht gefunden: ", erg$pfad)
),
"skript_fehler" = div(class = "alert-fehler",
paste0("Fehler beim Ausführen eines Skripts: ", erg$meldung)
),
"daten_fehler" = div(class = "alert-fehler",
"daten_lsas nicht geladen"
),
"db_fehler" = div(class = "alert-fehler",
"pseudonyme.db nicht gefunden"
),
"chiffre_nicht_gefunden" = div(class = "alert-fehler",
"Chiffre nicht in Pseudonym-Datenbank"
),
"session_nicht_gefunden" = div(class = "alert-fehler",
"Keine formr-Daten für diese Session"
),
"mehrere_treffer_warnung" = tagList(
div(class = "alert-warnung",
paste0("Mehrere Einträge gefunden (n=", erg$n, "); neuester Eintrag wird angezeigt.")
),
baue_ergebnis_anzeige(erg)
),
"ok" = baue_ergebnis_anzeige(erg)
)
})
output$gauge_plot = renderPlot({
erg = erg_aktuell()
req(erg$typ %in% c("ok", "mehrere_treffer_warnung"))
make_gauge_lsas(erg$sum_gesamt)
}, bg = "white")
output$download_word = downloadHandler(
filename = function() {
erg = erg_aktuell()
chiffre_esc = gsub("[^A-Za-z0-9]", "_", erg$chiffre)
ausfuelldatum_fn = format(as.Date(erg$ausfuelldatum, "%d.%m.%Y"), "%Y%m%d")
paste0("LSAS_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
},
content = function(file) {
erg = erg_aktuell()
doc = erstelle_lsas_docx(erg)
print(doc, target = file)
}
)
}
# Start ####
shinyApp(ui, server)