Initial commit
This commit is contained in:
commit
3cba772836
1341 changed files with 532924 additions and 0 deletions
797
SKID5-SPQ/app.R
Normal file
797
SKID5-SPQ/app.R
Normal file
|
|
@ -0,0 +1,797 @@
|
|||
# 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)
|
||||
Loading…
Add table
Add a link
Reference in a new issue