797 lines
32 KiB
R
797 lines
32 KiB
R
# Präambel ####
|
|
|
|
AKZENT_FARBE = "#8B2635"
|
|
|
|
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_scid5spq.R"
|
|
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
|
|
|
|
SCID5SPQ_DISCLAIMER = paste0(
|
|
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
|
|
"keine klinische Diagnose. Die Interpretation der Ergebnisse obliegt der ",
|
|
"behandelnden Person."
|
|
)
|
|
|
|
library(shiny)
|
|
library(dplyr)
|
|
library(haven)
|
|
library(tibble)
|
|
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)
|
|
|
|
|
|
# Datenaufbereitung ####
|
|
|
|
# Querverweis im Manual: Item 44 wird fuer Schizotype PS angezeigt, aber auch
|
|
# fuer den Cutoff der Schizoiden PS mitgezaehlt (nur_cutoff = TRUE).
|
|
pq_ps_mapping = tibble::tribble(
|
|
~item_nr, ~ps, ~kriterium, ~nur_cutoff,
|
|
1, "Vermeidend-Selbstunsichere PS", "Kriterium 1", FALSE,
|
|
2, "Vermeidend-Selbstunsichere PS", "Kriterium 2", FALSE,
|
|
3, "Vermeidend-Selbstunsichere PS", "Kriterium 3", FALSE,
|
|
4, "Vermeidend-Selbstunsichere PS", "Kriterium 4", FALSE,
|
|
5, "Vermeidend-Selbstunsichere PS", "Kriterium 5", FALSE,
|
|
6, "Vermeidend-Selbstunsichere PS", "Kriterium 6", FALSE,
|
|
7, "Vermeidend-Selbstunsichere PS", "Kriterium 7", FALSE,
|
|
8, "Dependente PS", "Kriterium 1", FALSE,
|
|
9, "Dependente PS", "Kriterium 2", FALSE,
|
|
10, "Dependente PS", "Kriterium 3", FALSE,
|
|
11, "Dependente PS", "Kriterium 4", FALSE,
|
|
12, "Dependente PS", "Kriterium 5", FALSE,
|
|
13, "Dependente PS", "Kriterium 6", FALSE,
|
|
14, "Dependente PS", "Kriterium 7", FALSE,
|
|
15, "Dependente PS", "Kriterium 8", FALSE,
|
|
16, "Zwanghafte PS", "Kriterium 1", FALSE,
|
|
17, "Zwanghafte PS", "Kriterium 2", FALSE,
|
|
18, "Zwanghafte PS", "Kriterium 3", FALSE,
|
|
19, "Zwanghafte PS", "Kriterium 4", FALSE,
|
|
20, "Zwanghafte PS", "Kriterium 5", FALSE,
|
|
21, "Zwanghafte PS", "Kriterium 6", FALSE,
|
|
22, "Zwanghafte PS", "Kriterium 7", FALSE,
|
|
23, "Zwanghafte PS", "Kriterium 8", FALSE,
|
|
24, "Zwanghafte PS", "Kriterium 8", FALSE,
|
|
25, "Paranoide PS", "Kriterium A1", FALSE,
|
|
26, "Paranoide PS", "Kriterium A2", FALSE,
|
|
27, "Paranoide PS", "Kriterium A3", FALSE,
|
|
28, "Paranoide PS", "Kriterium A4", FALSE,
|
|
29, "Paranoide PS", "Kriterium A5", FALSE,
|
|
30, "Paranoide PS", "Kriterium A5", FALSE,
|
|
31, "Paranoide PS", "Kriterium A6", FALSE,
|
|
32, "Paranoide PS", "Kriterium A7", FALSE,
|
|
33, "Schizotype PS", "Kriterium A1", FALSE,
|
|
34, "Schizotype PS", "Kriterium A1", FALSE,
|
|
35, "Schizotype PS", "Kriterium A1", FALSE,
|
|
36, "Schizotype PS", "Kriterium A2", FALSE,
|
|
37, "Schizotype PS", "Kriterium A2", FALSE,
|
|
38, "Schizotype PS", "Kriterium A2", FALSE,
|
|
39, "Schizotype PS", "Kriterium A2", FALSE,
|
|
40, "Schizotype PS", "Kriterium A3", FALSE,
|
|
41, "Schizotype PS", "Kriterium A3", FALSE,
|
|
42, "Schizotype PS", "Kriterium A3", FALSE,
|
|
43, "Schizotype PS", "Kriterium A3", FALSE,
|
|
44, "Schizotype PS", "Kriterium A8", FALSE,
|
|
44, "Schizoide PS", "Kriterium A5", TRUE,
|
|
45, "Schizotype PS", "Kriterium A9", FALSE,
|
|
46, "Schizoide PS", "Kriterium A1", FALSE,
|
|
47, "Schizoide PS", "Kriterium A2", FALSE,
|
|
48, "Schizoide PS", "Kriterium A3", FALSE,
|
|
49, "Schizoide PS", "Kriterium A4", FALSE,
|
|
50, "Schizoide PS", "Kriterium A6", FALSE,
|
|
51, "Schizoide PS", "Kriterium A7", FALSE,
|
|
52, "Histrionische PS", "Kriterium 1", FALSE,
|
|
53, "Histrionische PS", "Kriterium 2", FALSE,
|
|
54, "Histrionische PS", "Kriterium 2", FALSE,
|
|
55, "Histrionische PS", "Kriterium 4", FALSE,
|
|
56, "Histrionische PS", "Kriterium 6", FALSE,
|
|
57, "Histrionische PS", "Kriterium 6", FALSE,
|
|
58, "Histrionische PS", "Kriterium 7", FALSE,
|
|
59, "Histrionische PS", "Kriterium 8", FALSE,
|
|
60, "Narzisstische PS", "Kriterium 1", FALSE,
|
|
61, "Narzisstische PS", "Kriterium 1", FALSE,
|
|
62, "Narzisstische PS", "Kriterium 2", FALSE,
|
|
63, "Narzisstische PS", "Kriterium 2", FALSE,
|
|
64, "Narzisstische PS", "Kriterium 3", FALSE,
|
|
65, "Narzisstische PS", "Kriterium 3", FALSE,
|
|
66, "Narzisstische PS", "Kriterium 4", FALSE,
|
|
67, "Narzisstische PS", "Kriterium 5", FALSE,
|
|
68, "Narzisstische PS", "Kriterium 6", FALSE,
|
|
69, "Narzisstische PS", "Kriterium 6", FALSE,
|
|
70, "Narzisstische PS", "Kriterium 7", FALSE,
|
|
71, "Narzisstische PS", "Kriterium 7", FALSE,
|
|
72, "Narzisstische PS", "Kriterium 7", FALSE,
|
|
73, "Narzisstische PS", "Kriterium 8", FALSE,
|
|
74, "Narzisstische PS", "Kriterium 8", FALSE,
|
|
75, "Narzisstische PS", "Kriterium 9", FALSE,
|
|
76, "Narzisstische PS", "Kriterium 9", FALSE,
|
|
77, "Borderline-PS", "Kriterium 1", FALSE,
|
|
78, "Borderline-PS", "Kriterium 2", FALSE,
|
|
79, "Borderline-PS", "Kriterium 3", FALSE,
|
|
80, "Borderline-PS", "Kriterium 3", FALSE,
|
|
81, "Borderline-PS", "Kriterium 3", FALSE,
|
|
82, "Borderline-PS", "Kriterium 3", FALSE,
|
|
83, "Borderline-PS", "Kriterium 4", FALSE,
|
|
84, "Borderline-PS", "Kriterium 5", FALSE,
|
|
85, "Borderline-PS", "Kriterium 5", FALSE,
|
|
86, "Borderline-PS", "Kriterium 6", FALSE,
|
|
87, "Borderline-PS", "Kriterium 7", FALSE,
|
|
88, "Borderline-PS", "Kriterium 8", FALSE,
|
|
89, "Borderline-PS", "Kriterium 8", FALSE,
|
|
90, "Borderline-PS", "Kriterium 8", FALSE,
|
|
91, "Borderline-PS", "Kriterium 9", FALSE,
|
|
92, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 1", FALSE,
|
|
93, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 2", FALSE,
|
|
94, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 3", FALSE,
|
|
95, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 4", FALSE,
|
|
96, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 5", FALSE,
|
|
97, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 6", FALSE,
|
|
98, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 7", FALSE,
|
|
99, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 8", FALSE,
|
|
100, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 9", FALSE,
|
|
101, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 10", FALSE,
|
|
102, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 11", FALSE,
|
|
103, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 12", FALSE,
|
|
104, "Antisoziale PS", "Verhalten vor dem 15. Lebensjahr, Kriterium 13", FALSE,
|
|
105, "Antisoziale PS", "Verhalten vor dem 13. Lebensjahr, Kriterium 14", FALSE,
|
|
106, "Antisoziale PS", "Verhalten vor dem 13. Lebensjahr, Kriterium 15", FALSE
|
|
)
|
|
|
|
PS_REIHENFOLGE = c(
|
|
"Vermeidend-Selbstunsichere PS", "Dependente PS", "Zwanghafte PS",
|
|
"Paranoide PS", "Schizotype PS", "Schizoide PS",
|
|
"Histrionische PS", "Narzisstische PS", "Borderline-PS", "Antisoziale PS"
|
|
)
|
|
|
|
# beobachtungsbasiert_ohne_item: Kriterien die rein im Interview durch Beobachtung
|
|
# erhoben werden (kein SPQ-Item); zaehlen trotzdem zur Cutoff-Obergrenze, weil
|
|
# sie unabhaengig vom Screening mit "2" kodiert werden koennen.
|
|
ps_cutoffs = tibble::tribble(
|
|
~ps, ~kriterien_gesamt, ~cutoff, ~beobachtungsbasiert_ohne_item,
|
|
"Vermeidend-Selbstunsichere PS", 7, 4, 0,
|
|
"Dependente PS", 8, 5, 0,
|
|
"Zwanghafte PS", 8, 4, 0,
|
|
"Paranoide PS", 7, 4, 0,
|
|
"Schizotype PS", 9, 5, 4,
|
|
"Schizoide PS", 7, 4, 0,
|
|
"Histrionische PS", 8, 5, 2,
|
|
"Narzisstische PS", 9, 5, 0,
|
|
"Borderline-PS", 9, 5, 0
|
|
)
|
|
|
|
|
|
# Helper ####
|
|
|
|
loeseLabel = function(rohwert, spalte) {
|
|
labs = attr(spalte, "labels")
|
|
if (is.null(labs) || is.na(rohwert)) return(NA_character_)
|
|
treffer = names(labs)[labs == rohwert]
|
|
if (length(treffer) == 0) return(NA_character_)
|
|
treffer[1]
|
|
}
|
|
|
|
extrahiereNummer = function(label_text) {
|
|
m = regmatches(label_text, regexpr("^(\\d+)\\.", label_text))
|
|
if (length(m) == 0 || m == "") return(NA_integer_)
|
|
as.integer(sub("\\.", "", m))
|
|
}
|
|
|
|
entferneNummernpraefix = function(label_text) {
|
|
sub("^\\d+\\.\\s*", "", label_text)
|
|
}
|
|
|
|
berechneCutoffHinweis = function(ps_name, ja_item_nrs) {
|
|
|
|
# Antisoziale PS hat Sonderlogik: Screening deckt nur Sozialverhalten-Kriterien ab,
|
|
# adulte Kriterien werden unabhaengig im Interview erhoben.
|
|
if (ps_name == "Antisoziale PS") {
|
|
soz_ja = sum(
|
|
pq_ps_mapping$ps == "Antisoziale PS" &
|
|
pq_ps_mapping$item_nr %in% ja_item_nrs
|
|
)
|
|
if (soz_ja < 2) {
|
|
return(list(
|
|
erreichbar = FALSE,
|
|
hinweis = paste0(
|
|
"(Sozialverhalten-Teilkriterium [2 von 15] anhand Screening nicht erreicht; ",
|
|
"Gesamtdiagnose dadurch nicht ausgeschlossen, da die adulten Kriterien ",
|
|
"unabhaengig vom Screening im Interview erhoben werden)"
|
|
)
|
|
))
|
|
}
|
|
return(list(erreichbar = TRUE, hinweis = NULL))
|
|
}
|
|
|
|
ci = ps_cutoffs[ps_cutoffs$ps == ps_name, ]
|
|
if (nrow(ci) == 0) return(list(erreichbar = TRUE, hinweis = NULL))
|
|
|
|
cutoff = ci$cutoff
|
|
beobs = ci$beobachtungsbasiert_ohne_item
|
|
|
|
ps_rows = pq_ps_mapping[pq_ps_mapping$ps == ps_name, ]
|
|
kriterien = unique(ps_rows$kriterium)
|
|
hat_ja = vapply(kriterien, function(k) {
|
|
any(ps_rows$item_nr[ps_rows$kriterium == k] %in% ja_item_nrs)
|
|
}, logical(1))
|
|
kriterien_erfuellt = kriterien[hat_ja]
|
|
kriterien_mit_ja = length(kriterien_erfuellt)
|
|
|
|
max_erreichbar = kriterien_mit_ja + beobs
|
|
|
|
if (max_erreichbar >= cutoff) return(list(erreichbar = TRUE, hinweis = NULL))
|
|
|
|
# Paranoide/Schizotype/Schizoide PS haben Ausschluss-Kriterium B das separat geprueft werden muss
|
|
kb = if (ps_name %in% c("Paranoide PS", "Schizotype PS", "Schizoide PS")) {
|
|
"; zusaetzlich ist Kriterium B [Ausschluss anderer Stoerungen] separat zu pruefen"
|
|
} else ""
|
|
|
|
erfuellt_text = if (length(kriterien_erfuellt) > 0)
|
|
paste0(" [im Screening erfuellt: ", paste(kriterien_erfuellt, collapse = ", "), "]")
|
|
else ""
|
|
|
|
list(
|
|
erreichbar = FALSE,
|
|
hinweis = paste0(
|
|
"(Cutoff anhand Screening-Antworten nicht erreichbar: max. ", max_erreichbar,
|
|
" von ", cutoff, " erforderlichen Kriterien moeglich", erfuellt_text, kb, ")"
|
|
)
|
|
)
|
|
}
|
|
|
|
# PS-Abschnitte mit JA-Items oder nicht-erreichbarem Cutoff werden angezeigt,
|
|
# PS ohne JA-Items UND erreichbarem Cutoff werden weggelassen.
|
|
gruppiereNachPS = function(tabelle, ja_item_nrs) {
|
|
|
|
mapping_anzeige = pq_ps_mapping[!pq_ps_mapping$nur_cutoff, c("item_nr", "ps", "kriterium")]
|
|
|
|
gruppen = lapply(PS_REIHENFOLGE, function(ps_name) {
|
|
|
|
items_ps = mapping_anzeige[mapping_anzeige$ps == ps_name, c("item_nr", "kriterium")]
|
|
if (!is.null(tabelle) && nrow(tabelle) > 0) {
|
|
items_ja = merge(tabelle, items_ps, by.x = "Nummer", by.y = "item_nr")
|
|
items_ja = items_ja[order(items_ja$Nummer), c("Nummer", "Frage", "kriterium")]
|
|
} else {
|
|
items_ja = data.frame(Nummer = integer(0), Frage = character(0),
|
|
kriterium = character(0), stringsAsFactors = FALSE)
|
|
}
|
|
|
|
cutoff_r = berechneCutoffHinweis(ps_name, ja_item_nrs)
|
|
hat_ja = nrow(items_ja) > 0
|
|
|
|
if (!hat_ja && cutoff_r$erreichbar) return(NULL)
|
|
|
|
list(
|
|
ps = ps_name,
|
|
items = items_ja,
|
|
cutoff_erreich = cutoff_r$erreichbar,
|
|
hinweis = cutoff_r$hinweis
|
|
)
|
|
})
|
|
|
|
Filter(Negate(is.null), gruppen)
|
|
}
|
|
|
|
|
|
# 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;
|
|
}
|
|
|
|
.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; }
|
|
|
|
.ergebnis-kopf {
|
|
color: #8B2635;
|
|
margin: 8px 0 0 0;
|
|
font-size: 1.05em;
|
|
font-weight: 700;
|
|
}
|
|
|
|
.ps-abschnitt { margin-bottom: 18px; }
|
|
.ps-titel {
|
|
color: #8B2635;
|
|
border-bottom: 1px solid #8B2635;
|
|
padding-bottom: 3px;
|
|
margin-top: 18px;
|
|
margin-bottom: 4px;
|
|
font-size: 1em;
|
|
font-weight: 700;
|
|
}
|
|
|
|
p.cutoff-hinweis {
|
|
color: #666;
|
|
font-style: italic;
|
|
font-weight: bold;
|
|
font-size: 0.88em;
|
|
margin: 2px 0 6px 0;
|
|
}
|
|
|
|
.item-zeile { display: flex; margin-bottom: 4px; line-height: 1.45; }
|
|
.item-nr { min-width: 40px; font-weight: bold; color: #555; flex-shrink: 0; }
|
|
.item-text { flex: 1; }
|
|
.item-kriterium { min-width: 130px; color: #777; font-size: 0.88em;
|
|
flex-shrink: 0; padding-left: 14px; align-self: center; }
|
|
|
|
.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("SCID-5-SPQ Item-Lookup"),
|
|
tags$p("JA-Antworten im Screening nach Chiffre abrufen")
|
|
),
|
|
|
|
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", "Suchen", class = "btn btn-primary btn-laden"),
|
|
div(style = "margin-left: auto;",
|
|
downloadButton("download_word", "Word-Export (.docx)")
|
|
)
|
|
),
|
|
|
|
uiOutput("ergebnis_ui")
|
|
)
|
|
|
|
|
|
# Word-Export ####
|
|
|
|
erstelle_scid5spq_docx = function(erg) {
|
|
|
|
gruppen = gruppiereNachPS(erg$tabelle, erg$ja_item_nrs)
|
|
|
|
fmt_titel = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18)
|
|
fmt_meta = fp_text(color = "#333333", bold = FALSE, font.size = 11)
|
|
fmt_zusammenf = fp_text(color = "#000000", bold = TRUE, font.size = 11)
|
|
fmt_ps = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 13)
|
|
fmt_hinweis = fp_text(color = "#666666", italic = TRUE, font.size = 9.5)
|
|
fmt_item_nr = fp_text(color = "#555555", bold = TRUE, font.size = 10)
|
|
fmt_item_text = fp_text(color = "#000000", bold = FALSE, font.size = 10)
|
|
fmt_item_krit = fp_text(color = "#777777", italic = TRUE, font.size = 9)
|
|
fmt_disclaimer = fp_text(color = "#888888", italic = TRUE, font.size = 9)
|
|
|
|
doc = read_docx()
|
|
|
|
doc = body_add_fpar(doc,
|
|
fpar(ftext("SCID-5-SPQ - JA-Antworten im Screening", fmt_titel)))
|
|
|
|
doc = body_add_fpar(doc, fpar(ftext(
|
|
paste0("Chiffre: ", erg$chiffre,
|
|
" Ausfuelldatum: ", erg$ausfuelldatum,
|
|
" Erstellt am: ", format(Sys.Date(), "%d.%m.%Y")),
|
|
fmt_meta)))
|
|
|
|
if (!is.null(erg$warnung_daten))
|
|
doc = body_add_fpar(doc, fpar(ftext(
|
|
paste0("Hinweis: ", erg$warnung_daten),
|
|
fp_text(color = "#B8860B", italic = TRUE, font.size = 9)
|
|
)))
|
|
|
|
doc = body_add_par(doc, "")
|
|
|
|
doc = body_add_fpar(doc, fpar(ftext(
|
|
paste0(erg$anzahl_ja, " von 106 Items mit JA beantwortet"), fmt_zusammenf)))
|
|
|
|
for (g in gruppen) {
|
|
doc = body_add_par(doc, "")
|
|
doc = body_add_fpar(doc, fpar(ftext(g$ps, fmt_ps)))
|
|
|
|
if (!is.null(g$hinweis)) {
|
|
doc = body_add_fpar(doc, fpar(ftext(g$hinweis, fmt_hinweis)))
|
|
}
|
|
|
|
if (nrow(g$items) > 0) {
|
|
for (i in seq_len(nrow(g$items))) {
|
|
item = g$items[i, ]
|
|
doc = body_add_fpar(doc, fpar(
|
|
ftext(paste0(item$Nummer, ". "), fmt_item_nr),
|
|
ftext(item$Frage, fmt_item_text),
|
|
ftext(paste0(" ", item$kriterium), fmt_item_krit)
|
|
))
|
|
}
|
|
}
|
|
}
|
|
|
|
doc = body_add_par(doc, "")
|
|
doc = body_add_fpar(doc, fpar(ftext(SCID5SPQ_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_scid5spq", envir = .GlobalEnv)) {
|
|
return(list(typ = "skript_fehler",
|
|
meldung = paste0("Objekt 'daten_scid5spq' 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)))
|
|
}
|
|
|
|
daten_spq = get("daten_scid5spq", envir = .GlobalEnv)
|
|
pseudo_df = get("pseudo", envir = .GlobalEnv)
|
|
|
|
treffer_pseudo = pseudo_df[pseudo_df$chiffre == chiffre, ]
|
|
if (nrow(treffer_pseudo) == 0) {
|
|
return(list(typ = "chiffre_nicht_gefunden", chiffre = chiffre))
|
|
}
|
|
|
|
alle_session_ids = unique(as.character(treffer_pseudo$pseudonym))
|
|
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
|
|
|
|
treffer_daten = daten_spq[daten_spq$session %in% alle_session_ids, ]
|
|
if (nrow(treffer_daten) == 0) {
|
|
return(list(typ = "session_nicht_gefunden",
|
|
chiffre = chiffre,
|
|
session_id = paste(alle_session_ids, collapse = ", ")))
|
|
}
|
|
|
|
warnung_daten = NULL
|
|
if (nrow(treffer_daten) > 1) {
|
|
zeitstempel = format(sort(treffer_daten$created, decreasing = TRUE),
|
|
"%d.%m.%Y %H:%M")
|
|
warnung_daten = paste0(
|
|
nrow(treffer_daten), " Einreichungen gefunden (Zeitstempel: ",
|
|
paste(zeitstempel, collapse = ", "), "). Es wird die aktuellste verwendet.")
|
|
treffer_daten = treffer_daten[order(treffer_daten$created, decreasing = TRUE), ]
|
|
treffer_daten = treffer_daten[1, ]
|
|
}
|
|
|
|
zeile = treffer_daten[1, ]
|
|
ausfuelldatum = format(as.POSIXct(zeile$created), "%d.%m.%Y", tz = "Europe/Berlin")
|
|
|
|
item_spalten = paste0("q", sprintf("%03d", 1:106))
|
|
ja_items = list()
|
|
|
|
for (spname in item_spalten) {
|
|
if (!spname %in% names(zeile)) next
|
|
spalte = daten_spq[[spname]]
|
|
rohwert = zeile[[spname]]
|
|
if (is.na(rohwert)) next
|
|
antwort = loeseLabel(rohwert, spalte)
|
|
if (is.na(antwort) || toupper(trimws(antwort)) != "JA") next
|
|
label_text = attr(spalte, "label")
|
|
item_nummer = extrahiereNummer(label_text)
|
|
fragetext = entferneNummernpraefix(label_text)
|
|
ja_items[[length(ja_items) + 1]] = data.frame(
|
|
Nummer = item_nummer, Frage = fragetext, stringsAsFactors = FALSE)
|
|
}
|
|
|
|
if (length(ja_items) > 0) {
|
|
tabelle = do.call(rbind, ja_items)
|
|
tabelle = tabelle[order(tabelle$Nummer), ]
|
|
} else {
|
|
tabelle = NULL
|
|
}
|
|
|
|
list(
|
|
typ = "ergebnis",
|
|
chiffre = chiffre,
|
|
ausfuelldatum = ausfuelldatum,
|
|
tabelle = tabelle,
|
|
ja_item_nrs = if (!is.null(tabelle)) tabelle$Nummer else integer(0),
|
|
anzahl_ja = length(ja_items),
|
|
warnung_daten = warnung_daten
|
|
)
|
|
})
|
|
|
|
|
|
output$ergebnis_ui = renderUI({
|
|
|
|
if (input$btn_suchen == 0) {
|
|
return(div(class = "start-hinweis",
|
|
"Patientenchiffre eingeben und auf \"Suchen\" 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("Keine Daten gefunden"),
|
|
tags$p("Zur Chiffre ", tags$b(paste0("«", erg$chiffre, "»")),
|
|
" existiert ein Pseudonymeintrag, aber kein Datensatz in ",
|
|
tags$code("daten_scid5spq"), "."),
|
|
tags$p("Mögliche Ursachen: Bogen noch nicht ausgefüllt, ",
|
|
"oder Daten noch nicht heruntergeladen.")
|
|
))
|
|
}
|
|
|
|
gruppen = gruppiereNachPS(erg$tabelle, erg$ja_item_nrs)
|
|
|
|
kopf_block = div(class = "abschnitt-karte",
|
|
div(style = "border-bottom: 1px solid #eee; padding-bottom: 10px; margin-bottom: 8px;",
|
|
tags$b("Chiffre: "), erg$chiffre, " ",
|
|
tags$b("Ausfülldatum: "), erg$ausfuelldatum
|
|
),
|
|
if (!is.null(erg$warnung_daten))
|
|
div(class = "alert-warnung", "⚠ Hinweis: ", erg$warnung_daten),
|
|
tags$p(class = "ergebnis-kopf",
|
|
paste0(erg$anzahl_ja, " von 106 Items mit JA beantwortet"))
|
|
)
|
|
|
|
if (erg$anzahl_ja == 0 && length(gruppen) == 0) {
|
|
return(tagList(
|
|
kopf_block,
|
|
div(class = "abschnitt-karte",
|
|
tags$p(style = "color:#555; font-style:italic;",
|
|
"Keine der 106 Fragen wurde mit JA beantwortet. ",
|
|
"Hinweise zu Cutoffs weiter unten beachten, sofern vorhanden.")
|
|
)
|
|
))
|
|
}
|
|
|
|
gruppen_ui = tagList(lapply(gruppen, function(g) {
|
|
div(class = "ps-abschnitt",
|
|
tags$h4(class = "ps-titel", g$ps),
|
|
if (!is.null(g$hinweis))
|
|
tags$p(class = "cutoff-hinweis", g$hinweis)
|
|
else NULL,
|
|
if (nrow(g$items) > 0) {
|
|
tagList(lapply(seq_len(nrow(g$items)), function(i) {
|
|
item = g$items[i, ]
|
|
div(class = "item-zeile",
|
|
tags$span(class = "item-nr", paste0(item$Nummer, ".")),
|
|
tags$span(class = "item-text", item$Frage),
|
|
tags$span(class = "item-kriterium", item$kriterium))
|
|
}))
|
|
} else NULL
|
|
)
|
|
}))
|
|
|
|
tagList(kopf_block, gruppen_ui)
|
|
})
|
|
|
|
|
|
output$download_word = downloadHandler(
|
|
filename = function() {
|
|
erg = ergebnis_r()
|
|
if (is.null(erg) || erg$typ != "ergebnis") return("SCID5SPQ_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("SCID5SPQ_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
|
|
},
|
|
content = function(file) {
|
|
req(ergebnis_r()$typ == "ergebnis")
|
|
erg = ergebnis_r()
|
|
doc = erstelle_scid5spq_docx(erg)
|
|
print(doc, target = file)
|
|
}
|
|
)
|
|
}
|
|
|
|
|
|
# Start ####
|
|
|
|
shinyApp(ui = ui, server = server)
|