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

Initial commit

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

BIN
PBQ/.RData Normal file
View file

Binary file not shown.

1
PBQ/.Rprofile Normal file
View file

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

13
PBQ/PBQ.Rproj Normal file
View file

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

793
PBQ/app.R Normal file
View file

@ -0,0 +1,793 @@
# Präambel ####
AKZENT_FARBE = "#8B2635"
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_pbq.R"
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
PBQ_DISCLAIMER = paste0(
"Der PBQ liefert keinen Cutoff-Wert und keine Diagnose. Die dargestellten Z-Werte ",
"zeigen lediglich, wie nahe die Person den Vergleichswerten von Patientinnen und ",
"Patienten mit bzw. ohne die jeweils entsprechende Persoenlichkeitsstoerungsdiagnose ",
"kommt. Es handelt sich um eine Tendenzaussage im Gruppenvergleich, kein klinisches Urteil. ",
"Die Interpretation obliegt der behandelnden Person."
)
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)
# Helper ####
pbq_antwortkategorien = c("gar nicht", "ein wenig", "mäßig", "sehr", "völlig")
pbq_normalisiere_text = function(x) {
x = tolower(trimws(as.character(x)))
x = gsub("ä", "ae", x, fixed = TRUE)
x = gsub("ö", "oe", x, fixed = TRUE)
x = gsub("ü", "ue", x, fixed = TRUE)
x = gsub("ß", "ss", x, fixed = TRUE)
x
}
pbq_erwartete_kategorien_norm = pbq_normalisiere_text(pbq_antwortkategorien)
# Prueft fuer alle 121 Item-Spalten, ob das labels-Attribut genau die 5
# erwarteten Antwortkategorien in aufsteigender Reihenfolge 1-5 enthaelt.
# Erst NACH bestandener Pruefung darf Rohwert_Item = Choice-Index - 1
# ueber den blanken numerischen Wert gebildet werden.
pbq_pruefe_item_labels = function(daten) {
for (i in 1:121) {
var = sprintf("pbq_%03d", i)
if (!(var %in% names(daten))) {
return(paste0("Item-Spalte '", var, "' fehlt in daten_pbq."))
}
spalte = daten[[var]]
fehlermeldung = paste0(
"Unerwartetes Antwortformat bei Item ", var, " – Auswertung abgebrochen."
)
if (!haven::is.labelled(spalte)) return(fehlermeldung)
lbl = attr(spalte, "labels")
if (is.null(lbl) || length(lbl) != 5) return(fehlermeldung)
ord = order(as.vector(lbl))
werte_sortiert = as.numeric(as.vector(lbl))[ord]
if (!identical(werte_sortiert, as.numeric(1:5))) return(fehlermeldung)
namen_sortiert = pbq_normalisiere_text(names(lbl))[ord]
if (!identical(namen_sortiert, pbq_erwartete_kategorien_norm)) return(fehlermeldung)
}
NULL
}
# Nur nach bestandener pbq_pruefe_item_labels() aufrufen.
pbq_rohwert_item = function(spalte) {
wert = suppressWarnings(as.numeric(spalte))[1]
if (is.na(wert)) return(NA_real_)
wert - 1
}
# Itemtext aus dem label-Attribut, formr-Markdown-Escape "\." -> "." bereinigt.
# Die fuehrende Itemnummer wird entfernt, da sie separat (item-nr) angezeigt wird.
pbq_item_text = function(daten, i) {
var = sprintf("pbq_%03d", i)
lbl = attr(daten[[var]], "label")
if (is.null(lbl) || length(lbl) == 0 || is.na(lbl[1])) return(paste0("Item ", i))
txt = gsub("\\\\\\.", ".", as.character(lbl)[1])
txt = sub("^[0-9]+\\.\\s*", "", txt)
trimws(txt)
}
# Farbverlauf gruen -> dunkelrot fuer die 5 Antwortstufen 0-4.
PBQ_BADGE_FARBEN = c(
"0" = "#4CAF50",
"1" = "#9CCC65",
"2" = "#FFB300",
"3" = "#FB8C00",
"4" = "#C62828"
)
PBQ_BADGE_TEXT_FARBEN = c(
"0" = "white",
"1" = "#333333",
"2" = "#333333",
"3" = "white",
"4" = "white"
)
pbq_profil_plot = function(profil_df) {
df = profil_df
df$z_plot = ifelse(df$fehlend, NA, df$z)
y_werte = c(df$z_plot, df$z_mit_ps, df$z_ohne_ps, 0)
y_min = min(y_werte, na.rm = TRUE) - 0.6
y_max = max(y_werte, na.rm = TRUE) + 0.6
df_ohne = df[!is.na(df$z_ohne_ps), , drop = FALSE]
df_mit = df[!is.na(df$z_mit_ps), , drop = FALSE]
df_person = df[!df$fehlend, , drop = FALSE]
df_fehlend = df[df$fehlend, , drop = FALSE]
# Skalen ohne "mit PS"-Vergleichsdaten werden am Achsenticket markiert (*),
# nicht per Text-Annotation im Plot - bei benachbarten Skalen (z.B.
# Histrionisch/Schizoid) wuerden sich Annotationen sonst ueberlappen.
x_labels = setNames(
ifelse(is.na(df$z_mit_ps), paste0(as.character(df$skala), " *"), as.character(df$skala)),
as.character(df$skala)
)
hat_keine_vgl = any(is.na(df$z_mit_ps))
ggplot(df, aes(x = skala)) +
geom_hline(yintercept = 0, color = "#AAAAAA", linetype = "dashed", linewidth = 0.5) +
geom_line(data = df_ohne, aes(y = z_ohne_ps, group = 1, color = "Referenz: ohne PS-Diagnose"),
linewidth = 0.7, na.rm = TRUE) +
geom_point(data = df_ohne,
aes(y = z_ohne_ps, color = "Referenz: ohne PS-Diagnose", shape = "Referenz: ohne PS-Diagnose"),
size = 2.6) +
geom_line(data = df_mit, aes(y = z_mit_ps, group = 1, color = "Referenz: mit PS-Diagnose"),
linewidth = 0.7, linetype = "dotted", na.rm = TRUE) +
geom_point(data = df_mit,
aes(y = z_mit_ps, color = "Referenz: mit PS-Diagnose", shape = "Referenz: mit PS-Diagnose"),
size = 2.6) +
geom_line(data = df_person, aes(y = z_plot, group = 1, color = "Person"),
linewidth = 1.1, na.rm = TRUE) +
geom_point(data = df_person, aes(y = z_plot, color = "Person", shape = "Person"),
size = 3.2) +
{ if (nrow(df_fehlend) > 0)
geom_point(data = df_fehlend, aes(y = 0), shape = 21, size = 3.4,
color = AKZENT_FARBE, fill = "white", stroke = 1.2)
else NULL } +
scale_x_discrete(labels = x_labels) +
scale_color_manual(name = NULL, values = c(
"Person" = AKZENT_FARBE,
"Referenz: mit PS-Diagnose" = "#757575",
"Referenz: ohne PS-Diagnose" = "#1565C0"
)) +
scale_shape_manual(name = NULL, values = c(
"Person" = 16,
"Referenz: mit PS-Diagnose" = 15,
"Referenz: ohne PS-Diagnose" = 17
)) +
scale_y_continuous(limits = c(y_min, y_max)) +
labs(x = NULL, y = "Z-Wert",
caption = paste0(
"Z-Wert = (Rohwert - M) / SD der jeweiligen Referenzstichprobe (Beck et al. 2001).\n",
"Offener Kreis = Skala nicht auswertbar (fehlende Angaben).",
if (hat_keine_vgl) " * keine Vergleichsdaten 'mit PS' verfuegbar fuer diese Skala.\n" else "\n",
"Kein Cutoff, keine Diagnose - reiner Gruppenvergleich."
)) +
theme_minimal(base_size = 12) +
theme(
panel.grid.minor = element_blank(),
axis.text.x = element_text(angle = 30, hjust = 1, color = "#333333"),
axis.text.y = element_text(color = "#333333"),
axis.title.y = element_text(color = "#333333"),
legend.position = "bottom",
legend.text = element_text(color = "#333333"),
plot.caption = element_text(size = 8.5, color = "#5C5C5C", hjust = 0)
)
}
# Datenaufbereitung ####
# Statische Normtabelle aus auswertung_normen_pbq.md (Beck et al. 2001),
# wortwoertlich uebernommen - nicht runden, aendern oder ergaenzen.
pbq_skalen_tabelle = data.frame(
skala = c("Vermeidend", "Abhängig", "Passiv-aggressiv", "Zwanghaft", "Antisozial",
"Narzißtisch", "Histrionisch", "Schizoid", "Paranoid"),
von = c(1, 15, 29, 43, 57, 71, 85, 99, 113),
bis = c(14, 28, 42, 56, 70, 84, 98, 112, 121),
m = c(18.8, 18.0, 19.3, 22.7, 9.3, 10.0, 14.0, 16.3, 14.6),
sd = c(10.9, 11.8, 10.5, 11.5, 6.8, 7.6, 9.3, 8.6, 11.3),
z_mit_ps = c(0.62, 0.83, NA, 0.31, 0.31, 1.10, NA, NA, 0.51),
z_ohne_ps = c(-0.69, -0.49, -0.38, -0.51, -0.18, -0.38, -0.29, -0.14, -0.55),
stringsAsFactors = FALSE
)
{
n_items_je_skala = pbq_skalen_tabelle$bis - pbq_skalen_tabelle$von + 1
if (sum(n_items_je_skala) != 121) {
stop("Datenintegritaetsfehler: Summe der Itemanzahlen der PBQ-Skalen ergibt nicht 121.")
}
reihenfolge = order(pbq_skalen_tabelle$von)
von_sortiert = pbq_skalen_tabelle$von[reihenfolge]
bis_sortiert = pbq_skalen_tabelle$bis[reihenfolge]
if (von_sortiert[1] != 1 || bis_sortiert[length(bis_sortiert)] != 121) {
stop("Datenintegritaetsfehler: PBQ-Skalen decken nicht durchgehend die Items 1-121 ab.")
}
if (length(von_sortiert) > 1) {
for (i in 2:length(von_sortiert)) {
if (von_sortiert[i] != bis_sortiert[i - 1] + 1) {
stop("Datenintegritaetsfehler: Luecke oder Ueberschneidung zwischen PBQ-Skalen entdeckt.")
}
}
}
}
pbq_skala_reihenfolge = pbq_skalen_tabelle$skala
pbq_item_map = data.frame(item = 1:121, skala = NA_character_, stringsAsFactors = FALSE)
for (i in seq_len(nrow(pbq_skalen_tabelle))) {
rng = pbq_skalen_tabelle$von[i]:pbq_skalen_tabelle$bis[i]
pbq_item_map$skala[pbq_item_map$item %in% rng] = pbq_skalen_tabelle$skala[i]
}
if (anyNA(pbq_item_map$skala)) {
stop("Datenintegritaetsfehler: nicht alle 121 PBQ-Items sind genau einer Skala zugeordnet.")
}
# 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; }
.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: 34px; flex-shrink: 0; }
.item-text { flex: 1; color: #333; font-size: 0.92em; }
.stufe-badge {
border-radius: 4px; padding: 2px 9px; 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: #9CCC65; color: #333333; }
.stufe-badge-2 { background: #FFB300; color: #333333; }
.stufe-badge-3 { background: #FB8C00; color: white; }
.stufe-badge-4 { background: #C62828; color: white; }
.item-gruppe-titel {
color: #8B2635; font-weight: 700; font-size: 0.98em;
margin: 18px 0 6px; border-bottom: 1px solid #eee; padding-bottom: 4px;
}
.item-gruppe-titel:first-child { margin-top: 4px; }
table.tabelle { width: 100%; border-collapse: collapse; font-size: 0.92em; }
table.tabelle th {
text-align: left; border-bottom: 2px solid #8B2635; padding: 6px 8px; color: #8B2635;
}
table.tabelle td { padding: 6px 8px; border-bottom: 1px solid #eee; }
table.tabelle td.zahl { text-align: right; }
.hinweis-text { color: #999; font-style: italic; }
details.einzelitems summary {
cursor: pointer; font-weight: 600; color: #8B2635; padding: 6px 0;
}
"
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("PBQ – Fragebogen persönlicher Überzeugungen"),
tags$p("Beck & Beck 1991 | Normdaten Beck et al. 2001 | 121 Items, 9 Subskalen")
),
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_ui"),
uiOutput("ergebnis_ui")
)
)
# Word-Export ####
erstelle_pbq_docx = function(erg) {
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("PBQ - Einzelauswertung", fp_titel)))
doc = body_add_fpar(doc, fpar(
ftext("Chiffre: ", fp_label),
ftext(erg$chiffre, fp_normal),
ftext(" Ausfülldatum: ", fp_label),
ftext(erg$ausfuelldatum_anzeige, 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))) {
z = erg$profil[i, ]
if (isTRUE(z$fehlend)) {
rw_txt = "nicht auswertbar (fehlende Angaben)"
z_txt = "nicht auswertbar (fehlende Angaben)"
} else {
rw_txt = sprintf("%d", z$rohwert)
z_txt = sprintf("%.2f", z$z)
}
mit_txt = if (is.na(z$z_mit_ps)) "keine Vergleichsdaten" else sprintf("%.2f", z$z_mit_ps)
ohne_txt = sprintf("%.2f", z$z_ohne_ps)
doc = body_add_fpar(doc, fpar(
ftext(sprintf("%-18s ", z$skala), fp_text(bold = TRUE, font.size = 10, font.family = "Courier New")),
ftext(sprintf("Rohwert: %-8s Z: %-8s Z (mit PS): %-8s Z (ohne PS): %s",
rw_txt, z_txt, mit_txt, ohne_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, pbq_profil_plot(erg$profil), width = 8.5, height = 4.6, dpi = 150, bg = "white")
doc = body_add_img(doc, src = tmp_png, width = 6.4, height = 3.46)
if (file.exists(tmp_png)) unlink(tmp_png)
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Einzelitems", fp_abschnitt)))
fp_gruppe = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 11)
# Gleiche Gruppierung/Sortierung wie in der UI: nach Skala, absteigend nach Auspraegung.
for (sk in pbq_skala_reihenfolge) {
doc = body_add_fpar(doc, fpar(ftext(sk, fp_gruppe)))
idx = pbq_item_map$item[pbq_item_map$skala == sk]
stufen_sk = erg$stufen[idx]
reihenfolge = order(-stufen_sk, na.last = TRUE)
idx_sortiert = idx[reihenfolge]
for (i in idx_sortiert) {
stufe = erg$stufen[i]
item_txt = erg$item_texte[i]
if (is.na(stufe)) {
fp_badge = fp_text(color = "#999999", italic = TRUE, font.size = 10)
badge_txt = " keine Angabe "
} else {
stufe_key = as.character(stufe)
fp_badge = fp_text(
color = PBQ_BADGE_TEXT_FARBEN[[stufe_key]],
bold = TRUE,
shading.color = PBQ_BADGE_FARBEN[[stufe_key]],
font.size = 10
)
badge_txt = paste0(" ", pbq_antwortkategorien[stufe + 1L], " ")
}
doc = body_add_fpar(doc, fpar(
ftext(paste0(i, ". ", item_txt, " "), fp_normal),
ftext(badge_txt, fp_badge)
))
}
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(PBQ_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))
}
})
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 = "Ungültige Chiffre. Erwartet: ein Großbuchstabe + 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_pbq", envir = .GlobalEnv)) {
return(list(error = "Objekt 'daten_pbq' nach dem Sourcen nicht gefunden. Bitte Download-Skript prüfen."))
}
if (!exists("pseudo", envir = .GlobalEnv)) {
return(list(error = "Objekt 'pseudo' nach dem Sourcen nicht gefunden. Bitte Pseudonym-Skript prüfen."))
}
daten_pbq = get("daten_pbq", 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_pbq[as.character(daten_pbq$session) %in% alle_session_ids, , drop = FALSE]
if (nrow(treffer_dat) == 0) {
return(list(error = paste0(
"Kein PBQ-Datensatz für Chiffre '", chiffre, "' gefunden. (",
length(alle_session_ids), " Pseudonym(e) geprüft)"
)))
}
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 Ausfüllungen gefunden (", n, " Einträge). 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"
)
label_fehler = pbq_pruefe_item_labels(daten_pbq)
if (!is.null(label_fehler)) {
return(list(error = label_fehler))
}
stufen = sapply(1:121, function(i) {
var = sprintf("pbq_%03d", i)
pbq_rohwert_item(zeile[[var]])
})
item_texte = sapply(1:121, function(i) pbq_item_text(daten_pbq, i))
profil_zeilen = lapply(seq_len(nrow(pbq_skalen_tabelle)), function(i) {
sk = pbq_skalen_tabelle$skala[i]
idx = pbq_item_map$item[pbq_item_map$skala == sk]
werte = stufen[idx]
fehlend = anyNA(werte)
rohwert = if (fehlend) NA_real_ else sum(werte)
z_wert = if (fehlend) NA_real_ else (rohwert - pbq_skalen_tabelle$m[i]) / pbq_skalen_tabelle$sd[i]
data.frame(
skala = sk,
rohwert = rohwert,
z = z_wert,
z_mit_ps = pbq_skalen_tabelle$z_mit_ps[i],
z_ohne_ps = pbq_skalen_tabelle$z_ohne_ps[i],
fehlend = fehlend,
stringsAsFactors = FALSE
)
})
profil = do.call(rbind, profil_zeilen)
profil$skala = factor(profil$skala, levels = pbq_skala_reihenfolge)
list(
chiffre = chiffre,
ausfuelldatum_anzeige = ausfuelldatum_anzeige,
info_mehrere = info_mehrere,
profil = profil,
stufen = stufen,
item_texte = item_texte,
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_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$ergebnis_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (!is.null(d$error)) return(NULL)
profil = d$profil
tabellen_zeilen = lapply(seq_len(nrow(profil)), function(i) {
z = profil[i, ]
if (isTRUE(z$fehlend)) {
rw_anzeige = tags$span(class = "hinweis-text", "nicht auswertbar (fehlende Angaben)")
z_anzeige = tags$span(class = "hinweis-text", "nicht auswertbar (fehlende Angaben)")
} else {
rw_anzeige = sprintf("%d", z$rohwert)
z_anzeige = sprintf("%.2f", z$z)
}
mit_anzeige = if (is.na(z$z_mit_ps)) {
tags$span(class = "hinweis-text", "keine Vergleichsdaten")
} else {
sprintf("%.2f", z$z_mit_ps)
}
ohne_anzeige = sprintf("%.2f", z$z_ohne_ps)
tags$tr(
tags$td(as.character(z$skala)),
tags$td(class = "zahl", rw_anzeige),
tags$td(class = "zahl", z_anzeige),
tags$td(class = "zahl", mit_anzeige),
tags$td(class = "zahl", ohne_anzeige)
)
})
# Einzelitems nach Skala gruppiert, innerhalb jeder Skala nach Auspraegung
# absteigend sortiert (staerkste Zustimmung zuerst; fehlende Angaben zuletzt).
items_ui = lapply(pbq_skala_reihenfolge, function(sk) {
idx = pbq_item_map$item[pbq_item_map$skala == sk]
stufen_sk = d$stufen[idx]
reihenfolge = order(-stufen_sk, na.last = TRUE)
idx_sortiert = idx[reihenfolge]
zeilen = lapply(idx_sortiert, function(i) {
stufe = d$stufen[i]
badge = if (is.na(stufe)) {
tags$span(class = "hinweis-text", "keine Angabe")
} else {
tags$span(class = paste0("stufe-badge stufe-badge-", as.character(stufe)),
pbq_antwortkategorien[stufe + 1L])
}
div(class = "item-zeile",
div(class = "item-nr", paste0(i, ".")),
div(class = "item-text", d$item_texte[i]),
badge
)
})
tagList(
div(class = "item-gruppe-titel", sk),
zeilen
)
})
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "PBQ-Auswertung"),
div(class = "meta-block",
tags$strong("Chiffre: "), d$chiffre,
tags$span(" | ", style = "color:#ccc;"),
tags$strong("Ausfülldatum: "), d$ausfuelldatum_anzeige
),
tags$hr(),
tags$h5("Skalenwerte"),
tags$table(class = "tabelle",
tags$thead(
tags$tr(
tags$th("Skala"), tags$th("Rohwert"), tags$th("Z-Wert (Person)"),
tags$th("Referenz Z 'mit PS'"), tags$th("Referenz Z 'ohne PS'")
)
),
tags$tbody(tabellen_zeilen)
),
tags$hr(),
tags$h5("Profildiagramm"),
plotOutput("profil_plot", height = "420px"),
tags$hr(),
tags$details(class = "einzelitems",
tags$summary("Einzelitems anzeigen"),
div(items_ui)
),
div(class = "disclaimer-block", PBQ_DISCLAIMER)
)
})
output$profil_plot = renderPlot({
d = ergebnis_r()
req(is.null(d$error))
pbq_profil_plot(d$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("PBQ_", 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()
}
erg = list(
chiffre = d$chiffre,
ausfuelldatum_anzeige = d$ausfuelldatum_anzeige,
info_mehrere = d$info_mehrere,
profil = d$profil,
stufen = d$stufen,
item_texte = d$item_texte
)
doc = tryCatch(
erstelle_pbq_docx(erg),
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)

3019
PBQ/renv.lock Normal file
View file

File diff suppressed because it is too large Load diff

16
PBQ/setup_renv.R Normal file
View file

@ -0,0 +1,16 @@
# 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. formr ist nicht Teil der App und
# wird nur vom (externen) Download-Skript benoetigt:
# remotes::install_github("rubenarslan/formr")
renv::init()
pkgs = c("shiny", "dplyr", "ggplot2", "haven", "officer", "DBI", "RSQLite", "formr")
install.packages(pkgs)
renv::snapshot()
message("Setup abgeschlossen. App starten mit: shiny::runApp()")