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
PSI-Q/.RData Normal file
View file

Binary file not shown.

1
PSI-Q/.Rprofile Normal file
View file

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

13
PSI-Q/PSI-Q.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

707
PSI-Q/app.R Normal file
View file

@ -0,0 +1,707 @@
# Präambel ####
library(shiny)
library(dplyr)
library(ggplot2)
library(haven)
library(officer)
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_psiq.R"
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
AKZENT_FARBE = "#8B2635"
# Deskriptive Kennwerte (M, SD) der Validierungsstichprobe (N=300) aus dem
# elektronischen Supplement zur deutschen Adaptationsstudie (Jungmann, Becker
# & Witthoeft). KEINE klinische Norm, KEIN Cutoff - siehe PSIQ_DISCLAIMER.
PSIQ_SUBSKALEN = data.frame(
key = c("visuell", "auditiv", "olfaktorisch", "gustatorisch",
"tasten", "kinaesthetisch", "emotional"),
label = c("Visuell", "Auditiv", "Olfaktorisch", "Gustatorisch",
"Tasten", "Kinästhetisch", "Emotional"),
item_start = c(1, 4, 7, 10, 13, 16, 19),
item_ende = c(3, 6, 9, 12, 15, 18, 21),
ref_m = c(7.82, 7.53, 6.19, 6.69, 7.91, 7.25, 7.15),
ref_sd = c(1.55, 1.73, 2.16, 2.08, 1.68, 1.66, 1.76),
stringsAsFactors = FALSE
)
PSIQ_VERGLEICHSHINWEIS = "Vergleichswert aus Validierungsstichprobe (N=300), keine klinische Norm"
# Vollstaendige Item-Aussagen aus der formr-Survey-Definition (psiq.xlsx):
# jede Domaenen-Einleitung (psiq_domain_intro_xx, z.B. "Stellen Sie sich das
# Aussehen/Erscheinung ...") ist hier bereits mit der Item-Ergaenzung
# (z.B. "... eines Lagerfeuers vor.") zu einer vollstaendigen Aussage
# zusammengefuegt, in Item-Reihenfolge psiq_01 bis psiq_21.
PSIQ_ITEM_TEXTE = c(
"Stellen Sie sich das Aussehen/Erscheinung eines Lagerfeuers vor.",
"Stellen Sie sich das Aussehen/Erscheinung eines Sonnenuntergangs vor.",
"Stellen Sie sich das Aussehen/Erscheinung einer Katze vor, die einen Baum hochklettert.",
"Stellen Sie sich den Klang und Geräusche der Hupe eines Autos vor.",
"Stellen Sie sich den Klang und Geräusche vom Hände-Klatschen beim Applaudieren vor.",
"Stellen Sie sich den Klang und Geräusche der Sirene eines Krankenwagens vor.",
"Stellen Sie sich den Geruch von frisch gemähtem Gras vor.",
"Stellen Sie sich den Geruch von brennendem Holz vor.",
"Stellen Sie sich den Geruch einer Rose vor.",
"Stellen Sie sich den Geschmack von schwarzem Pfeffer vor.",
"Stellen Sie sich den Geschmack einer Zitrone vor.",
"Stellen Sie sich den Geschmack von Senf vor.",
"Stellen Sie sich die Wahrnehmung beim Tasten von Fell vor.",
"Stellen Sie sich die Wahrnehmung beim Tasten von warmem Sand vor.",
"Stellen Sie sich die Wahrnehmung beim Tasten eines weichen Handtuchs vor.",
"Stellen Sie sich die körperliche Empfindung beim Entspannen in einem warmen Bad vor.",
"Stellen Sie sich die körperliche Empfindung beim schnellen Gehen in der Kälte vor.",
"Stellen Sie sich die körperliche Empfindung beim Sprung in einen Swimmingpool vor.",
"Stellen Sie sich vor, Sie fühlen sich emotional aufgeregt.",
"Stellen Sie sich vor, Sie fühlen sich emotional erleichtert.",
"Stellen Sie sich vor, Sie fühlen sich emotional verängstigt."
)
PSIQ_DISCLAIMER = paste0(
"Diese Auswertung stellt die individuellen Antworten den Kennwerten einer wissenschaftlichen ",
"Validierungsstichprobe (N = 300) gegenueber. Es handelt sich nicht um eine klinische Norm und ",
"nicht um eine Klassifikation. Die Interpretation obliegt der behandelnden Person."
)
# Verlauf dunkelrot -> gruen, extrapoliert aus den 5 PG13R-Ankerfarben auf die
# 11 Stufen der PSI-Q-Skala (0-10) per Lab-Farbinterpolation. Anders als bei
# PG13R ist hier ein hoher Wert (lebhafte Vorstellung) das positive Ergebnis,
# daher steht gruen bei 10 und dunkelrot bei 0.
PSIQ_BADGE_FARBEN = c(
"0" = "#4A0000",
"1" = "#73080F",
"2" = "#9F1517",
"3" = "#C22826",
"4" = "#D83E3A",
"5" = "#EE5250",
"6" = "#F36C76",
"7" = "#F4839D",
"8" = "#D8999E",
"9" = "#9CA777",
"10" = "#4CAE50"
)
PSIQ_BADGE_TEXT_FARBEN = c(
"0" = "white", "1" = "white", "2" = "white", "3" = "white",
"4" = "white", "5" = "white", "6" = "white", "7" = "#333333",
"8" = "#333333", "9" = "#333333", "10" = "white"
)
# 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 ####
# Spaltenname in daten_psiq per Muster suchen (case-insensitive). Kein
# stiller Fallback: bei keinem Treffer wird ein klarer Fehler geworfen, da
# der tatsaechliche Spaltenname von daten_psiq nicht verifiziert ist.
psiq_finde_spalte = function(daten, muster, beschreibung) {
namen = names(daten)
treffer = namen[grepl(muster, namen, ignore.case = TRUE)]
if (length(treffer) == 0) {
stop(paste0(
"In daten_psiq wurde keine Spalte gefunden, die zu '", beschreibung,
"' passt (Suchmuster: '", muster, "'). Bitte Datenstruktur des ",
"Download-Skripts pruefen."
))
}
treffer[1]
}
# Nicht verifiziert, ob formr fuer range_ticks-Items einen reinen Zahlenwert
# oder ein dbl+lbl-Objekt (Labels nur an den Endpunkten) exportiert. Defensiv:
# bei is.labelled(original_col) wird ueber zap_labels entlabelt, sonst wird
# der Rohwert direkt numerisch interpretiert. In beiden Faellen echte
# 0-10-Ratingskala, keine Kategorie/Faktor-Interpretation.
psiq_item_wert = function(original_col, wert) {
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_real_)
if (haven::is.labelled(original_col)) {
as.numeric(haven::zap_labels(wert[1]))
} else {
suppressWarnings(as.numeric(wert[1]))
}
}
# Rundet auf die naechste Badge-Stufe (0-10) fuer die Farbwahl. Werte ausserhalb
# 0-10 (siehe Warnung) werden fuer die Farbe an den naechsten gueltigen Rand
# geklemmt, der angezeigte Zahlenwert selbst bleibt davon unberuehrt.
psiq_badge_stufe = function(wert) {
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_integer_)
as.integer(round(pmin(10, pmax(0, wert[1]))))
}
# Rein deskriptive Einordnung relativ zur Validierungsstichprobe, KEINE
# Klassifikation und KEIN klinischer Schwellenwert. Der Pflichthinweis
# PSIQ_VERGLEICHSHINWEIS wird separat direkt bei den Zahlenwerten angezeigt
# (UI-Karte, Plot-Caption, Word-Export), nicht in diesen Satz gemischt.
psiq_einordnung = function(wert, ref_m, ref_sd) {
if (is.na(wert)) return("nicht auswertbar (fehlender Wert)")
diff = wert - ref_m
if (abs(diff) <= ref_sd) return("im Bereich M ± 1 SD")
if (diff > ref_sd) return("mehr als 1 SD ueber dem Vergleichswert")
"mehr als 1 SD unter dem Vergleichswert"
}
make_profil_psiq = function(profil_df) {
profil_df$label = factor(profil_df$label, levels = rev(profil_df$label))
ggplot(profil_df, aes(x = label, y = mittelwert)) +
geom_col(fill = AKZENT_FARBE, width = 0.6) +
geom_errorbar(
aes(ymin = pmax(0, ref_m - ref_sd), ymax = pmin(10, ref_m + ref_sd)),
width = 0.3, color = "#555555", linewidth = 0.6
) +
geom_point(aes(y = ref_m), color = "#333333", size = 2.6, shape = 18) +
coord_flip(ylim = c(0, 10)) +
scale_y_continuous(breaks = 0:10) +
theme_minimal(base_size = 12) +
labs(
x = NULL, y = "Wert (0-10)",
caption = paste0(
"Balken = individueller Mittelwert je Subskala. Punkt/Fehlerbalken = M ± 1 SD der ",
"Validierungsstichprobe (N=300). ", PSIQ_VERGLEICHSHINWEIS, "."
)
) +
theme(
panel.grid.minor = element_blank(),
plot.caption = element_text(size = 8, color = "#777777", hjust = 0),
plot.margin = margin(t = 5, r = 15, b = 5, l = 5)
)
}
# UI ####
app_css = "
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; }
.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; }
#download_word {
background: #8B2635; color: white; border: none;
font-weight: 600; padding: 8px 20px; border-radius: 4px;
}
#download_word:hover { background: #6d1e29; color: white; }
.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; }
.subskalen-grid {
display: grid; grid-template-columns: repeat(auto-fit, minmax(210px, 1fr));
gap: 12px; margin-bottom: 6px;
}
.subskala-karte {
background: #FAFAFA; border: 1px solid #EEEEEE; border-radius: 6px;
padding: 12px 14px;
}
.subskala-titel { font-weight: 700; color: #333; margin-bottom: 4px; }
.subskala-wert { font-size: 1.7rem; font-weight: 800; color: #8B2635; }
.subskala-vergleich { font-size: 0.82em; color: #666; margin-top: 2px; }
.subskala-einordnung { font-size: 0.82em; color: #444; margin-top: 6px; line-height: 1.4; }
.item-gruppe-titel {
font-weight: 700; color: #8B2635; margin: 14px 0 4px; font-size: 0.98em;
}
.item-zeile {
display: flex; align-items: flex-start; gap: 10px;
padding: 6px 0; border-bottom: 1px solid #F0F0F0;
}
.item-nr { font-weight: 600; color: #8B2635; min-width: 30px; flex-shrink: 0; }
.item-text { flex: 1; color: #333; font-size: 0.92em; }
.stufe-badge {
border-radius: 4px; padding: 2px 9px; font-weight: 700;
font-size: 0.82em; white-space: nowrap; display: inline-block; flex-shrink: 0;
min-width: 22px; text-align: center;
}
.stufe-badge-na { background: #E0E0E0; color: #757575; font-style: italic; font-weight: 500; }
.stufe-badge-0 { background: #4A0000; color: white; }
.stufe-badge-1 { background: #73080F; color: white; }
.stufe-badge-2 { background: #9F1517; color: white; }
.stufe-badge-3 { background: #C22826; color: white; }
.stufe-badge-4 { background: #D83E3A; color: white; }
.stufe-badge-5 { background: #EE5250; color: white; }
.stufe-badge-6 { background: #F36C76; color: white; }
.stufe-badge-7 { background: #F4839D; color: #333333; }
.stufe-badge-8 { background: #D8999E; color: #333333; }
.stufe-badge-9 { background: #9CA777; color: #333333; }
.stufe-badge-10 { background: #4CAE50; color: white; }
"
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("PSI-Q – Plymouth Sensory Imagery Questionnaire"),
tags$p("Deutsche Adaptation nach Jungmann, Becker & Witthoeft")
),
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_psiq_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")
fp_wert = fp_text(bold = TRUE, font.size = 12, color = AKZENT_FARBE)
fp_vergleich = fp_text(font.size = 9, italic = TRUE, color = "#666666")
doc = body_add_fpar(doc, fpar(
ftext("PSI-Q – Auswertung", fp_titel)
))
doc = body_add_fpar(doc, fpar(
ftext("Chiffre: ", fp_label), ftext(erg$chiffre, fp_normal),
ftext(" Ausfülldatum: ", fp_label), ftext(erg$datum_str, fp_normal)
))
for (w in erg$warnungen) {
doc = body_add_fpar(doc, fpar(
ftext(w, fp_text(font.size = 10, italic = TRUE, color = "#BF360C"))
))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Subskalen", fp_abschnitt)))
for (i in seq_len(nrow(erg$subskalen))) {
sub = erg$subskalen[i, ]
doc = body_add_fpar(doc, fpar(
ftext(paste0(sub$label, ": "), fp_label),
ftext(paste0(sub$mittelwert_str, " / 10"), fp_wert)
))
doc = body_add_fpar(doc, fpar(
ftext(paste0(
"M = ", sub$ref_m, ", SD = ", sub$ref_sd, " (", PSIQ_VERGLEICHSHINWEIS, "). ",
"Einordnung: ", sub$einordnung, "."
), fp_vergleich)
))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Einzelitems", fp_abschnitt)))
for (i in seq_len(nrow(erg$items))) {
it = erg$items[i, ]
stufe = psiq_badge_stufe(it$wert)
sk = if (is.na(stufe)) NA_character_ else as.character(stufe)
fp_badge = if (is.na(sk))
fp_text(color = "#757575", italic = TRUE, font.size = 10, shading.color = "#E0E0E0")
else
fp_text(
color = PSIQ_BADGE_TEXT_FARBEN[[sk]], bold = TRUE,
shading.color = PSIQ_BADGE_FARBEN[[sk]], font.size = 10
)
doc = body_add_fpar(doc, fpar(
ftext(paste0(it$nr, ". ", it$text, " "), fp_normal),
ftext(paste0(" ", it$wert_str, " "), fp_badge)
))
}
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(PSIQ_DISCLAIMER, fp_disclaimer)))
doc
}
# Server ####
server = function(input, output, session) {
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)))
}
})
# Skripte werden NICHT beim App-Start gesourct, nur beim Klick auf "Auswerten".
ergebnis_r = eventReactive(input$btn_suchen, {
chiffre = toupper(trimws(input$chiffre))
pseudonym_wert = trimws(input$pseudonym)
if (nchar(pseudonym_wert) == 0 && nchar(chiffre) == 0) {
return(list(typ = "leere_eingabe", meldung = "Bitte Chiffre oder Pseudonym eingeben."))
}
if (nchar(pseudonym_wert) == 0 && !grepl("^[A-Z][0-9]{6}$", chiffre)) {
return(list(typ = "format_fehler", meldung = paste0(
"Ungültige Chiffre. Erwartet: ein Grossbuchstabe + 6 Ziffern (z.B. P000123)."
)))
}
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
return(list(typ = "skript_fehler",
meldung = paste0("Download-Skript nicht gefunden unter:\n", PFAD_DOWNLOAD_SKRIPT)))
}
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
return(list(typ = "skript_fehler",
meldung = paste0("Pseudonym-Skript nicht gefunden unter:\n", PFAD_PSEUDONYM_SKRIPT)))
}
ok_download = tryCatch({
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
list(ok = TRUE)
}, error = function(e) list(ok = FALSE, msg = e$message))
if (!ok_download$ok) {
return(list(typ = "skript_fehler",
meldung = paste0("Fehler im Download-Skript: ", ok_download$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
})
alter_wd = getwd()
wd_ziel = if (!is.null(db_ordner)) db_ordner else
dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE))
setwd(wd_ziel)
on.exit(setwd(alter_wd), add = TRUE)
ok_pseudo = tryCatch({
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
list(ok = TRUE)
}, error = function(e) list(ok = FALSE, msg = e$message))
if (!ok_pseudo$ok) {
return(list(typ = "skript_fehler",
meldung = paste0("Fehler im Pseudonym-Skript: ", ok_pseudo$msg)))
}
if (!exists("daten_psiq", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = "Objekt 'daten_psiq' wurde nach dem Sourcen des Download-Skripts nicht gefunden."))
}
if (!exists("pseudo", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = "Objekt 'pseudo' wurde nach dem Sourcen des Pseudonym-Skripts nicht gefunden."))
}
daten = get("daten_psiq", envir = .GlobalEnv)
pseudo_df = get("pseudo", envir = .GlobalEnv)
# Spaltennamen fuer Sitzungskennung und Ausfuelldatum sind in daten_psiq
# nicht verifiziert - defensiv per Musterabgleich ermitteln.
spalten_ok = tryCatch({
list(
session_spalte = psiq_finde_spalte(daten, "session|pseudonym", "Sitzungskennung"),
datum_spalte = psiq_finde_spalte(daten, "created|ausfuell|datum", "Ausfülldatum"),
ok = TRUE
)
}, error = function(e) list(ok = FALSE, msg = e$message))
if (!isTRUE(spalten_ok$ok)) {
return(list(typ = "skript_fehler", meldung = spalten_ok$msg))
}
session_spalte = spalten_ok$session_spalte
datum_spalte = spalten_ok$datum_spalte
warnungen = c()
if (nchar(pseudonym_wert) > 0) {
pw_treffer = pseudo_df[pseudo_df$pseudonym == pseudonym_wert, ]
if (nrow(pw_treffer) == 0) {
return(list(typ = "pseudonym_unbekannt", meldung = paste0(
"Pseudonym '", pseudonym_wert, "' wurde in der Pseudonym-Datenbank nicht gefunden."
)))
}
chiffre_anzeige = toupper(trimws(pw_treffer$chiffre[1]))
alle_session_ids = pseudonym_wert
} else {
treffer_ps = pseudo_df[pseudo_df$chiffre == chiffre, ]
if (nrow(treffer_ps) == 0) {
return(list(typ = "chiffre_unbekannt", meldung = paste0(
"Chiffre '", chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden."
)))
}
chiffre_anzeige = chiffre
alle_session_ids = unique(treffer_ps$pseudonym)
}
treffer_dat = daten[daten[[session_spalte]] %in% alle_session_ids, ]
if (nrow(treffer_dat) == 0) {
return(list(typ = "kein_datensatz", meldung = paste0(
"Kein PSI-Q-Datensatz für ", if (nchar(pseudonym_wert) > 0) "Pseudonym" else "Chiffre",
" '", if (nchar(pseudonym_wert) > 0) pseudonym_wert else chiffre_anzeige,
"' gefunden. (", length(alle_session_ids), " Sitzungskennung(en) geprüft)"
)))
}
if (nrow(treffer_dat) > 1) {
n = nrow(treffer_dat)
sortier_wert = tryCatch(as.POSIXct(treffer_dat[[datum_spalte]]),
error = function(e) treffer_dat[[datum_spalte]])
treffer_dat = treffer_dat[order(sortier_wert, decreasing = TRUE), ]
datum_neu = tryCatch(
format(as.POSIXct(treffer_dat[[datum_spalte]][1]), "%d.%m.%Y %H:%M"),
error = function(e) as.character(treffer_dat[[datum_spalte]][1])
)
warnungen = c(warnungen, paste0(
"Mehrere Ausfüllungen gefunden (", n, " Einträge). Angezeigt wird die neueste vom ", datum_neu, "."
))
treffer_dat = treffer_dat[1, , drop = FALSE]
}
zeile = treffer_dat[1, , drop = FALSE]
datum_str = tryCatch(
format(as.POSIXct(zeile[[datum_spalte]][1]), "%d.%m.%Y"),
error = function(e) as.character(zeile[[datum_spalte]][1])
)
item_vars = sprintf("psiq_%02d", 1:21)
werte = sapply(item_vars, function(v) psiq_item_wert(daten[[v]], zeile[[v]]))
ausserhalb = which(!is.na(werte) & (werte < 0 | werte > 10))
if (length(ausserhalb) > 0) {
warnungen = c(warnungen, paste0(
"Wert(e) ausserhalb des gültigen Bereichs 0-10 bei Item(s): ",
paste(ausserhalb, collapse = ", "), ". Werte werden unveraendert angezeigt."
))
}
fehlend = which(is.na(werte))
if (length(fehlend) > 0) {
warnungen = c(warnungen, paste0(
"Kein Wert (NA) bei Item(s): ", paste(fehlend, collapse = ", "), "."
))
}
items = data.frame(
nr = 1:21,
var = item_vars,
text = PSIQ_ITEM_TEXTE,
wert = as.numeric(werte),
stringsAsFactors = FALSE
)
items$wert_str = ifelse(is.na(items$wert), "k. A.", as.character(round(items$wert, 1)))
subskalen = PSIQ_SUBSKALEN
subskalen$mittelwert = sapply(seq_len(nrow(subskalen)), function(i) {
idx = subskalen$item_start[i]:subskalen$item_ende[i]
mean(werte[idx], na.rm = TRUE)
})
subskalen$mittelwert_str = ifelse(
is.nan(subskalen$mittelwert), "k. A.", as.character(round(subskalen$mittelwert, 2))
)
subskalen$einordnung = sapply(seq_len(nrow(subskalen)), function(i) {
wert_i = if (is.nan(subskalen$mittelwert[i])) NA_real_ else subskalen$mittelwert[i]
psiq_einordnung(wert_i, subskalen$ref_m[i], subskalen$ref_sd[i])
})
list(
typ = "ok",
chiffre = chiffre_anzeige,
datum_str = datum_str,
warnungen = warnungen,
items = items,
subskalen = subskalen
)
})
output$fehler_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (d$typ != "ok") div(class = "alert-fehler", d$meldung) else NULL
})
output$warnung_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (d$typ != "ok" || length(d$warnungen) == 0) return(NULL)
div(lapply(d$warnungen, function(w) div(class = "alert-warnung", w)))
})
output$ergebnis_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (d$typ != "ok") return(NULL)
subskalen_ui = lapply(seq_len(nrow(d$subskalen)), function(i) {
sub = d$subskalen[i, ]
div(class = "subskala-karte",
div(class = "subskala-titel", sub$label),
div(class = "subskala-wert", paste0(sub$mittelwert_str, " / 10")),
div(class = "subskala-vergleich",
paste0("Vergleichswert: M = ", sub$ref_m, ", SD = ", sub$ref_sd)),
div(class = "subskala-einordnung", sub$einordnung)
)
})
item_gruppen_ui = lapply(seq_len(nrow(PSIQ_SUBSKALEN)), function(g) {
sub = PSIQ_SUBSKALEN[g, ]
idx = sub$item_start:sub$item_ende
zeilen = lapply(idx, function(i) {
it = d$items[d$items$nr == i, ]
stufe = psiq_badge_stufe(it$wert)
sk = if (is.na(stufe)) "na" else as.character(stufe)
div(class = "item-zeile",
div(class = "item-nr", paste0(it$nr, ".")),
div(class = "item-text", it$text),
span(class = paste0("stufe-badge stufe-badge-", sk), it$wert_str)
)
})
tagList(
div(class = "item-gruppe-titel", sub$label),
div(zeilen)
)
})
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "PSI-Q Auswertung"),
div(class = "meta-block",
tags$strong("Chiffre: "), d$chiffre,
tags$span(" | ", style = "color:#ccc;"),
tags$strong("Ausfülldatum: "), d$datum_str
),
tags$hr(),
tags$h5("Subskalen (Mittelwert je Sinnesbereich, 0-10)"),
div(class = "subskalen-grid", subskalen_ui),
tags$hr(),
tags$h5("Profil"),
plotOutput("profil_plot", height = "340px"),
tags$hr(),
tags$h5("Einzelitems"),
div(item_gruppen_ui)
)
})
output$profil_plot = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(identical(d$typ, "ok"))
profil_df = d$subskalen
profil_df$mittelwert[is.nan(profil_df$mittelwert)] = NA_real_
make_profil_psiq(profil_df)
}, bg = "transparent")
output$download_word = downloadHandler(
filename = function() {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
chiffre_esc = if (is.list(d) && identical(d$typ, "ok")) d$chiffre else "export"
datum = if (is.list(d) && identical(d$typ, "ok") && !is.null(d$datum_str))
tryCatch(
format(as.Date(d$datum_str, "%d.%m.%Y"), "%Y%m%d"),
error = function(e) format(Sys.Date(), "%Y%m%d")
)
else
format(Sys.Date(), "%Y%m%d")
paste0("PSIQ_", chiffre_esc, "_", datum, ".docx")
},
content = function(file) {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
daten_ok = is.list(d) && identical(d$typ, "ok")
if (!daten_ok) {
doc = read_docx()
doc = body_add_par(doc,
"Kein Datensatz geladen. Bitte zuerst Chiffre oder Pseudonym eingeben und 'Auswerten' klicken.",
style = "Normal")
print(doc, target = file)
return()
}
doc = tryCatch(
erstelle_psiq_docx(d),
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)

2879
PSI-Q/renv.lock Normal file
View file

File diff suppressed because it is too large Load diff

14
PSI-Q/setup_renv.R Normal file
View file

@ -0,0 +1,14 @@
# Einmalig ausfuehren, bevor die App zum ersten Mal gestartet wird.
# Initialisiert renv und installiert alle benoetigten Pakete.
#
# DBI und RSQLite werden vom gesourcten Pseudonym-Skript benoetigt,
# nicht direkt von der App selbst.
renv::init()
pkgs = c("shiny", "dplyr", "ggplot2", "haven", "officer", "DBI", "RSQLite","formr")
install.packages(pkgs)
renv::snapshot()
message("Setup abgeschlossen. App starten mit: shiny::runApp()")