Initial commit
This commit is contained in:
commit
3cba772836
1341 changed files with 532924 additions and 0 deletions
794
PSSI/app.R
Normal file
794
PSSI/app.R
Normal file
|
|
@ -0,0 +1,794 @@
|
|||
# Präambel ####
|
||||
|
||||
AKZENT_FARBE = "#8B2635"
|
||||
|
||||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_pssi.R"
|
||||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
|
||||
PFAD_NORMTABELLEN = "normtabellen"
|
||||
|
||||
PSSI_DISCLAIMER = paste0(
|
||||
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
|
||||
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ",
|
||||
"Es wird kein klinischer Cutoff-Wert angewendet; Prozentrang und T-Wert werden ",
|
||||
"neutral berichtet und muessen fachlich eingeordnet werden."
|
||||
)
|
||||
|
||||
library(shiny)
|
||||
library(dplyr)
|
||||
library(ggplot2)
|
||||
library(haven)
|
||||
library(officer)
|
||||
library(DBI)
|
||||
library(RSQLite)
|
||||
|
||||
|
||||
# Infrastruktur ####
|
||||
|
||||
APP_VERZEICHNIS = normalizePath(getwd())
|
||||
|
||||
absPath = function(pfad) {
|
||||
if (grepl("^([A-Za-z]:[/\\\\]|/)", pfad)) return(pfad)
|
||||
file.path(APP_VERZEICHNIS, pfad)
|
||||
}
|
||||
|
||||
PFAD_DOWNLOAD_SKRIPT = normalizePath(absPath(PFAD_DOWNLOAD_SKRIPT), mustWork = FALSE)
|
||||
PFAD_PSEUDONYM_SKRIPT = normalizePath(absPath(PFAD_PSEUDONYM_SKRIPT), mustWork = FALSE)
|
||||
PFAD_NORMTABELLEN = normalizePath(absPath(PFAD_NORMTABELLEN), mustWork = FALSE)
|
||||
|
||||
|
||||
# Helper ####
|
||||
|
||||
pssi_antwortkategorien = c(
|
||||
"trifft gar nicht zu", "trifft etwas zu",
|
||||
"trifft ueberwiegend zu", "trifft ausgesprochen zu"
|
||||
)
|
||||
|
||||
pssi_normalisiere_kat = function(text) {
|
||||
x = tolower(trimws(as.character(text)))
|
||||
x = gsub("ü", "ue", x, fixed = TRUE)
|
||||
x
|
||||
}
|
||||
pssi_antwortkategorien_norm = pssi_normalisiere_kat(pssi_antwortkategorien)
|
||||
|
||||
# Extrahiert die Stufe 0-3 aus einer PSSI-Item-Spalte. Nutzt bei
|
||||
# haven-labelled Spalten IMMER das labels-Attribut (Antworttext -> Code),
|
||||
# nie den rohen numerischen Code direkt, da dessen Kodierung variieren kann.
|
||||
stufe_aus_item = function(spalte, item_name = "") {
|
||||
if (length(spalte) == 0 || is.na(spalte[1])) return(NA_integer_)
|
||||
|
||||
if (haven::is.labelled(spalte)) {
|
||||
lbl_attr = attr(spalte, "labels")
|
||||
wert = as.numeric(spalte[1])
|
||||
if (is.null(lbl_attr) || length(lbl_attr) == 0 || is.na(wert)) {
|
||||
stop(paste0("Unerwartetes Antwortformat bei PSSI-Item ", item_name,
|
||||
": labelled-Spalte ohne labels-Attribut."))
|
||||
}
|
||||
pos = which(as.vector(lbl_attr) == wert)
|
||||
if (length(pos) == 0) {
|
||||
stop(paste0("Unerwartetes Antwortformat bei PSSI-Item ", item_name,
|
||||
": Code ", wert, " nicht in labels-Attribut gefunden."))
|
||||
}
|
||||
txt_norm = pssi_normalisiere_kat(names(lbl_attr)[pos[1]])
|
||||
stufe = match(txt_norm, pssi_antwortkategorien_norm) - 1L
|
||||
if (is.na(stufe)) {
|
||||
stop(paste0("Unerwartetes Antwortformat bei PSSI-Item ", item_name,
|
||||
": Antworttext '", names(lbl_attr)[pos[1]],
|
||||
"' passt zu keiner der vier bekannten Kategorien."))
|
||||
}
|
||||
return(as.integer(stufe))
|
||||
}
|
||||
|
||||
txt_norm = pssi_normalisiere_kat(spalte[1])
|
||||
stufe = match(txt_norm, pssi_antwortkategorien_norm) - 1L
|
||||
if (is.na(stufe)) {
|
||||
stop(paste0("Unerwartetes Antwortformat bei PSSI-Item ", item_name,
|
||||
": Wert '", spalte[1], "' passt zu keiner der vier bekannten Kategorien."))
|
||||
}
|
||||
as.integer(stufe)
|
||||
}
|
||||
|
||||
pssi_pr_t_lookup = function(normtabelle, skala, rohwert) {
|
||||
zeile = normtabelle[normtabelle$rohwert == rohwert, , drop = FALSE]
|
||||
if (nrow(zeile) == 0) return(list(pr = NA_real_, t = NA_real_))
|
||||
pr_col = paste0(skala, "_PR")
|
||||
t_col = paste0(skala, "_T")
|
||||
list(
|
||||
pr = suppressWarnings(as.numeric(zeile[[pr_col]][1])),
|
||||
t = suppressWarnings(as.numeric(zeile[[t_col]][1]))
|
||||
)
|
||||
}
|
||||
|
||||
pssi_vorschlag_normtabelle = function(alter, geschlecht) {
|
||||
if (is.na(alter) || alter < 14 || alter > 82) return(NULL)
|
||||
if (is.na(geschlecht) || !(geschlecht %in% c("weiblich", "maennlich"))) return(NULL)
|
||||
|
||||
if (alter >= 14 && alter <= 17) return("B4")
|
||||
|
||||
altersgruppe = if (alter <= 25) "18_25"
|
||||
else if (alter <= 45) "26_45"
|
||||
else if (alter <= 55) "46_55"
|
||||
else "56_82"
|
||||
|
||||
schluessel = list(
|
||||
"18_25" = c(weiblich = "B10", maennlich = "B9"),
|
||||
"26_45" = c(weiblich = "B12", maennlich = "B11"),
|
||||
"46_55" = c(weiblich = "B14", maennlich = "B13"),
|
||||
"56_82" = c(weiblich = "B16", maennlich = "B15")
|
||||
)
|
||||
unname(schluessel[[altersgruppe]][geschlecht])
|
||||
}
|
||||
|
||||
pssi_profil_plot = function(profil_df) {
|
||||
df = profil_df
|
||||
df$fehlend = is.na(df$t)
|
||||
df_plot = df
|
||||
df_plot$t_plot = ifelse(df_plot$fehlend, NA, df_plot$t)
|
||||
|
||||
ggplot(df_plot, aes(x = skala, y = t_plot, group = 1)) +
|
||||
geom_hline(yintercept = 50, color = "#777777", linetype = "dashed", linewidth = 0.6) +
|
||||
annotate("text", x = levels(df_plot$skala)[1], y = 52,
|
||||
label = "Populationsmittelwert (T=50) - statistische Konvention, kein Cutoff",
|
||||
hjust = 0, size = 3, color = "#555555") +
|
||||
geom_line(color = AKZENT_FARBE, linewidth = 0.9, na.rm = TRUE) +
|
||||
geom_point(data = df_plot[!df_plot$fehlend, ], aes(x = skala, y = t_plot),
|
||||
color = AKZENT_FARBE, size = 2.6) +
|
||||
geom_point(data = df_plot[df_plot$fehlend, ], aes(x = skala, y = 50),
|
||||
shape = 21, size = 3, color = AKZENT_FARBE, fill = "white", stroke = 1.1) +
|
||||
scale_y_continuous(limits = c(10, 90), breaks = seq(10, 90, 10)) +
|
||||
labs(x = NULL, y = "T-Wert",
|
||||
caption = "Offener Kreis = kein T-Wert ausgewiesen (Boden-/Deckeneffekt der Normstichprobe)") +
|
||||
theme_minimal(base_size = 11) +
|
||||
theme(
|
||||
panel.grid.minor = element_blank(),
|
||||
axis.text.x = element_text(angle = 0),
|
||||
plot.caption = element_text(size = 8, color = "#777777", hjust = 0)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
# Datenaufbereitung ####
|
||||
|
||||
pssi_skala_reihenfolge_items = c("PN","SZ","ST","BL","HI","NA","SU","AB","ZW","NT","DP","SL","RH","AS")
|
||||
pssi_item_map = data.frame(
|
||||
item = 1:140,
|
||||
skala = rep(pssi_skala_reihenfolge_items, times = 10),
|
||||
umgepolt = (1:140) %in% c(15, 39, 43, 44, 49, 67, 71, 72, 86, 91, 99, 104, 105, 109, 137),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
{
|
||||
n_je_skala = table(pssi_item_map$skala)
|
||||
if (!all(n_je_skala == 10) || length(n_je_skala) != 14) {
|
||||
stop("Datenintegritaetsfehler: pssi_item_map weist nicht jeder der 14 Skalen genau 10 Items zu.")
|
||||
}
|
||||
if (length(unique(pssi_item_map$item)) != 140 || anyNA(pssi_item_map$skala)) {
|
||||
stop("Datenintegritaetsfehler: nicht alle 140 PSSI-Items sind genau einer Skala zugeordnet.")
|
||||
}
|
||||
}
|
||||
|
||||
pssi_skalennamen = c(
|
||||
AS = "Selbstbestimmt (antisoziale PS)",
|
||||
PN = "Eigenwillig (paranoide PS)",
|
||||
SZ = "Zurueckhaltend (schizoide PS)",
|
||||
SU = "Selbstkritisch (selbstunsichere PS)",
|
||||
ZW = "Sorgfaeltig (zwanghafte PS)",
|
||||
ST = "Ahnungsvoll (schizotypische PS)",
|
||||
RH = "Optimistisch (rhapsodisch, kein DSM-Bezug)",
|
||||
"NA" = "Ehrgeizig (narzisstische PS)",
|
||||
NT = "Kritisch (negativistische/passiv-aggressive PS)",
|
||||
AB = "Loyal (abhaengige PS)",
|
||||
BL = "Spontan (Borderline-PS)",
|
||||
HI = "Liebenswuerdig (histrionische PS)",
|
||||
DP = "Still/passiv (depressive PS, kein DSM-Achse-II-Bezug)",
|
||||
SL = "Hilfsbereit/altruistisch (selbstlose PS, kein DSM-Bezug)"
|
||||
)
|
||||
|
||||
pssi_skala_anzeige_reihenfolge = c("AS","PN","SZ","SU","ZW","ST","RH","NA","NT","AB","BL","HI","DP","SL")
|
||||
|
||||
pssi_normtabellen_meta = data.frame(
|
||||
key = paste0("B", 1:16),
|
||||
datei = c(
|
||||
"B1_gesamtstichprobe.csv", "B2_maenner_gesamt.csv", "B3_frauen_gesamt.csv",
|
||||
"B4_14_17_jahre.csv", "B5_18_25_jahre.csv", "B6_26_45_jahre.csv",
|
||||
"B7_46_55_jahre.csv", "B8_56_82_jahre.csv", "B9_18_25_maenner.csv",
|
||||
"B10_18_25_frauen.csv", "B11_26_45_maenner.csv", "B12_26_45_frauen.csv",
|
||||
"B13_46_55_maenner.csv", "B14_46_55_frauen.csv", "B15_56_82_maenner.csv",
|
||||
"B16_56_82_frauen.csv"
|
||||
),
|
||||
beschreibung = c(
|
||||
"Gesamtstichprobe, alle Erwachsenen", "alle erwachsenen Maenner", "alle erwachsenen Frauen",
|
||||
"14-17 Jahre (beide Geschlechter)", "18-25 Jahre (beide Geschlechter)", "26-45 Jahre (beide Geschlechter)",
|
||||
"46-55 Jahre (beide Geschlechter)", "56-82 Jahre (beide Geschlechter)", "18-25 Jahre, maennlich",
|
||||
"18-25 Jahre, weiblich", "26-45 Jahre, maennlich", "26-45 Jahre, weiblich",
|
||||
"46-55 Jahre, maennlich", "46-55 Jahre, weiblich", "56-82 Jahre, maennlich",
|
||||
"56-82 Jahre, weiblich"
|
||||
),
|
||||
n = c(1903, 1037, 866, 40, 658, 852, 256, 137, 327, 331, 456, 396, 183, 73, 71, 66),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
pssi_normtabellen_meta$label = paste0(
|
||||
pssi_normtabellen_meta$key, " – ", pssi_normtabellen_meta$beschreibung,
|
||||
" (N=", pssi_normtabellen_meta$n, ")"
|
||||
)
|
||||
|
||||
pssi_normtabellen = list()
|
||||
for (i in seq_len(nrow(pssi_normtabellen_meta))) {
|
||||
key = pssi_normtabellen_meta$key[i]
|
||||
datei = pssi_normtabellen_meta$datei[i]
|
||||
pfad = file.path(PFAD_NORMTABELLEN, datei)
|
||||
|
||||
if (!file.exists(pfad)) {
|
||||
stop(paste0("Normtabelle nicht gefunden: ", pfad))
|
||||
}
|
||||
|
||||
tab = tryCatch(
|
||||
read.csv(pfad, na.strings = character(0), stringsAsFactors = FALSE),
|
||||
error = function(e) stop(paste0("Fehler beim Einlesen von '", datei, "': ", e$message))
|
||||
)
|
||||
|
||||
if (!("rohwert" %in% names(tab))) {
|
||||
stop(paste0("Normtabelle '", datei, "' hat keine Spalte 'rohwert'."))
|
||||
}
|
||||
if (!setequal(sort(tab$rohwert), 0:30)) {
|
||||
stop(paste0("Normtabelle '", datei, "' enthaelt nicht lueckenlos die Rohwerte 0-30."))
|
||||
}
|
||||
for (sk in pssi_skala_reihenfolge_items) {
|
||||
pr_col = paste0(sk, "_PR")
|
||||
t_col = paste0(sk, "_T")
|
||||
if (!(pr_col %in% names(tab))) {
|
||||
stop(paste0("Normtabelle '", datei, "' hat keine Spalte '", pr_col, "'."))
|
||||
}
|
||||
if (!(t_col %in% names(tab))) {
|
||||
stop(paste0("Normtabelle '", datei, "' hat keine Spalte '", t_col, "'."))
|
||||
}
|
||||
}
|
||||
|
||||
pssi_normtabellen[[key]] = tab
|
||||
}
|
||||
|
||||
|
||||
# UI ####
|
||||
|
||||
app_css = "
|
||||
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; }
|
||||
.container-fluid { max-width: 1100px; }
|
||||
.app-header {
|
||||
background: #8B2635; color: white; padding: 18px 24px 14px;
|
||||
margin-bottom: 20px; border-radius: 0 0 6px 6px;
|
||||
}
|
||||
.app-header h2 { margin: 0; font-size: 1.5rem; font-weight: 600; }
|
||||
.app-header p { margin: 4px 0 0; opacity: 0.85; font-size: 0.9rem; }
|
||||
.input-panel {
|
||||
background: white; border-radius: 6px; padding: 16px 20px;
|
||||
margin-bottom: 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
|
||||
display: flex; align-items: flex-end; gap: 12px; flex-wrap: wrap;
|
||||
}
|
||||
.input-panel .form-group { margin-bottom: 0; }
|
||||
.input-panel label { font-weight: 600; color: #333; }
|
||||
.btn-laden {
|
||||
background: #8B2635 !important; color: white !important;
|
||||
border: none !important; border-radius: 4px !important;
|
||||
padding: 8px 20px !important; font-weight: 600 !important; cursor: pointer;
|
||||
}
|
||||
.btn-laden:hover { background: #6d1e29 !important; }
|
||||
.alert-fehler {
|
||||
background: #FFEBEE; border-left: 5px solid #C62828;
|
||||
padding: 12px 16px; border-radius: 4px; color: #B71C1C;
|
||||
margin-bottom: 12px; font-weight: 500;
|
||||
}
|
||||
.alert-warnung {
|
||||
background: #FFF3E0; border-left: 5px solid #E65100;
|
||||
padding: 10px 16px; border-radius: 4px; color: #BF360C;
|
||||
margin-bottom: 12px; font-size: 0.93em; font-weight: 500;
|
||||
}
|
||||
.abschnitt-karte {
|
||||
background: white; border-radius: 6px; padding: 20px 24px;
|
||||
margin-bottom: 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
|
||||
}
|
||||
.abschnitt-titel {
|
||||
color: #8B2635; font-size: 1.15rem; font-weight: 700;
|
||||
border-bottom: 2px solid #8B2635; padding-bottom: 8px; margin-bottom: 14px;
|
||||
}
|
||||
.meta-block { margin-bottom: 10px; color: #555; font-size: 0.95em; }
|
||||
.meta-block strong { color: #222; }
|
||||
.normtabelle-info { margin-bottom: 14px; color: #444; font-size: 0.92em; }
|
||||
.disclaimer-block {
|
||||
font-size: 0.82em; color: #777; font-style: italic;
|
||||
margin-top: 10px; border-top: 1px solid rgba(0,0,0,.1); padding-top: 8px;
|
||||
}
|
||||
.item-zeile {
|
||||
display: flex; align-items: flex-start; gap: 10px;
|
||||
padding: 7px 0; border-bottom: 1px solid #F0F0F0;
|
||||
}
|
||||
.item-nr { font-weight: 600; color: #8B2635; min-width: 26px; flex-shrink: 0; }
|
||||
.item-text { flex: 1; color: #333; font-size: 0.92em; }
|
||||
table.pssi-tabelle { width: 100%; border-collapse: collapse; font-size: 0.92em; }
|
||||
table.pssi-tabelle th {
|
||||
text-align: left; border-bottom: 2px solid #8B2635; padding: 6px 8px; color: #8B2635;
|
||||
}
|
||||
table.pssi-tabelle td { padding: 6px 8px; border-bottom: 1px solid #eee; }
|
||||
table.pssi-tabelle td.zahl { text-align: right; }
|
||||
"
|
||||
|
||||
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("PSSI – Persoenlichkeits-Stil- und Stoerungs-Inventar"),
|
||||
tags$p("Einzelfall-Auswertung mit Normtabellen (Prozentrang, T-Wert)")
|
||||
),
|
||||
|
||||
div(class = "container-fluid",
|
||||
|
||||
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("fehler_ui"),
|
||||
uiOutput("warnung_normtabelle_ui"),
|
||||
uiOutput("warnung_mehrfach_ui"),
|
||||
uiOutput("normtabelle_auswahl_ui"),
|
||||
uiOutput("ergebnis_ui")
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
# Word-Export ####
|
||||
|
||||
erstelle_pssi_docx = function(erg, normtabelle_info) {
|
||||
doc = read_docx()
|
||||
|
||||
fp_titel = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18)
|
||||
fp_abschnitt = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 13)
|
||||
fp_label = fp_text(bold = TRUE, font.size = 11)
|
||||
fp_normal = fp_text(font.size = 11)
|
||||
fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext("PSSI - Einzelauswertung", fp_titel)))
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext("Chiffre: ", fp_label),
|
||||
ftext(erg$chiffre, fp_normal),
|
||||
ftext(" Ausfuelldatum: ", fp_label),
|
||||
ftext(erg$ausfuelldatum_anzeige, fp_normal)
|
||||
))
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext("Normtabelle: ", fp_label),
|
||||
ftext(normtabelle_info, fp_normal)
|
||||
))
|
||||
if (!is.null(erg$info_mehrere)) {
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(erg$info_mehrere, fp_text(font.size = 10, italic = TRUE, color = "#555555"))
|
||||
))
|
||||
}
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext("Skalenwerte", fp_abschnitt)))
|
||||
|
||||
for (i in seq_len(nrow(erg$profil))) {
|
||||
zeile = erg$profil[i, ]
|
||||
pr_txt = if (is.na(zeile$pr)) "k. A." else sprintf("%.1f", zeile$pr)
|
||||
t_txt = if (is.na(zeile$t)) "kein T-Wert ausgewiesen (Boden-/Deckeneffekt)" else sprintf("%.0f", zeile$t)
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(sprintf("%-4s ", zeile$skala), fp_text(bold = TRUE, font.size = 10, font.family = "Courier New")),
|
||||
ftext(sprintf("%-55s ", substr(zeile$skala_name, 1, 55)), fp_normal),
|
||||
ftext(sprintf("Rohwert: %2d PR: %-6s T: %s", zeile$rohwert, pr_txt, t_txt), fp_normal)
|
||||
))
|
||||
}
|
||||
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
doc = body_add_fpar(doc, fpar(ftext("Profildiagramm", fp_abschnitt)))
|
||||
|
||||
tmp_png = tempfile(fileext = ".png")
|
||||
ggplot2::ggsave(tmp_png, pssi_profil_plot(erg$profil), width = 8, height = 4, dpi = 150, bg = "white")
|
||||
doc = body_add_img(doc, src = tmp_png, width = 6.2, height = 3.1)
|
||||
if (file.exists(tmp_png)) unlink(tmp_png)
|
||||
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
doc = body_add_fpar(doc, fpar(ftext(PSSI_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)))
|
||||
}
|
||||
})
|
||||
|
||||
ergebnis_r = eventReactive(input$btn_suchen, {
|
||||
|
||||
chiffre = toupper(trimws(input$chiffre))
|
||||
|
||||
if ((nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0)) {
|
||||
return(list(error = "Bitte eine Patientenchiffre eingeben."))
|
||||
}
|
||||
if (!(nchar(trimws(input$pseudonym)) > 0 || grepl("^[A-Z][0-9]{6}$", chiffre))) {
|
||||
return(list(error = "Ungueltige Chiffre. Erwartet: ein Grossbuchstabe + 6 Ziffern (z.B. P000123)."))
|
||||
}
|
||||
|
||||
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
|
||||
return(list(error = paste0("Download-Skript nicht gefunden:\n", PFAD_DOWNLOAD_SKRIPT)))
|
||||
}
|
||||
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
|
||||
return(list(error = paste0("Pseudonym-Skript nicht gefunden:\n", PFAD_PSEUDONYM_SKRIPT)))
|
||||
}
|
||||
|
||||
ok_dl = tryCatch(
|
||||
{ source(PFAD_DOWNLOAD_SKRIPT, local = FALSE); list(ok = TRUE) },
|
||||
error = function(e) list(ok = FALSE, msg = e$message)
|
||||
)
|
||||
if (!ok_dl$ok) {
|
||||
return(list(error = paste0("Fehler im Download-Skript: ", ok_dl$msg)))
|
||||
}
|
||||
|
||||
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(error = paste0(
|
||||
"pseudonyme.db nicht gefunden (bis 5 Ebenen oberhalb von ",
|
||||
dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE)), " gesucht)."
|
||||
)))
|
||||
}
|
||||
|
||||
alter_wd = getwd()
|
||||
setwd(db_ordner)
|
||||
on.exit(setwd(alter_wd), add = TRUE)
|
||||
|
||||
ok_ps = tryCatch(
|
||||
{ source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
|
||||
if (nchar(trimws(input$pseudonym)) > 0) {
|
||||
.pw_wert = trimws(input$pseudonym)
|
||||
.pw_tab = get("pseudo", envir = .GlobalEnv)
|
||||
.pw_treffer = .pw_tab[.pw_tab$pseudonym == .pw_wert, ]
|
||||
if (nrow(.pw_treffer) > 0) chiffre = toupper(trimws(.pw_treffer$chiffre[1]))
|
||||
}; list(ok = TRUE) },
|
||||
error = function(e) list(ok = FALSE, msg = e$message)
|
||||
)
|
||||
if (!ok_ps$ok) {
|
||||
return(list(error = paste0("Fehler im Pseudonym-Skript: ", ok_ps$msg)))
|
||||
}
|
||||
|
||||
if (!exists("daten_pssi", envir = .GlobalEnv)) {
|
||||
return(list(error = "Objekt 'daten_pssi' nach dem Sourcen nicht gefunden. Bitte Download-Skript pruefen."))
|
||||
}
|
||||
if (!exists("pseudo", envir = .GlobalEnv)) {
|
||||
return(list(error = "Objekt 'pseudo' nach dem Sourcen nicht gefunden. Bitte Pseudonym-Skript pruefen."))
|
||||
}
|
||||
|
||||
daten_pssi = get("daten_pssi", envir = .GlobalEnv)
|
||||
pseudo = get("pseudo", envir = .GlobalEnv)
|
||||
|
||||
treffer_ps = pseudo[toupper(trimws(as.character(pseudo$chiffre))) == chiffre, ]
|
||||
if (nrow(treffer_ps) == 0) {
|
||||
return(list(error = paste0("Chiffre '", chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden.")))
|
||||
}
|
||||
|
||||
alle_session_ids = unique(as.character(treffer_ps$pseudonym))
|
||||
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
|
||||
treffer_dat = daten_pssi[as.character(daten_pssi$session) %in% alle_session_ids, , drop = FALSE]
|
||||
if (nrow(treffer_dat) == 0) {
|
||||
return(list(error = paste0(
|
||||
"Kein PSSI-Datensatz fuer Chiffre '", chiffre, "' gefunden. (",
|
||||
length(alle_session_ids), " Pseudonym(e) geprueft)"
|
||||
)))
|
||||
}
|
||||
|
||||
info_mehrere = NULL
|
||||
if (nrow(treffer_dat) > 1) {
|
||||
n = nrow(treffer_dat)
|
||||
idx_neu = which.max(as.POSIXct(treffer_dat$created))
|
||||
datum_neu = tryCatch(
|
||||
format(as.POSIXct(treffer_dat$created[idx_neu]), "%d.%m.%Y %H:%M"),
|
||||
error = function(e) "unbekanntes Datum"
|
||||
)
|
||||
info_mehrere = paste0(
|
||||
"Mehrere Ausfuellungen gefunden (", n, " Eintraege). Angezeigt wird die neueste vom ", datum_neu, "."
|
||||
)
|
||||
treffer_dat = treffer_dat[idx_neu, , drop = FALSE]
|
||||
}
|
||||
|
||||
zeile = treffer_dat[1, , drop = FALSE]
|
||||
|
||||
ausfuelldatum_raw = zeile[["created"]][1]
|
||||
ausfuelldatum_anzeige = tryCatch(
|
||||
format(as.POSIXct(ausfuelldatum_raw), "%d.%m.%Y"),
|
||||
error = function(e) "unbekannt"
|
||||
)
|
||||
|
||||
alter_roh = zeile[["pssi_alter"]][1]
|
||||
alter_num = suppressWarnings(as.numeric(trimws(as.character(alter_roh))))
|
||||
alter_gueltig = !is.na(alter_num) && alter_num >= 10 && alter_num <= 110
|
||||
if (!alter_gueltig) alter_num = NA_real_
|
||||
|
||||
geschlecht_roh = zeile[["pssi_geschlecht"]][1]
|
||||
geschlecht_txt = tryCatch({
|
||||
spalte_orig = daten_pssi[["pssi_geschlecht"]]
|
||||
if (haven::is.labelled(spalte_orig)) {
|
||||
lbl_attr = attr(spalte_orig, "labels")
|
||||
pos = which(as.vector(lbl_attr) == as.numeric(geschlecht_roh))
|
||||
if (length(pos) > 0) trimws(names(lbl_attr)[pos[1]]) else NA_character_
|
||||
} else {
|
||||
trimws(as.character(geschlecht_roh))
|
||||
}
|
||||
}, error = function(e) NA_character_)
|
||||
|
||||
geschlecht = if (!is.na(geschlecht_txt) && grepl("^weiblich$", geschlecht_txt, ignore.case = TRUE)) {
|
||||
"weiblich"
|
||||
} else if (!is.na(geschlecht_txt) && grepl("^m(a|ä)nnlich$", geschlecht_txt, ignore.case = TRUE)) {
|
||||
"maennlich"
|
||||
} else {
|
||||
NA_character_
|
||||
}
|
||||
|
||||
stufen = sapply(1:140, function(i) {
|
||||
var = sprintf("pssi_%03d", i)
|
||||
if (!(var %in% names(daten_pssi))) {
|
||||
stop(paste0("Item-Spalte '", var, "' fehlt in daten_pssi."))
|
||||
}
|
||||
stufe_aus_item(zeile[[var]], var)
|
||||
})
|
||||
|
||||
rohwerte = sapply(pssi_skala_anzeige_reihenfolge, function(sk) {
|
||||
idx = pssi_item_map$item[pssi_item_map$skala == sk]
|
||||
umgepolt = pssi_item_map$umgepolt[pssi_item_map$skala == sk]
|
||||
werte = stufen[idx]
|
||||
werte_final = ifelse(umgepolt, 3 - werte, werte)
|
||||
sum(werte_final)
|
||||
})
|
||||
names(rohwerte) = pssi_skala_anzeige_reihenfolge
|
||||
|
||||
normtabelle_vorschlag = pssi_vorschlag_normtabelle(alter_num, geschlecht)
|
||||
kein_vorschlag = is.null(normtabelle_vorschlag)
|
||||
|
||||
list(
|
||||
chiffre = chiffre,
|
||||
ausfuelldatum_anzeige = ausfuelldatum_anzeige,
|
||||
info_mehrere = info_mehrere,
|
||||
alter_num = alter_num,
|
||||
geschlecht = geschlecht,
|
||||
rohwerte = rohwerte,
|
||||
normtabelle_vorschlag = normtabelle_vorschlag,
|
||||
kein_vorschlag = kein_vorschlag,
|
||||
error = NULL
|
||||
)
|
||||
})
|
||||
|
||||
output$fehler_ui = renderUI({
|
||||
req(input$btn_suchen)
|
||||
d = ergebnis_r()
|
||||
if (!is.null(d$error)) div(class = "alert-fehler", d$error)
|
||||
})
|
||||
|
||||
output$warnung_mehrfach_ui = renderUI({
|
||||
req(input$btn_suchen)
|
||||
d = ergebnis_r()
|
||||
if (!is.null(d$error) || is.null(d$info_mehrere)) return(NULL)
|
||||
div(class = "alert-warnung", d$info_mehrere)
|
||||
})
|
||||
|
||||
output$warnung_normtabelle_ui = renderUI({
|
||||
req(input$btn_suchen)
|
||||
d = ergebnis_r()
|
||||
if (!is.null(d$error) || !isTRUE(d$kein_vorschlag)) return(NULL)
|
||||
div(class = "alert-warnung",
|
||||
"Kein automatischer Normtabellen-Vorschlag moeglich (Alter und/oder Geschlecht ",
|
||||
"nicht eindeutig auswertbar). Bitte Normtabelle manuell pruefen und auswaehlen."
|
||||
)
|
||||
})
|
||||
|
||||
output$normtabelle_auswahl_ui = renderUI({
|
||||
req(input$btn_suchen)
|
||||
d = ergebnis_r()
|
||||
if (!is.null(d$error)) return(NULL)
|
||||
|
||||
default_key = if (isTRUE(d$kein_vorschlag)) "B1" else d$normtabelle_vorschlag
|
||||
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Normtabelle"),
|
||||
selectInput("normtabelle_wahl", label = "Verwendete Normtabelle",
|
||||
choices = setNames(pssi_normtabellen_meta$key, pssi_normtabellen_meta$label),
|
||||
selected = default_key, width = "100%"),
|
||||
uiOutput("normtabelle_info_ui")
|
||||
)
|
||||
})
|
||||
|
||||
output$normtabelle_info_ui = renderUI({
|
||||
req(input$normtabelle_wahl)
|
||||
meta = pssi_normtabellen_meta[pssi_normtabellen_meta$key == input$normtabelle_wahl, ]
|
||||
if (nrow(meta) == 0) return(NULL)
|
||||
div(class = "normtabelle-info",
|
||||
tags$strong("Aktuell verwendet: "), meta$label[1]
|
||||
)
|
||||
})
|
||||
|
||||
profil_r = reactive({
|
||||
req(input$btn_suchen, input$normtabelle_wahl)
|
||||
d = ergebnis_r()
|
||||
if (!is.null(d$error)) return(NULL)
|
||||
|
||||
tab = pssi_normtabellen[[input$normtabelle_wahl]]
|
||||
zeilen = lapply(pssi_skala_anzeige_reihenfolge, function(sk) {
|
||||
rw = d$rohwerte[[sk]]
|
||||
lk = pssi_pr_t_lookup(tab, sk, rw)
|
||||
data.frame(
|
||||
skala = sk,
|
||||
skala_name = unname(pssi_skalennamen[sk]),
|
||||
rohwert = rw,
|
||||
pr = lk$pr,
|
||||
t = lk$t,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
})
|
||||
df = do.call(rbind, zeilen)
|
||||
df$skala = factor(df$skala, levels = pssi_skala_anzeige_reihenfolge)
|
||||
df
|
||||
})
|
||||
|
||||
output$ergebnis_ui = renderUI({
|
||||
req(input$btn_suchen)
|
||||
d = ergebnis_r()
|
||||
if (!is.null(d$error)) return(NULL)
|
||||
profil = profil_r()
|
||||
if (is.null(profil)) return(NULL)
|
||||
|
||||
tabellen_zeilen = lapply(seq_len(nrow(profil)), function(i) {
|
||||
z = profil[i, ]
|
||||
t_anzeige = if (is.na(z$t)) {
|
||||
tags$span(style = "color:#999; font-style:italic;",
|
||||
"kein T-Wert ausgewiesen (Boden-/Deckeneffekt)")
|
||||
} else {
|
||||
sprintf("%.0f", z$t)
|
||||
}
|
||||
pr_anzeige = if (is.na(z$pr)) "k. A." else sprintf("%.1f", z$pr)
|
||||
tags$tr(
|
||||
tags$td(paste0(z$skala, " – ", z$skala_name)),
|
||||
tags$td(class = "zahl", z$rohwert),
|
||||
tags$td(class = "zahl", pr_anzeige),
|
||||
tags$td(class = "zahl", t_anzeige)
|
||||
)
|
||||
})
|
||||
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "PSSI-Auswertung"),
|
||||
|
||||
div(class = "meta-block",
|
||||
tags$strong("Chiffre: "), d$chiffre,
|
||||
tags$span(" | ", style = "color:#ccc;"),
|
||||
tags$strong("Ausfuelldatum: "), d$ausfuelldatum_anzeige,
|
||||
tags$span(" | ", style = "color:#ccc;"),
|
||||
tags$strong("Alter: "), if (is.na(d$alter_num)) "nicht auswertbar" else d$alter_num,
|
||||
tags$span(" | ", style = "color:#ccc;"),
|
||||
tags$strong("Geschlecht: "), if (is.na(d$geschlecht)) "nicht zuordenbar" else d$geschlecht
|
||||
),
|
||||
|
||||
tags$hr(),
|
||||
|
||||
tags$h5("Skalenwerte"),
|
||||
tags$table(class = "pssi-tabelle",
|
||||
tags$thead(
|
||||
tags$tr(
|
||||
tags$th("Skala"), tags$th("Rohwert (0-30)"),
|
||||
tags$th("Prozentrang"), tags$th("T-Wert")
|
||||
)
|
||||
),
|
||||
tags$tbody(tabellen_zeilen)
|
||||
),
|
||||
|
||||
tags$hr(),
|
||||
|
||||
tags$h5("Profildiagramm"),
|
||||
plotOutput("profil_plot", height = "380px"),
|
||||
|
||||
div(class = "disclaimer-block", PSSI_DISCLAIMER)
|
||||
)
|
||||
})
|
||||
|
||||
output$profil_plot = renderPlot({
|
||||
profil = profil_r()
|
||||
req(profil)
|
||||
pssi_profil_plot(profil)
|
||||
})
|
||||
|
||||
output$download_word = downloadHandler(
|
||||
filename = function() {
|
||||
d = tryCatch(ergebnis_r(), error = function(e) NULL)
|
||||
chiffre_esc = if (is.list(d) && is.null(d$error) && nchar(d$chiffre) > 0) {
|
||||
gsub("[^A-Za-z0-9_-]", "_", d$chiffre)
|
||||
} else {
|
||||
"export"
|
||||
}
|
||||
ausfuelldatum_fn = tryCatch(
|
||||
format(as.Date(d$ausfuelldatum_anzeige, "%d.%m.%Y"), "%Y%m%d"),
|
||||
error = function(e) format(Sys.Date(), "%Y%m%d")
|
||||
)
|
||||
if (is.na(ausfuelldatum_fn) || length(ausfuelldatum_fn) == 0) {
|
||||
ausfuelldatum_fn = format(Sys.Date(), "%Y%m%d")
|
||||
}
|
||||
paste0("PSSI_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
|
||||
},
|
||||
content = function(file) {
|
||||
d = tryCatch(ergebnis_r(), error = function(e) NULL)
|
||||
daten_ok = is.list(d) && is.null(d$error)
|
||||
if (!daten_ok) {
|
||||
doc = read_docx()
|
||||
doc = body_add_par(doc,
|
||||
"Kein Datensatz geladen. Bitte zuerst Chiffre eingeben und 'Auswerten' klicken.",
|
||||
style = "Normal")
|
||||
print(doc, target = file)
|
||||
return()
|
||||
}
|
||||
profil = profil_r()
|
||||
meta = pssi_normtabellen_meta[pssi_normtabellen_meta$key == input$normtabelle_wahl, ]
|
||||
normtabelle_info = if (nrow(meta) > 0) meta$label[1] else input$normtabelle_wahl
|
||||
|
||||
erg = list(
|
||||
chiffre = d$chiffre,
|
||||
ausfuelldatum_anzeige = d$ausfuelldatum_anzeige,
|
||||
info_mehrere = d$info_mehrere,
|
||||
profil = profil
|
||||
)
|
||||
|
||||
doc = tryCatch(
|
||||
erstelle_pssi_docx(erg, normtabelle_info),
|
||||
error = function(e) {
|
||||
err_doc = read_docx()
|
||||
body_add_par(err_doc,
|
||||
paste0("Fehler beim Erstellen des Word-Dokuments: ", e$message),
|
||||
style = "Normal")
|
||||
}
|
||||
)
|
||||
print(doc, target = file)
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
# Start ####
|
||||
|
||||
shinyApp(ui, server)
|
||||
Loading…
Add table
Add a link
Reference in a new issue