server/DiagnostikApps
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit

Browse source
This commit is contained in:
Jonas Karneboge 2026-09-22 18:35:43 +02:00
commit 3cba772836
1341 changed files with 532924 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

BIN
AUDIT/.RData Normal file
View file

Binary file not shown.

1
AUDIT/.Rprofile Normal file
View file

@ -0,0 +1 @@
source("renv/activate.R")

13
AUDIT/AUDIT.Rproj Normal file
View file

@ -0,0 +1,13 @@
Version: 1.0
RestoreWorkspace: Default
SaveWorkspace: Default
AlwaysSaveHistory: Default
EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: UTF-8
RnwWeave: Sweave
LaTeX: pdfLaTeX

908
AUDIT/app.R Normal file
View file

@ -0,0 +1,908 @@
# Präambel ####
AKZENT_FARBE = "#8B2635"
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_audit.R"
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
AUDIT_DISCLAIMER = paste0(
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
"keine klinische Diagnose. Die Interpretation der Ergebnisse obliegt der ",
"behandelnden Person. Auswertungslogik gemaess WHO-AUDIT-Manual (Babor et al., 2001)."
)
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 ####
# In formr-Exporten stehen Markdown-Sternchen im Itemwortlaut und in Choice-Texten.
strip_stars = function(x) {
if (is.null(x) || length(x) == 0) return(x)
gsub("\\*\\*", "", as.character(x))
}
# Fallback-Itemtexte (deutsche WHO-AUDIT-Fassung), falls im formr-Export kein
# Spaltenlabel vorhanden ist.
AUDIT_ITEM_TEXTE = c(
"Wie oft trinken Sie Alkohol?",
"Wenn Sie Alkohol trinken, wie viele Gläser trinken Sie dann typischerweise an einem Tag?",
"Wie oft trinken Sie 6 oder mehr alkoholische Getränke bei einer Gelegenheit?",
"Wie oft haben Sie im letzten Jahr festgestellt, dass Sie nicht mehr aufhören konnten zu trinken, wenn Sie einmal angefangen hatten?",
"Wie oft haben Sie im letzten Jahr wegen Ihres Alkoholkonsums Dinge nicht erledigt, die von Ihnen erwartet wurden?",
"Wie oft haben Sie im letzten Jahr direkt nach dem Aufstehen ein alkoholisches Getränk gebraucht, um wieder in Gang zu kommen?",
"Wie oft hatten Sie im letzten Jahr Schuldgefühle oder Gewissensbisse nach dem Trinken?",
"Wie oft waren Sie im letzten Jahr nicht in der Lage, sich am nächsten Morgen an Ereignisse des Vorabends zu erinnern, weil Sie getrunken hatten?",
"Haben Sie sich selbst oder haben andere sich durch Ihren Alkoholkonsum schon einmal verletzt?",
"Hat sich ein(e) Verwandte(r), Freund(in), Ärztin/Arzt oder ein(e) andere(r) Angehörige(r) eines Gesundheitsberufs schon einmal Sorgen über Ihren Alkoholkonsum gemacht oder vorgeschlagen, dass Sie weniger trinken?"
)
# Fallback-Antworttexte je Item (nur genutzt, wenn die formr-Spalte keine
# labels tragen). Items 1-8: 5-stufige Frequenz-/Mengenskalen (0-4 Punkte).
# Items 9-10: 3-stufige Skala, aber mit Punktesprung 0/2/4 (WHO-Manual).
AUDIT_ANTWORT_TEXTE = list(
c("Nie", "Einmal im Monat oder seltener", "2- bis 4-mal im Monat",
"2- bis 3-mal die Woche", "4-mal oder öfter die Woche"),
c("1 oder 2", "3 oder 4", "5 oder 6", "7 bis 9", "10 oder mehr"),
c("Nie", "Seltener als monatlich", "Monatlich", "Wöchentlich", "Täglich oder fast täglich"),
c("Nie", "Seltener als monatlich", "Monatlich", "Wöchentlich", "Täglich oder fast täglich"),
c("Nie", "Seltener als monatlich", "Monatlich", "Wöchentlich", "Täglich oder fast täglich"),
c("Nie", "Seltener als monatlich", "Monatlich", "Wöchentlich", "Täglich oder fast täglich"),
c("Nie", "Seltener als monatlich", "Monatlich", "Wöchentlich", "Täglich oder fast täglich"),
c("Nie", "Seltener als monatlich", "Monatlich", "Wöchentlich", "Täglich oder fast täglich"),
c("Nein", "Ja, aber nicht im letzten Jahr", "Ja, im letzten Jahr"),
c("Nein", "Ja, aber nicht im letzten Jahr", "Ja, im letzten Jahr")
)
# Punktemultiplikator je Item: Items 1-8 sind direkt 0-4 skaliert (Position =
# Punkte). Items 9-10 haben laut WHO-Manual nur 3 Antwortstufen, die aber mit
# 0/2/4 statt 0/1/2 kodiert werden (Position * 2 = Punkte).
AUDIT_MULTIPLIKATOR = c(rep(1L, 8), 2L, 2L)
AUDIT_SUBSKALEN = list(
konsum = list(label = "Konsum", hinweis = "Items 1-3", items = 1:3, max = 12),
abhaengigkeit = list(label = "Abhängigkeitssymptome", hinweis = "Items 4-6",
items = 4:6, max = 12),
schaedlich = list(label = "Schädlicher Gebrauch", hinweis = "Items 7-10",
items = 7:10, max = 16)
)
# Ermittelt Position (0-basiert) und Antworttext ueber die sortierten
# labels-Werte der Originalspalte, analog zum PCL5-Muster. Robust gegenueber
# formr-internen Kodierungen, die nicht zwingend bei 0 beginnen muessen.
extrahiere_position_und_text = function(original_col, wert, item_idx) {
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) {
return(list(position = NA_integer_, text = "(keine Angabe)"))
}
lbl_attr = attr(original_col, "labels")
if (is.null(lbl_attr) || length(lbl_attr) == 0) {
fallback = AUDIT_ANTWORT_TEXTE[[item_idx]]
idx = as.integer(wert[1]) + 1L
txt = if (!is.na(idx) && idx >= 1 && idx <= length(fallback)) fallback[idx] else as.character(wert[1])
return(list(position = as.integer(wert[1]), text = txt))
}
lbl_sorted = sort(lbl_attr)
pos = which(as.numeric(lbl_sorted) == as.numeric(wert[1]))
if (length(pos) == 0) {
return(list(position = NA_integer_, text = as.character(wert[1])))
}
list(position = as.integer(pos[1]) - 1L, text = strip_stars(names(lbl_sorted)[pos[1]]))
}
# Klassifikation nach den 4 WHO-AUDIT-Risikozonen (Babor et al., 2001).
klassifiziere_audit = function(score) {
if (is.na(score)) {
return(list(text = "Nicht berechenbar", zone = "", bereich = "", farbe = "#888888"))
}
if (score <= 7) {
return(list(text = "Kein / geringes Risiko", zone = "Zone I",
bereich = "0-7 Punkte", farbe = "#2E7D32"))
}
if (score <= 15) {
return(list(text = "Riskanter Konsum", zone = "Zone II",
bereich = "8-15 Punkte", farbe = "#F57F17"))
}
if (score <= 19) {
return(list(text = "Schädlicher Konsum", zone = "Zone III",
bereich = "16-19 Punkte", farbe = "#E65100"))
}
list(text = "Wahrscheinliche Alkoholabhängigkeit", zone = "Zone IV",
bereich = "20-40 Punkte", farbe = "#B71C1C")
}
erstelle_gauge = function(score) {
zonen = data.frame(
xmin = c(0, 8, 16, 20),
xmax = c(8, 16, 20, 40),
zone = c("Zone I (0-7)", "Zone II (8-15)", "Zone III (16-19)", "Zone IV (20-40)"),
stringsAsFactors = FALSE
)
zonen$zone = factor(zonen$zone, levels = zonen$zone)
zonen_farben = c(
"Zone I (0-7)" = "#C8E6C9",
"Zone II (8-15)" = "#FFF9C4",
"Zone III (16-19)" = "#FFE0B2",
"Zone IV (20-40)" = "#FFCDD2"
)
zone_mitte = c(4, 12, 18, 30)
zone_labels = c("Zone I\n0-7", "Zone II\n8-15", "Zone III\n16-19", "Zone IV\n20-40")
p = ggplot() +
geom_rect(data = zonen,
aes(xmin = xmin, xmax = xmax, ymin = 0, ymax = 1, fill = zone),
colour = "white", linewidth = 1) +
scale_fill_manual(values = zonen_farben, guide = "none") +
annotate("text", x = zone_mitte, y = 0.5, label = zone_labels,
size = 2.9, colour = "#444444", fontface = "bold", lineheight = 0.9) +
scale_x_continuous(limits = c(0, 40), expand = c(0, 0),
breaks = c(0, 8, 16, 20, 40)) +
scale_y_continuous(limits = c(-0.25, 1.35), expand = c(0, 0)) +
labs(x = "Summenscore (0-40)", y = NULL) +
theme_minimal(base_size = 11) +
theme(
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
panel.grid = element_blank(),
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)
)
if (!is.na(score)) {
p = p +
geom_segment(aes(x = score, xend = score, y = -0.1, yend = 1.1),
colour = AKZENT_FARBE, linewidth = 2.5, lineend = "round") +
annotate("text", x = score, y = 1.26,
label = as.character(score),
colour = AKZENT_FARBE, fontface = "bold", size = 4.2)
}
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; }
.verletzung-block {
background-color: #6D0000;
color: white;
border-radius: 5px;
padding: 14px 18px;
margin-bottom: 14px;
border-left: 6px solid #FF6B6B;
}
.verletzung-block h4 { margin: 0 0 9px; font-size: 1.05em; font-weight: 700; }
.verletzung-block .antwort-text {
background: rgba(255,255,255,0.12);
border-radius: 3px;
padding: 7px 10px;
margin: 6px 0;
font-size: 0.92em;
line-height: 1.5;
}
.verletzung-block .disclaimer {
margin-top: 10px;
font-size: 0.82em;
opacity: 0.82;
font-style: italic;
}
.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; }
.score-label { font-size: 0.8em; color: #999; display: block; margin-bottom: 2px; }
.score-zahl { font-size: 3em; font-weight: 800; color: #8B2635; display: block;
line-height: 1.1; }
.klasse-text { font-size: 1.05em; font-weight: 700; display: block; margin-top: 4px; }
.bereich-text { font-size: 0.8em; color: #888; display: block; margin-top: 2px; }
.subskala-reihe { display: flex; gap: 12px; flex-wrap: wrap; margin-bottom: 4px; }
.subskala-karte {
flex: 1 1 200px;
background: #fafafa;
border: 1px solid #eee;
border-radius: 6px;
padding: 10px 14px;
}
.subskala-titel { font-weight: 700; color: #333; font-size: 0.92em; }
.subskala-hinweis { color: #999; font-size: 0.78em; margin-left: 4px; }
.subskala-score { font-size: 1.6em; font-weight: 800; color: #8B2635; }
.subskala-max { color: #999; font-size: 0.85em; margin-left: 3px; }
.subskala-fussnote { color: #999; font-size: 0.78em; margin-top: 10px; font-style: italic; }
.item-tabelle { width: 100%; border-collapse: collapse; font-size: 0.9em; }
.item-tabelle thead th {
text-align: left;
padding: 6px 10px;
border-bottom: 2px solid #8B2635;
color: #8B2635;
font-weight: 700;
font-size: 0.88em;
}
.item-tabelle tbody td {
padding: 6px 10px;
border-bottom: 1px solid #f0f0f0;
vertical-align: top;
line-height: 1.4;
}
.item-tabelle tbody tr:last-child td { border-bottom: none; }
.item-tabelle tbody tr:hover { background-color: #fafafa; }
.stufe-badge {
display: inline-block;
background-color: #8B2635;
color: white;
border-radius: 3px;
padding: 2px 8px;
font-size: 0.88em;
font-weight: 700;
min-width: 30px;
text-align: center;
font-family: monospace;
}
.stufe-badge-0 { background-color: #C8E6C9; color: #1B5E20; }
.stufe-badge-1 { background-color: #FFF59D; color: #7A5F00; }
.stufe-badge-2 { background-color: #FFCC80; color: #7A3E00; }
.stufe-badge-3 { background-color: #EF9A9A; color: #7B0000; }
.stufe-badge-4 { background-color: #B71C1C; color: white; }
.stufe-badge-na { background-color: #bbb; color: white; }
.punkte-zelle { color: #8B2635; font-weight: 700; text-align: right; }
.antwort-zelle { display: flex; align-items: baseline; gap: 8px; }
.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("AUDIT Auswertung"),
tags$p("Alcohol Use Disorders Identification Test • 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_audit_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_score_l = fp_text(color = "#888888", bold = FALSE, font.size = 10)
fmt_score = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 22)
fmt_klasse = fp_text(color = erg$klasse$farbe, bold = TRUE, font.size = 12)
fmt_abschn = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 12,
underlined = TRUE)
fmt_sk_label = fp_text(color = "#555555", bold = TRUE, font.size = 10)
fmt_sk_score = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 10)
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_item_ant = fp_text(color = "#555555", bold = FALSE, font.size = 10)
fmt_disclaimer = fp_text(color = "#888888", italic = TRUE, font.size = 9)
doc = read_docx()
doc = body_add_fpar(doc, fpar(ftext("AUDIT 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_audit))
doc = body_add_fpar(doc, fpar(ftext(paste0("Hinweis: ", erg$warnung_audit), fmt_warn)))
doc = body_add_par(doc, "")
doc = body_add_fpar(doc, fpar(
ftext("Summenscore: ", fmt_score_l),
ftext(if (!is.na(erg$summenscore)) as.character(erg$summenscore) else "n/a",
fmt_score)
))
doc = body_add_fpar(doc, fpar(ftext(
paste0(erg$klasse$zone, " – ", erg$klasse$text,
if (nchar(erg$klasse$bereich) > 0) paste0(" (", erg$klasse$bereich, ")") else ""),
fmt_klasse
)))
doc = body_add_par(doc, "")
if (erg$verletzung_flag) {
doc = body_add_fpar(doc, fpar(ftext(
"HINWEIS: Bitte Item 9 gesondert beachten (Verletzung durch Alkoholkonsum)",
fp_text(color = "#B71C1C", bold = TRUE, font.size = 11)
)))
doc = body_add_fpar(doc, fpar(ftext(
paste0("Gewaehlte Antwort: ", erg$item9$antwort),
fp_text(color = "#B71C1C", font.size = 10)
)))
doc = body_add_fpar(doc, fpar(ftext(
"(Aufmerksamkeitshinweis, kein automatisiertes klinisches Urteil)",
fp_text(color = "#888888", italic = TRUE, font.size = 9)
)))
doc = body_add_par(doc, "")
}
doc = body_add_fpar(doc, fpar(ftext("Subskalen", fmt_abschn)))
for (sk_name in names(AUDIT_SUBSKALEN)) {
sk = AUDIT_SUBSKALEN[[sk_name]]
sk_erg = erg$subskalen[[sk_name]]
doc = body_add_fpar(doc, fpar(
ftext(paste0(sk$label, " (", sk$hinweis, "): "), fmt_sk_label),
ftext(paste0(if (!is.na(sk_erg)) sk_erg else "n/a", " / ", sk$max, " Pkt"), fmt_sk_score)
))
}
doc = body_add_par(doc, "")
doc = body_add_fpar(doc, fpar(ftext("Einzelitems (10 Items)", fmt_abschn)))
for (it in erg$items) {
stufe_text = if (is.na(it$position)) "?" else as.character(it$position)
punkte_text = if (is.na(it$score)) "" else paste0(" [", it$score, " Pkt]")
doc = body_add_fpar(doc, fpar(
ftext(sprintf("%2d. ", it$nr), fmt_item_nr),
ftext(paste0(it$titel, " "), fmt_item_tit),
ftext(paste0(" ", stufe_text, " "),
fp_text(color = "#333333", bold = TRUE, font.size = 9,
shading.color = "#EEEEEE")),
ftext(paste0(" ", it$antwort, punkte_text), fmt_item_ant)
))
}
doc = body_add_par(doc, "")
doc = body_add_fpar(doc, fpar(ftext(AUDIT_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_audit", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = paste0("Objekt 'daten_audit' 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_audit = get("daten_audit", 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)
audit_treffer = dat_audit[dat_audit$session %in% alle_session_ids, , drop = FALSE]
if (nrow(audit_treffer) == 0) {
return(list(typ = "session_nicht_gefunden",
chiffre = chiffre,
session_id = paste(alle_session_ids, collapse = ", ")))
}
warnung_audit = NULL
if (nrow(audit_treffer) > 1) {
n_ausfuell = nrow(audit_treffer)
audit_treffer = audit_treffer %>%
arrange(desc(created)) %>%
slice(1)
datum_neu = format(as.POSIXct(audit_treffer$created[1]),
"%d.%m.%Y %H:%M", tz = "Europe/Berlin")
warnung_audit = paste0(
n_ausfuell, " Ausfuellungen gefunden. ",
"Es wird die neueste angezeigt (", datum_neu, ")."
)
}
zeile = audit_treffer[1, , drop = FALSE]
ausfuelldatum = format(as.POSIXct(zeile$created[1]),
"%d.%m.%Y", tz = "Europe/Berlin")
item_cols = paste0("audit_", sprintf("%02d", 1:10))
# labels-Attribut wird aus der Original-Spalte gelesen, nicht aus dem subgesetteten
# Datensatz, weil haven die Attribute beim Subsetten zwar erhaelt, aber das Original
# die zuverlaessigere Quelle ist.
items = lapply(seq_along(item_cols), function(i) {
col_name = item_cols[i]
spalte_orig = dat_audit[[col_name]]
wert = zeile[[col_name]]
item_label_roh = attr(spalte_orig, "label")
item_titel = if (!is.null(item_label_roh) && !is.na(item_label_roh)) {
strip_stars(as.character(item_label_roh))
} else {
AUDIT_ITEM_TEXTE[i]
}
pt = extrahiere_position_und_text(spalte_orig, wert, i)
score = if (is.na(pt$position)) {
NA_integer_
} else {
as.integer(pt$position * AUDIT_MULTIPLIKATOR[i])
}
list(
nr = i,
titel = item_titel,
position = pt$position,
score = score,
antwort = pt$text,
fehlt = is.na(pt$position)
)
})
scores = sapply(items, `[[`, "score")
n_fehlt = sum(is.na(scores))
summenscore = if (n_fehlt == 0L) as.integer(sum(scores)) else NA_integer_
klasse = klassifiziere_audit(summenscore)
subskalen = lapply(AUDIT_SUBSKALEN, function(sk) {
sk_scores = scores[sk$items]
if (any(is.na(sk_scores))) NA_integer_ else as.integer(sum(sk_scores))
})
item9 = items[[9]]
verletzung_flag = !is.na(item9$score) && item9$score > 0
list(
typ = "ergebnis",
chiffre = chiffre,
ausfuelldatum = ausfuelldatum,
warnung_audit = warnung_audit,
items = items,
summenscore = summenscore,
n_fehlt = n_fehlt,
klasse = klasse,
subskalen = subskalen,
verletzung_flag = verletzung_flag,
item9 = item9
)
})
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",
"Ungültige Chiffre. Erwartet wird ein Großbuchstabe 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 prüfen oder Pseudonymtabelle aktualisieren.")
))
}
if (erg$typ == "session_nicht_gefunden") {
return(div(class = "alert-fehler",
tags$h4("Kein AUDIT-Datensatz gefunden"),
tags$p("Zur Chiffre ", tags$b(paste0("«", erg$chiffre, "»")),
" existiert ein Pseudonymeintrag, aber kein Datensatz in ",
tags$code("daten_audit"), "."),
tags$p("Mögliche Ursachen: Bogen noch nicht ausgefüllt, ",
"oder Daten noch nicht heruntergeladen.")
))
}
kopf_block = div(class = "abschnitt-karte",
div(class = "kopf-info",
tags$b("Chiffre: "), erg$chiffre, " ",
tags$b("Ausfülldatum: "), erg$ausfuelldatum
),
if (!is.null(erg$warnung_audit))
div(class = "alert-warnung", "⚠ Hinweis: ", erg$warnung_audit)
)
verletzung_block = if (erg$verletzung_flag) {
div(class = "verletzung-block",
tags$h4("⚠️ Bitte Item 9 gesondert beachten – Verletzung durch Alkoholkonsum"),
div(class = "antwort-text",
tags$b("Gewählte Antwort: "), erg$item9$antwort
),
tags$p(class = "disclaimer",
"Dieser Hinweis ist kein automatisiertes klinisches Urteil, ",
"sondern ein Aufmerksamkeitshinweis für die behandelnde Person."
)
)
} else NULL
fehlende_items_block = if (erg$n_fehlt > 0) {
div(class = "alert-warnung",
tags$b("⚠ "), erg$n_fehlt,
" Item(s) ohne Angabe – Summenscore kann nicht berechnet werden."
)
} else NULL
score_block = div(class = "abschnitt-karte",
fluidRow(
column(4,
tags$span(class = "score-label", "Summenscore AUDIT"),
tags$span(class = "score-zahl",
if (!is.na(erg$summenscore)) as.character(erg$summenscore) else "–"
),
tags$span(class = "klasse-text",
style = paste0("color:", erg$klasse$farbe, ";"),
paste0(erg$klasse$zone, " – ", erg$klasse$text)
),
tags$span(class = "bereich-text", erg$klasse$bereich)
),
column(8,
style = "padding-top: 6px;",
plotOutput("gauge_plot", height = "110px")
)
),
fehlende_items_block
)
subskala_karten = lapply(names(AUDIT_SUBSKALEN), function(sk_name) {
sk = AUDIT_SUBSKALEN[[sk_name]]
sk_val = erg$subskalen[[sk_name]]
div(class = "subskala-karte",
div(class = "subskala-titel", sk$label,
tags$span(class = "subskala-hinweis", paste0("(", sk$hinweis, ")"))),
div(
tags$span(class = "subskala-score", if (!is.na(sk_val)) sk_val else "–"),
tags$span(class = "subskala-max", paste0("/ ", sk$max, " Pkt"))
)
)
})
subskala_block = div(class = "abschnitt-karte",
tags$h4(class = "abschnitt-titel", "Subskalen"),
div(class = "subskala-reihe", subskala_karten),
div(class = "subskala-fussnote",
"Rein informativ. Die klinische Klassifikation basiert auf dem WHO-Summenscore ",
"(0-40); für die Subskala „Konsum“ (Items 1-3, AUDIT-C) werden in der Literatur ",
"gebräuchliche Schwellenwerte von ≥4 (Männer) bzw. ≥3 (Frauen) als Hinweis auf ",
"riskanten Konsum genannt."
)
)
item_zeilen = lapply(erg$items, function(it) {
if (is.na(it$position)) {
badge_class = "stufe-badge stufe-badge-na"
badge_text = "?"
} else {
badge_class = paste0("stufe-badge stufe-badge-", min(it$position, 4L))
badge_text = as.character(it$position)
}
tags$tr(
tags$td(style = paste0("color:", AKZENT_FARBE, "; font-weight:700; width:32px;"),
paste0(it$nr, ".")),
tags$td(style = "color:#333; padding-right:14px;", it$titel),
tags$td(
div(class = "antwort-zelle",
tags$span(class = badge_class, badge_text),
tags$span(style = "color:#555;", it$antwort)
)
),
tags$td(class = "punkte-zelle",
if (is.na(it$score)) "–" else it$score
)
)
})
item_block = div(class = "abschnitt-karte",
tags$h4(class = "abschnitt-titel", "Einzelitems (10 Items)"),
tags$table(class = "item-tabelle",
tags$thead(tags$tr(
tags$th("Nr."),
tags$th("Itemtitel"),
tags$th("Antwort"),
tags$th("Punkte")
)),
tags$tbody(item_zeilen)
)
)
tagList(kopf_block, verletzung_block, score_block, subskala_block, item_block)
})
output$gauge_plot = renderPlot({
req(input$btn_suchen > 0)
erg = ergebnis_r()
req(erg$typ == "ergebnis")
erstelle_gauge(erg$summenscore)
}, bg = "white")
output$download_word = downloadHandler(
filename = function() {
erg = ergebnis_r()
if (is.null(erg) || erg$typ != "ergebnis") return("AUDIT_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("AUDIT_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
},
content = function(file) {
req(ergebnis_r()$typ == "ergebnis")
erg = ergebnis_r()
doc = erstelle_audit_docx(erg)
print(doc, target = file)
}
)
}
# Start ####
shinyApp(ui = ui, server = server)

2879
AUDIT/renv.lock Normal file
View file

File diff suppressed because it is too large Load diff

13
AUDIT/setup_renv.R Normal file
View file

@ -0,0 +1,13 @@
# Einmalig ausfuehren, bevor die App zum ersten Mal gestartet wird.
# Initialisiert renv und installiert alle benoetigten Pakete.
if (!requireNamespace("renv", quietly = TRUE)) install.packages("renv")
renv::init()
pkgs = c("shiny", "dplyr", "ggplot2", "haven", "officer", "remotes", "formr", "RSQLite")
install.packages(pkgs)
renv::snapshot()
message("Setup abgeschlossen. App starten mit: shiny::runApp('app.R')")