Initial commit
This commit is contained in:
commit
3cba772836
1341 changed files with 532924 additions and 0 deletions
BIN
DESC/.RData
Normal file
BIN
DESC/.RData
Normal file
Binary file not shown.
1
DESC/.Rprofile
Normal file
1
DESC/.Rprofile
Normal file
|
|
@ -0,0 +1 @@
|
|||
source("renv/activate.R")
|
||||
13
DESC/DESC.Rproj
Normal file
13
DESC/DESC.Rproj
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
Version: 1.0
|
||||
|
||||
RestoreWorkspace: No
|
||||
SaveWorkspace: No
|
||||
AlwaysSaveHistory: No
|
||||
|
||||
EnableCodeIndexing: Yes
|
||||
UseSpacesForTab: Yes
|
||||
NumSpacesForTab: 2
|
||||
Encoding: UTF-8
|
||||
|
||||
RnwWeave: Sweave
|
||||
LaTeX: pdfLaTeX
|
||||
756
DESC/app.R
Normal file
756
DESC/app.R
Normal file
|
|
@ -0,0 +1,756 @@
|
|||
# Präambel ####
|
||||
|
||||
|
||||
library(shiny)
|
||||
library(dplyr)
|
||||
library(ggplot2)
|
||||
library(haven)
|
||||
library(officer)
|
||||
library(DBI)
|
||||
library(RSQLite)
|
||||
|
||||
# Infrastruktur ####
|
||||
|
||||
# Beide Formen teilen sich dasselbe Download-Skript (liefert vermutlich sowohl
|
||||
# daten_desci als auch daten_descii); analog zum Muster in bdi2/pg13r.
|
||||
PFAD_DOWNLOAD_SKRIPT_DESC1 = "../API/get_data_desci.R"
|
||||
PFAD_DOWNLOAD_SKRIPT_DESC2 = "../API/get_data_descii.R"
|
||||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
|
||||
AKZENT_FARBE = "#8B2635"
|
||||
|
||||
# Hinweis (verifiziert 2026-07-01): pseudo$instrument ist ein reines Freitext-Notizfeld
|
||||
# in der lokalen SQLite-Pseudonym-Datenbank, nicht zuverlaessig befuellt und daher NICHT
|
||||
# fuer die Form-Zuordnung nutzbar. Die Zuordnung zur richtigen Form ergibt sich stattdessen
|
||||
# implizit daraus, in welchem der beiden daten_desci/daten_descii-Datensaetze die per
|
||||
# Chiffre gefundene Session-ID tatsaechlich vorkommt (siehe Server-Logik).
|
||||
|
||||
DESC_DISCLAIMER = paste0(
|
||||
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
|
||||
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person."
|
||||
)
|
||||
|
||||
APP_VERZEICHNIS = normalizePath(getwd())
|
||||
|
||||
absPath = function(pfad) {
|
||||
if (grepl("^([A-Za-z]:[/\\\\]|/)", pfad)) return(pfad)
|
||||
file.path(APP_VERZEICHNIS, pfad)
|
||||
}
|
||||
|
||||
PFAD_DOWNLOAD_SKRIPT_DESC1 = normalizePath(absPath(PFAD_DOWNLOAD_SKRIPT_DESC1), mustWork = FALSE)
|
||||
PFAD_DOWNLOAD_SKRIPT_DESC2 = normalizePath(absPath(PFAD_DOWNLOAD_SKRIPT_DESC2), mustWork = FALSE)
|
||||
PFAD_PSEUDONYM_SKRIPT = normalizePath(absPath(PFAD_PSEUDONYM_SKRIPT), mustWork = FALSE)
|
||||
|
||||
|
||||
# Helper ####
|
||||
|
||||
STUFE_FARBEN = c("0" = "#4CAF50", "1" = "#F9A825", "2" = "#EF6C00",
|
||||
"3" = "#C62828", "4" = "#6D0000")
|
||||
STUFE_TEXT_FARBEN = c("0" = "#FFFFFF", "1" = "#333333", "2" = "#FFFFFF",
|
||||
"3" = "#FFFFFF", "4" = "#FFFFFF")
|
||||
|
||||
# Konfiguration je Form buendeln, damit Server-Logik und Rendering nicht ueberall
|
||||
# zwischen DESC-I/DESC-II verzweigen muessen.
|
||||
desc_konfiguration = function(form) {
|
||||
if (form == "desc1") {
|
||||
return(list(
|
||||
form = "desc1",
|
||||
label = "DESC-I",
|
||||
praefix = "desci_",
|
||||
item_texte = ITEM_TEXTE_DESC1,
|
||||
kritisch_index = KRITISCH_INDEX_DESC1,
|
||||
download_skript = PFAD_DOWNLOAD_SKRIPT_DESC1,
|
||||
normtabelle = NORMTABELLE_DESC1,
|
||||
grenzwert_max = 28,
|
||||
daten_objekt = "daten_desci"
|
||||
))
|
||||
}
|
||||
list(
|
||||
form = "desc2",
|
||||
label = "DESC-II",
|
||||
praefix = "descii_",
|
||||
item_texte = ITEM_TEXTE_DESC2,
|
||||
kritisch_index = KRITISCH_INDEX_DESC2,
|
||||
download_skript = PFAD_DOWNLOAD_SKRIPT_DESC2,
|
||||
normtabelle = NORMTABELLE_DESC2,
|
||||
grenzwert_max = 31,
|
||||
daten_objekt = "daten_descii"
|
||||
)
|
||||
}
|
||||
|
||||
# Stufe (0-4) ausschliesslich ueber den Antworttext ableiten, niemals ueber den rohen
|
||||
# Zahlenwert - formr liefert dbl+lbl (haven/labelled), dessen Rohwert nicht verlaesslich
|
||||
# der inhaltlichen Stufe entspricht. Bei unbekanntem Antworttext klarer Fehler statt NA.
|
||||
lese_item_stufe = function(spalte_orig, wert, item_bezeichnung) {
|
||||
if (is.na(wert)) {
|
||||
stop(paste0("Item '", item_bezeichnung, "': Antwortwert fehlt (NA), ",
|
||||
"Stufe kann nicht ermittelt werden."))
|
||||
}
|
||||
|
||||
lbl = attr(spalte_orig, "labels")
|
||||
antwort_text = NA_character_
|
||||
|
||||
if (!is.null(lbl) && length(lbl) > 0) {
|
||||
idx = which(as.numeric(lbl) == as.numeric(wert))
|
||||
if (length(idx) > 0) antwort_text = names(lbl)[idx[1]]
|
||||
}
|
||||
if (is.na(antwort_text)) {
|
||||
antwort_text = as.character(haven::as_factor(wert))
|
||||
}
|
||||
antwort_text = trimws(antwort_text)
|
||||
|
||||
if (!(antwort_text %in% names(DESC_STUFEN_TEXT))) {
|
||||
stop(paste0(
|
||||
"Item '", item_bezeichnung, "': Unbekannter Antworttext '", antwort_text,
|
||||
"' - erwartet wird einer von: ", paste(names(DESC_STUFEN_TEXT), collapse = ", ")
|
||||
))
|
||||
}
|
||||
|
||||
list(stufe = as.integer(DESC_STUFEN_TEXT[[antwort_text]]), text = antwort_text)
|
||||
}
|
||||
|
||||
desc_klassifikation = function(summenwert) {
|
||||
if (summenwert >= 12) {
|
||||
return(list(text = "Hinweis auf wahrscheinliches Vorliegen einer depressiven Episode",
|
||||
farbe = "#C62828"))
|
||||
}
|
||||
list(text = "unauffaellig (kein Hinweis auf depressive Episode)", farbe = "#388E3C")
|
||||
}
|
||||
|
||||
# Nur exakte Summenwert-Treffer nachschlagen; fehlt der Wert, den naechstniedrigeren
|
||||
# Tabelleneintrag verwenden (keine Interpolation/Extrapolation) und das kennzeichnen.
|
||||
# Werte am/oberhalb des Tabellenmaximums sind in der Quelle als ">= grenzwert_max"
|
||||
# gekennzeichnet und werden entsprechend als Grenzwert, nicht als exakter Treffer, markiert.
|
||||
normwert_lookup = function(tabelle, summenwert, grenzwert_max) {
|
||||
if (summenwert >= grenzwert_max) {
|
||||
zeile = tabelle[tabelle$summenwert == grenzwert_max, ]
|
||||
return(list(
|
||||
prozentrang = zeile$prozentrang[1], t = zeile$t[1], z = zeile$z[1],
|
||||
exakt = FALSE, verwendeter_summenwert = grenzwert_max,
|
||||
warnung = paste0("Wert >= ", grenzwert_max, ", siehe Tabellenmaximum.")
|
||||
))
|
||||
}
|
||||
|
||||
treffer = tabelle[tabelle$summenwert == summenwert, ]
|
||||
if (nrow(treffer) == 1) {
|
||||
return(list(
|
||||
prozentrang = treffer$prozentrang[1], t = treffer$t[1], z = treffer$z[1],
|
||||
exakt = TRUE, verwendeter_summenwert = summenwert, warnung = NULL
|
||||
))
|
||||
}
|
||||
|
||||
kandidaten = tabelle[tabelle$summenwert < summenwert, ]
|
||||
naechst = kandidaten[which.max(kandidaten$summenwert), ]
|
||||
list(
|
||||
prozentrang = naechst$prozentrang[1], t = naechst$t[1], z = naechst$z[1],
|
||||
exakt = FALSE, verwendeter_summenwert = naechst$summenwert[1],
|
||||
warnung = paste0("Kein exakter Normwert fuer Summenwert ", summenwert,
|
||||
" verfuegbar, Werte fuer naechstniedrigeren Tabelleneintrag (",
|
||||
naechst$summenwert[1], ") angezeigt.")
|
||||
)
|
||||
}
|
||||
|
||||
make_gauge_desc = function(summenwert) {
|
||||
zonen = data.frame(
|
||||
xmin = c(0, 12),
|
||||
xmax = c(12, 40),
|
||||
farbe = c("#C8E6C9", "#FFCDD2"),
|
||||
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_vline(xintercept = 12, linetype = "dashed", color = "#B71C1C", linewidth = 0.8) +
|
||||
annotate("text", x = 12, y = 1.32, label = "Cutoff: 12",
|
||||
color = "#B71C1C", size = 3.2, fontface = "bold") +
|
||||
geom_segment(aes(x = summenwert, xend = summenwert, y = 0, yend = 1.15),
|
||||
color = "#212121", linewidth = 1) +
|
||||
geom_point(aes(x = summenwert, y = 1.28), shape = 17, size = 4, color = "#212121") +
|
||||
scale_x_continuous(limits = c(0, 40), expand = c(0, 0),
|
||||
breaks = c(0, 12, 20, 30, 40)) +
|
||||
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)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
# Datenaufbereitung ####
|
||||
|
||||
DESC_STUFEN_TEXT = c("nie" = 0, "selten" = 1, "manchmal" = 2, "meistens" = 3, "immer" = 4)
|
||||
|
||||
ITEM_TEXTE_DESC1 = c(
|
||||
"...waren Sie traurig?",
|
||||
"...sahen Sie Selbstmord als moeglichen Ausweg?",
|
||||
"...fuehlten Sie sich leer?",
|
||||
"...dachten Sie, Ihr Leben sei ein einziger Fehlschlag?",
|
||||
"...waren Sie hoffnungslos angesichts der Zukunft?",
|
||||
"...waren Sie verzweifelt?",
|
||||
"...fuehlten Sie sich einsam, selbst wenn Sie in Gesellschaft waren?",
|
||||
"...fuehlten Sie sich ueberfluessig?",
|
||||
"...hatten Sie die Freude am Leben verloren?",
|
||||
"...war das Leben eine Last fuer Sie?"
|
||||
)
|
||||
KRITISCH_INDEX_DESC1 = 2
|
||||
|
||||
ITEM_TEXTE_DESC2 = c(
|
||||
"...hatten Sie das Gefuehl, nicht gebraucht zu werden?",
|
||||
"...hatten Sie das Gefuehl, Ihr Interesse an anderen Menschen verloren zu haben?",
|
||||
"...waren Sie niedergeschlagen?",
|
||||
"...hatten Sie wenig Freude daran, etwas zu tun?",
|
||||
"...hatten Sie das Gefuehl, dass Sie zu nichts taugen?",
|
||||
"...fuehlten Sie sich ideenlos?",
|
||||
"...sahen Sie alles \"schwarz\"?",
|
||||
"...waren Sie entmutigt?",
|
||||
"...zogen Sie sich zurueck?",
|
||||
"...dachten Sie daran, mit dem Leben Schluss zu machen?"
|
||||
)
|
||||
KRITISCH_INDEX_DESC2 = 10
|
||||
|
||||
NORMTABELLE_DESC1 = data.frame(
|
||||
summenwert = c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,26,27,28),
|
||||
prozentrang = c(33.5,49.1,59.9,67.8,73.9,78.9,83.1,85.7,88.5,90.9,93.3,95.7,97.3,97.9,98.3,98.8,99.1,99.3,99.5,99.6,99.7,99.8,99.8,99.9,99.9,100.0,100.0),
|
||||
theta = c(-5.80,-4.52,-3.71,-3.19,-2.78,-2.42,-2.10,-1.81,-1.53,-1.26,-1.00,-0.75,-0.51,-0.28,-0.06,0.16,0.37,0.57,0.78,0.98,1.18,1.38,1.59,1.82,2.61,2.97,3.45),
|
||||
z = c(-1.09,-0.38,0.07,0.36,0.59,0.79,0.97,1.13,1.29,1.44,1.58,1.72,1.86,1.99,2.11,2.23,2.35,2.46,2.58,2.69,2.80,2.91,3.03,3.16,3.60,3.80,4.07),
|
||||
t = c(39,46,51,54,56,58,60,61,63,64,66,67,69,70,71,72,73,75,76,77,78,79,80,82,86,88,91)
|
||||
)
|
||||
# Hinweis: Summenwert 28 in der Quelltabelle als "20/=28" (>=28) gekennzeichnet,
|
||||
# hier als oberer Grenzwert 28 codiert. In der App-Anzeige wird bei Summenwert >= 28
|
||||
# explizit "Wert >= 28, siehe Tabellenmaximum" angezeigt, nicht als exakter Treffer.
|
||||
|
||||
NORMTABELLE_DESC2 = data.frame(
|
||||
summenwert = c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,30,31),
|
||||
prozentrang = c(38.4,49.3,59.0,65.3,70.5,75.2,79.5,82.7,85.0,87.2,89.4,91.2,92.7,94.5,95.9,97.1,97.8,98.5,98.7,98.9,99.2,99.3,99.6,99.6,99.8,99.8,99.8,99.9,100.0,100.0),
|
||||
theta = c(-6.03,-4.74,-3.93,-3.41,-3.00,-2.66,-2.35,-2.08,-1.82,-1.58,-1.35,-1.13,-0.92,-0.71,-0.51,-0.31,-0.11,0.08,0.27,0.46,0.65,0.84,1.03,1.22,1.41,1.61,1.82,2.05,2.86,3.22),
|
||||
z = c(-1.02,-0.36,0.05,0.31,0.52,0.70,0.85,0.99,1.12,1.25,1.36,1.48,1.58,1.69,1.79,1.89,1.99,2.09,2.19,2.29,2.38,2.48,2.58,2.67,2.77,2.87,2.98,3.10,3.51,3.69),
|
||||
t = c(40,46,50,53,55,57,59,60,61,62,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,85,87)
|
||||
)
|
||||
# Hinweis: Summenwert 31 in der Quelltabelle als "1/= 31" (>=31) gekennzeichnet,
|
||||
# gleiche Behandlung wie bei Form I (Tabellenmaximum, kein exakter Treffer ab 31).
|
||||
|
||||
# Anmerkung: theta = geschaetzter latenter Trait-Score (Depressivitaet) aus der
|
||||
# Rasch-Analyse; Z: Mittelwert 0, SD 1; T: Mittelwert 50, SD 10.
|
||||
|
||||
|
||||
# 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;
|
||||
}
|
||||
.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;
|
||||
padding: 7px 0; border-bottom: 1px solid #f0f0f0;
|
||||
}
|
||||
.item-zeile-kritisch { border-left: 4px solid #8B2635; padding-left: 8px; background: #FFF9F8; }
|
||||
.item-nr { font-weight: 700; color: #8B2635; min-width: 30px; flex-shrink: 0; }
|
||||
.item-text { flex: 1; 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; }
|
||||
.stufe-badge-4 { background: #6D0000; color: white; }
|
||||
.kritisch-block {
|
||||
background: #6D0000; color: white; border-radius: 5px;
|
||||
padding: 14px 18px; margin: 0 16px 16px 16px; border-left: 6px solid #FF6B6B;
|
||||
}
|
||||
.kritisch-block h4 { margin: 0 0 9px; font-size: 1.05em; font-weight: 700; }
|
||||
.kritisch-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;
|
||||
}
|
||||
.kritisch-block .disclaimer { margin-top: 10px; font-size: 0.82em; opacity: 0.82; font-style: italic; }
|
||||
"
|
||||
|
||||
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("DESC – Depressionsscreening (Parallelform I & II)")
|
||||
),
|
||||
|
||||
div(class = "input-panel",
|
||||
div(style = "min-width: 200px;",
|
||||
radioButtons("form_wahl", label = "Verwendete Form",
|
||||
choices = c("DESC-I" = "desc1", "DESC-II" = "desc2"),
|
||||
selected = character(0))
|
||||
),
|
||||
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_desc_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_klasse = fp_text(color = erg$klasse_farbe, bold = TRUE, font.size = 13)
|
||||
fp_warnung = fp_text(color = "#B8860B", italic = TRUE, font.size = 9)
|
||||
fp_kritisch_h = fp_text(color = "#C62828", bold = TRUE, font.size = 11)
|
||||
fp_kritisch_t = fp_text(color = "#C62828", font.size = 10)
|
||||
fp_fussnote = fp_text(color = "#777777", italic = TRUE, font.size = 8)
|
||||
fp_disclaimer = fp_text(color = "#777777", italic = TRUE, font.size = 9)
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext(paste0(erg$form_label, " – Depressionsscreening"), fp_titel)))
|
||||
doc = body_add_fpar(doc, fpar(ftext(
|
||||
paste0("Chiffre: ", erg$chiffre, " | Ausfuelldatum: ", erg$ausfuelldatum),
|
||||
fp_meta
|
||||
)))
|
||||
|
||||
if (!is.null(erg$warnung_mehrfach)) {
|
||||
doc = body_add_fpar(doc, fpar(ftext(erg$warnung_mehrfach, fp_warnung)))
|
||||
}
|
||||
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
|
||||
if (erg$kritisch_flag) {
|
||||
doc = body_add_fpar(doc, fpar(ftext(
|
||||
paste0("HINWEIS: Kritisches Item auffaellig – ", erg$kritisch_item_text),
|
||||
fp_kritisch_h
|
||||
)))
|
||||
doc = body_add_fpar(doc, fpar(ftext(
|
||||
paste0("Gewaehlte Antwort: ", erg$kritisch_antwort_text), fp_kritisch_t
|
||||
)))
|
||||
doc = body_add_fpar(doc, fpar(ftext(
|
||||
"Dies ist kein automatisiertes klinisches Urteil.", fp_kritisch_t
|
||||
)))
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
}
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext(
|
||||
paste0("Summenscore: ", erg$summenwert, " / 40"), fp_abschnitt
|
||||
)))
|
||||
doc = body_add_fpar(doc, fpar(ftext(erg$klasse_text, fp_klasse)))
|
||||
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
doc = body_add_fpar(doc, fpar(ftext("Normwerte (bevoelkerungsrepraesentativ)", fp_abschnitt)))
|
||||
if (!erg$norm$exakt) {
|
||||
doc = body_add_fpar(doc, fpar(ftext(erg$norm$warnung, fp_warnung)))
|
||||
}
|
||||
doc = body_add_fpar(doc, fpar(ftext(
|
||||
paste0("Prozentrang: ", erg$norm$prozentrang,
|
||||
" T-Wert: ", erg$norm$t,
|
||||
" Z-Wert: ", erg$norm$z),
|
||||
fp_normal
|
||||
)))
|
||||
doc = body_add_fpar(doc, fpar(ftext(
|
||||
paste0("Theta: geschaetzter latenter Trait-Score (Depressivitaet) aus der Rasch-Analyse. ",
|
||||
"Z: Mittelwert 0, SD 1. T: Mittelwert 50, SD 10."),
|
||||
fp_fussnote
|
||||
)))
|
||||
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
doc = body_add_fpar(doc, fpar(ftext("Einzelitems (10 Items)", fp_abschnitt)))
|
||||
|
||||
for (i in seq_along(erg$item_texte)) {
|
||||
stufe = erg$stufen[i]
|
||||
stufe_key = as.character(stufe)
|
||||
kritisch = (i == erg$kritisch_index)
|
||||
fp_badge = fp_text(
|
||||
color = STUFE_TEXT_FARBEN[[stufe_key]],
|
||||
bold = TRUE,
|
||||
shading.color = STUFE_FARBEN[[stufe_key]],
|
||||
font.size = 9
|
||||
)
|
||||
praefix_txt = if (kritisch) "[KRITISCH] " else ""
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(paste0(sprintf("%02d", i), ". ", praefix_txt, erg$item_texte[i], " "), fp_normal),
|
||||
ftext(paste0(" ", erg$antworten[i], " "), fp_badge)
|
||||
))
|
||||
}
|
||||
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
doc = body_add_fpar(doc, fpar(ftext(DESC_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, {
|
||||
|
||||
if (is.null(input$form_wahl) || length(input$form_wahl) == 0) {
|
||||
return(list(typ = "form_fehler"))
|
||||
}
|
||||
cfg = desc_konfiguration(input$form_wahl)
|
||||
|
||||
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(cfg$download_skript)) {
|
||||
return(list(typ = "pfad_fehler", pfad = cfg$download_skript))
|
||||
}
|
||||
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
|
||||
return(list(typ = "pfad_fehler", pfad = PFAD_PSEUDONYM_SKRIPT))
|
||||
}
|
||||
|
||||
# Nur das zur gewaehlten Form passende Download-Skript sourcen - fuer die nicht
|
||||
# gewaehlte Form findet keinerlei Download-/Netzwerkaktivitaet statt.
|
||||
ok_dl = tryCatch({
|
||||
source(cfg$download_skript, local = FALSE)
|
||||
list(ok = TRUE)
|
||||
}, error = function(e) list(
|
||||
ok = FALSE, msg = e$message,
|
||||
aufruf = if (!is.null(e$call)) paste(deparse(e$call), collapse = " ") else NA_character_
|
||||
))
|
||||
if (!ok_dl$ok) {
|
||||
return(list(typ = "skript_fehler",
|
||||
skript = basename(cfg$download_skript),
|
||||
pfad = cfg$download_skript,
|
||||
meldung = ok_dl$msg,
|
||||
aufruf = ok_dl$aufruf))
|
||||
}
|
||||
|
||||
if (!exists(cfg$daten_objekt, envir = .GlobalEnv) ||
|
||||
!is.data.frame(get(cfg$daten_objekt, envir = .GlobalEnv))) {
|
||||
return(list(typ = "daten_fehler", cfg = cfg))
|
||||
}
|
||||
daten = get(cfg$daten_objekt, 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,
|
||||
aufruf = if (!is.null(e$call)) paste(deparse(e$call), collapse = " ") else NA_character_
|
||||
))
|
||||
if (!ok_ps$ok) {
|
||||
return(list(typ = "skript_fehler",
|
||||
skript = basename(PFAD_PSEUDONYM_SKRIPT),
|
||||
pfad = PFAD_PSEUDONYM_SKRIPT,
|
||||
meldung = ok_ps$msg,
|
||||
aufruf = ok_ps$aufruf))
|
||||
}
|
||||
|
||||
if (!exists("pseudo", envir = .GlobalEnv)) {
|
||||
return(list(typ = "skript_fehler",
|
||||
meldung = "Objekt 'pseudo' nach dem Sourcen nicht gefunden."))
|
||||
}
|
||||
pseudo = get("pseudo", envir = .GlobalEnv)
|
||||
|
||||
# pseudo$instrument ist nur ein unzuverlaessiges Freitext-Notizfeld (verifiziert
|
||||
# 2026-07-01) und wird daher NICHT zur Form-Zuordnung verwendet. Stattdessen alle
|
||||
# zur Chiffre gehoerenden Session-IDs holen und gegen den formspezifischen
|
||||
# Datensatz (daten_desci/daten_descii) matchen - die Form-Zugehoerigkeit ergibt
|
||||
# sich implizit daraus, in welchem Datensatz die Session tatsaechlich auftaucht.
|
||||
treffer = pseudo[toupper(pseudo$chiffre) == chiffre, ]
|
||||
if (nrow(treffer) == 0) {
|
||||
return(list(typ = "chiffre_nicht_gefunden", chiffre = chiffre, cfg = cfg))
|
||||
}
|
||||
|
||||
alle_session_ids = unique(treffer$pseudonym)
|
||||
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
|
||||
|
||||
zeilen = daten[daten$session %in% alle_session_ids, ]
|
||||
if (nrow(zeilen) == 0) {
|
||||
return(list(typ = "session_nicht_gefunden", chiffre = chiffre, cfg = cfg))
|
||||
}
|
||||
|
||||
warnung_mehrfach = NULL
|
||||
if (nrow(zeilen) > 1) {
|
||||
n_mehrfach = nrow(zeilen)
|
||||
zeilen = zeilen[order(zeilen$created, decreasing = TRUE), ]
|
||||
warnung_mehrfach = paste0(
|
||||
n_mehrfach, " Ausfuellungen gefunden. Es wird die neueste angezeigt."
|
||||
)
|
||||
}
|
||||
zeile = zeilen[1, , drop = FALSE]
|
||||
|
||||
item_cols = paste0(cfg$praefix, sprintf("%02d", 1:10))
|
||||
|
||||
ok_items = tryCatch({
|
||||
erg_items = lapply(seq_along(item_cols), function(i) {
|
||||
col_name = item_cols[i]
|
||||
spalte_orig = daten[[col_name]]
|
||||
wert = zeile[[col_name]]
|
||||
lese_item_stufe(spalte_orig, wert, paste0(cfg$label, " Item ", i))
|
||||
})
|
||||
list(ok = TRUE, items = erg_items)
|
||||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||||
if (!ok_items$ok) {
|
||||
return(list(typ = "item_fehler", meldung = ok_items$msg))
|
||||
}
|
||||
|
||||
stufen = sapply(ok_items$items, `[[`, "stufe")
|
||||
antworten = sapply(ok_items$items, `[[`, "text")
|
||||
|
||||
summenwert = sum(stufen)
|
||||
klass = desc_klassifikation(summenwert)
|
||||
norm = normwert_lookup(cfg$normtabelle, summenwert, cfg$grenzwert_max)
|
||||
|
||||
kritisch_index = cfg$kritisch_index
|
||||
kritisch_flag = stufen[kritisch_index] >= 1
|
||||
|
||||
ausfuelldatum = format(as.Date(zeile$created[1]), "%d.%m.%Y")
|
||||
|
||||
list(
|
||||
typ = "ok",
|
||||
form = cfg$form,
|
||||
form_label = cfg$label,
|
||||
chiffre = chiffre,
|
||||
ausfuelldatum = ausfuelldatum,
|
||||
warnung_mehrfach = warnung_mehrfach,
|
||||
item_texte = cfg$item_texte,
|
||||
stufen = stufen,
|
||||
antworten = antworten,
|
||||
summenwert = summenwert,
|
||||
klasse_text = klass$text,
|
||||
klasse_farbe = klass$farbe,
|
||||
norm = norm,
|
||||
kritisch_index = kritisch_index,
|
||||
kritisch_flag = kritisch_flag,
|
||||
kritisch_item_text = cfg$item_texte[kritisch_index],
|
||||
kritisch_antwort_text = antworten[kritisch_index]
|
||||
)
|
||||
})
|
||||
|
||||
baue_item_liste = function(erg) {
|
||||
lapply(seq_along(erg$item_texte), function(i) {
|
||||
stufe = erg$stufen[i]
|
||||
stufe_key = as.character(stufe)
|
||||
kritisch = (i == erg$kritisch_index)
|
||||
klasse_row = if (kritisch) "item-zeile item-zeile-kritisch" else "item-zeile"
|
||||
div(class = klasse_row,
|
||||
div(class = "item-nr", sprintf("%02d", i)),
|
||||
div(class = "item-text", erg$item_texte[i]),
|
||||
span(class = paste0("stufe-badge stufe-badge-", stufe_key), erg$antworten[i])
|
||||
)
|
||||
})
|
||||
}
|
||||
|
||||
baue_ergebnis_anzeige = function(erg) {
|
||||
tagList(
|
||||
if (!is.null(erg$warnung_mehrfach)) {
|
||||
div(class = "alert-warnung", erg$warnung_mehrfach)
|
||||
},
|
||||
if (erg$kritisch_flag) {
|
||||
div(class = "kritisch-block",
|
||||
tags$h4("⚠ Kritisches Item auffaellig"),
|
||||
tags$p(erg$kritisch_item_text),
|
||||
div(class = "antwort-text",
|
||||
tags$b("Gewaehlte Antwort: "), erg$kritisch_antwort_text
|
||||
),
|
||||
tags$p(class = "disclaimer", "Dies ist kein automatisiertes klinisches Urteil.")
|
||||
)
|
||||
},
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "meta-zeile",
|
||||
tags$b("Form: "), erg$form_label,
|
||||
tags$span(class = "sep", "|"),
|
||||
tags$b("Chiffre: "), erg$chiffre,
|
||||
tags$span(class = "sep", "|"),
|
||||
tags$b("Ausfuelldatum: "), erg$ausfuelldatum,
|
||||
tags$span(class = "sep", "|"),
|
||||
tags$b("Summenscore: "), paste0(erg$summenwert, " / 40")
|
||||
),
|
||||
div(class = "klassifikation-badge", style = paste0("color:", erg$klasse_farbe, ";"),
|
||||
erg$klasse_text
|
||||
),
|
||||
plotOutput("gauge_plot", height = "80px"),
|
||||
if (!erg$norm$exakt) {
|
||||
div(class = "alert-warnung", erg$norm$warnung)
|
||||
},
|
||||
tags$p(style = "margin-top: 10px;",
|
||||
tags$b("Prozentrang: "), erg$norm$prozentrang, " ",
|
||||
tags$b("T-Wert: "), erg$norm$t, " ",
|
||||
tags$b("Z-Wert: "), erg$norm$z
|
||||
)
|
||||
),
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Einzelitems (10 Items)"),
|
||||
baue_item_liste(erg)
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
output$ergebnis_ui = renderUI({
|
||||
erg = erg_aktuell()
|
||||
if (is.null(erg)) return(NULL)
|
||||
|
||||
switch(erg$typ,
|
||||
"form_fehler" = div(class = "alert-fehler",
|
||||
"Bitte zuerst eine Form auswaehlen (DESC-I oder DESC-II)."
|
||||
),
|
||||
"format_fehler" = div(class = "alert-fehler",
|
||||
"Ungueltiges Chiffre-Format (erwartet: P000123)"
|
||||
),
|
||||
"pfad_fehler" = div(class = "alert-fehler",
|
||||
paste0("Skript-Pfad nicht gefunden: ", erg$pfad)
|
||||
),
|
||||
"skript_fehler" = div(class = "alert-fehler",
|
||||
tags$p(tags$b(paste0("Fehler beim Ausfuehren von: ", erg$skript))),
|
||||
tags$p(tags$code(erg$pfad)),
|
||||
if (!is.null(erg$aufruf) && !is.na(erg$aufruf)) {
|
||||
tags$p(tags$b("Fehlgeschlagener Aufruf: "), tags$code(erg$aufruf))
|
||||
},
|
||||
tags$p(tags$b("Meldung: "), erg$meldung)
|
||||
),
|
||||
"daten_fehler" = div(class = "alert-fehler",
|
||||
paste0(erg$cfg$daten_objekt, " nicht geladen")
|
||||
),
|
||||
"db_fehler" = div(class = "alert-fehler",
|
||||
"pseudonyme.db nicht gefunden"
|
||||
),
|
||||
"chiffre_nicht_gefunden" = div(class = "alert-fehler",
|
||||
paste0("Keine ", erg$cfg$label, "-Zuordnung fuer Chiffre ", erg$chiffre, " gefunden")
|
||||
),
|
||||
"session_nicht_gefunden" = div(class = "alert-fehler",
|
||||
paste0("Fuer Chiffre ", erg$chiffre, " liegen keine ", erg$cfg$label, "-Antwortdaten vor")
|
||||
),
|
||||
"item_fehler" = div(class = "alert-fehler",
|
||||
paste0("Fehler bei der Itemauswertung: ", erg$meldung)
|
||||
),
|
||||
"ok" = baue_ergebnis_anzeige(erg)
|
||||
)
|
||||
})
|
||||
|
||||
output$gauge_plot = renderPlot({
|
||||
erg = erg_aktuell()
|
||||
req(erg$typ == "ok")
|
||||
make_gauge_desc(erg$summenwert)
|
||||
}, 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")
|
||||
praefix_dateiname = if (erg$form == "desc1") "DESC-I" else "DESC-II"
|
||||
paste0(praefix_dateiname, "_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
|
||||
},
|
||||
content = function(file) {
|
||||
erg = erg_aktuell()
|
||||
doc = erstelle_desc_docx(erg)
|
||||
print(doc, target = file)
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
# Start ####
|
||||
|
||||
shinyApp(ui, server)
|
||||
3066
DESC/renv.lock
Normal file
3066
DESC/renv.lock
Normal file
File diff suppressed because it is too large
Load diff
17
DESC/setup_renv.R
Normal file
17
DESC/setup_renv.R
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
# Einmalig ausfuehren, bevor die App zum ersten Mal gestartet wird.
|
||||
# Initialisiert renv und installiert alle benoetigten Pakete.
|
||||
#
|
||||
# DBI und RSQLite werden vom gesourcten Pseudonym-Skript benoetigt,
|
||||
# nicht direkt von der App selbst.
|
||||
|
||||
renv::init()
|
||||
|
||||
pkgs = c("shiny", "dplyr", "ggplot2", "haven", "officer", "DBI", "RSQLite", "remotes")
|
||||
install.packages(pkgs)
|
||||
|
||||
renv::snapshot()
|
||||
|
||||
message("Setup abgeschlossen. App starten mit: shiny::runApp()")
|
||||
|
||||
install.packages("remotes")
|
||||
remotes::install_github("rubenarslan/formr")
|
||||
Loading…
Add table
Add a link
Reference in a new issue