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

Binary file not shown.

1
AQ/.Rprofile Normal file
View file

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

13
AQ/AQ.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

734
AQ/app.R Normal file
View file

@ -0,0 +1,734 @@
# Präambel ####
library(shiny)
library(dplyr)
library(ggplot2)
library(haven)
library(officer)
# DBI und RSQLite werden nicht hier geladen: sie werden ausschliesslich vom
# gesourcten ../get_pseudo.R gebraucht. In renv.lock landen sie ueber
# renv::snapshot(type = "all") (siehe setup_renv.R).
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_aq50.R" # liefert: daten_aq50
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo
AKZENT_FARBE = "#8B2635"
AQ_DISCLAIMER = paste0(
"Der AQ ist kein diagnostisches Instrument. Ein erhoehter Wert rechtfertigt eine ",
"weiterfuehrende Abklaerung, keine Diagnose. Die Interpretation obliegt der behandelnden Person."
)
# Anzeige-Disclaimer, immer sichtbar (exakter Wortlaut aus der Quelldokumentation)
AQ_DISCLAIMER_ANZEIGE = paste0(
"Der AQ ist kein diagnostisches Instrument. Ein erhöhter Wert rechtfertigt eine ",
"weiterführende Abklärung, keine Diagnose."
)
# Bereichstexte je Cutoff-Bereich (exakter Wortlaut, nicht kuerzen)
AQ_BEREICH_UNAUFFAELLIG = paste0(
"Unauffällig im Sinne des AQ; Wert unterhalb des klinischen Screening-Cutoffs ",
"(Referenz: Mittelwert Allgemeinbevölkerung ≈ 16,4)."
)
AQ_BEREICH_SCREENING = paste0(
"Oberhalb des klinischen Screening-Cutoffs (≥ 26) — weiterführende ",
"autismusspezifische Abklärung erwägen."
)
AQ_BEREICH_FORSCHUNG = paste0(
"Zusätzlich oberhalb des Forschungs-Cutoffs (≥ 32) — deutliche Ausprägung ",
"autistischer Züge im Selbstbericht; weiterführende Diagnostik nahegelegt."
)
# Beschriftung des Prozentwerts (exakt so, keine Abkuerzung, keine Umformulierung)
AQ_PROZENT_LABEL = "Orientierender Prozentwert (Rohwert bezogen auf 40; keine validierte Wahrscheinlichkeit)."
# Robustheits-Hinweis zum Subskalen-Profil
AQ_SUBSKALEN_HINWEIS = paste0(
"Die 5-Faktoren-Struktur des AQ gilt in der Literatur als nicht robust repliziert; ",
"die Subskalen sind als deskriptive Zusatzinformation zu verstehen, nicht als ",
"eigenständige Diagnostik."
)
# Klassifikationsfarben (gruen / orange / rot), nicht die Akzentfarbe
AQ_FARBE_GRUEN = "#2E7D32"
AQ_FARBE_ORANGE = "#E65100"
AQ_FARBE_ROT = "#C62828"
AQ_BG_GRUEN = "#E8F5E9"
AQ_BG_ORANGE = "#FFF3E0"
AQ_BG_ROT = "#FFEBEE"
AQ_MITTELWERT_ALLGEMEIN = 16.4
# 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 ####
# Dekodiert eine Item-Spalte zu Antworttext. Robust gegen drei Faelle:
# haven_labelled (numerischer Wert + labels-Attribut), rein numerisch, oder bereits Text.
aq_text_dekodieren = function(spalte) {
if (inherits(spalte, "haven_labelled")) {
labels_attr = attr(spalte, "labels")
werte_numerisch = as.numeric(spalte)
text = names(labels_attr)[match(werte_numerisch, labels_attr)]
return(text)
}
if (is.numeric(spalte)) {
zuordnung = c("1" = "stimme voll zu", "2" = "stimme eher zu",
"3" = "stimme eher nicht zu", "4" = "stimme überhaupt nicht zu")
return(unname(zuordnung[as.character(spalte)]))
}
return(as.character(spalte))
}
# Vereinheitlicht Antworttext vor der Dichotomisierung (Klein/Gross, Markdown, Whitespace,
# abschliessende Satzzeichen). Aendert keine Umlaute.
aq_normalisiere_text = function(x) {
if (is.null(x) || length(x) == 0 || is.na(x[1])) return(NA_character_)
y = tolower(trimws(as.character(x[1])))
y = gsub("\\*\\*", "", y)
y = gsub("[[:space:]]+", " ", y)
y = gsub("[.;,!]+$", "", y)
trimws(y)
}
# Dichotomisierung ausschliesslich ueber den dekodierten Text, nie ueber Zahlenwerte.
aq_dichotom_punkt = function(text_vektor, ist_zustimmungsitem) {
zustimmung = text_vektor %in% c("stimme voll zu", "stimme eher zu")
ablehnung = text_vektor %in% c("stimme eher nicht zu", "stimme überhaupt nicht zu")
punkt = ifelse(ist_zustimmungsitem, as.integer(zustimmung), as.integer(ablehnung))
punkt[is.na(text_vektor) | (!zustimmung & !ablehnung)] = NA_integer_
punkt
}
# Klinische Einordnung anhand der Cutoffs.
aq_klassifikation = function(score) {
if (score <= 25) {
return(list(text = AQ_BEREICH_UNAUFFAELLIG, farbe = AQ_FARBE_GRUEN,
bg = AQ_BG_GRUEN, kurz = "unauffaellig"))
}
if (score <= 31) {
return(list(text = AQ_BEREICH_SCREENING, farbe = AQ_FARBE_ORANGE,
bg = AQ_BG_ORANGE, kurz = "screening"))
}
list(text = AQ_BEREICH_FORSCHUNG, farbe = AQ_FARBE_ROT, bg = AQ_BG_ROT, kurz = "forschung")
}
# Entfernt formr-Artefakte (fuehrende Nummerierung, Markdown-Escapes, Zeilenumbrueche)
# aus dem Itemwortlaut. Behandelt auch Formen wie "22\. Text" oder "22 . Text".
clean_item_label = function(text) {
if (is.null(text) || length(text) == 0 || is.na(text[1])) return(NA_character_)
roh = as.character(text[1])
roh = gsub("[\r\n]+", " ", roh)
roh = gsub("\\*\\*", "", roh) # Fett-Markdown
roh = gsub("\\\\", "", roh) # Markdown-Escapes, z.B. "22\."
roh = trimws(roh)
roh = sub("^\\d+\\s*[.)]?\\s*", "", roh) # fuehrende Item-Nummer (+ optionaler Punkt/Klammer)
roh = sub("^[.)]\\s*", "", roh) # evtl. verbliebenes fuehrendes Satzzeichen
roh = gsub("[[:space:]]+", " ", roh)
trimws(roh)
}
# Horizontale Gauge 0-50 mit farbigen Zonen, Wertmarker und Referenzlinie bei 16,4.
make_gauge_aq = function(score) {
ggplot() +
geom_rect(aes(xmin = 0, xmax = 25.5, ymin = 0, ymax = 1), fill = AQ_BG_GRUEN, color = NA) +
geom_rect(aes(xmin = 25.5, xmax = 31.5, ymin = 0, ymax = 1), fill = AQ_BG_ORANGE, color = NA) +
geom_rect(aes(xmin = 31.5, xmax = 50, ymin = 0, ymax = 1), fill = AQ_BG_ROT, color = NA) +
geom_rect(aes(xmin = 0, xmax = 50, ymin = 0, ymax = 1), fill = NA, color = "#9E9E9E", linewidth = 0.6) +
geom_vline(xintercept = AQ_MITTELWERT_ALLGEMEIN, color = "#555555", linetype = "dashed", linewidth = 0.9) +
annotate("text", x = AQ_MITTELWERT_ALLGEMEIN, y = 1.34,
label = "Mittelwert Allgemeinbevoelkerung (16,4)",
color = "#555555", size = 3.1, hjust = 0.5) +
geom_segment(aes(x = score, xend = score, y = -0.25, yend = 1.25),
color = AKZENT_FARBE, linewidth = 2.5) +
geom_label(aes(x = score, y = 1.78, label = paste0("AQ: ", score)),
fill = AKZENT_FARBE, color = "white", fontface = "bold",
linewidth = 0, size = 4.2) +
annotate("text", x = 12.75, y = 0.5, label = "0-25", color = AQ_FARBE_GRUEN,
size = 3.3, fontface = "italic") +
annotate("text", x = 28.5, y = 0.5, label = "26-31", color = AQ_FARBE_ORANGE,
size = 3.3, fontface = "italic") +
annotate("text", x = 41, y = 0.5, label = ">= 32", color = AQ_FARBE_ROT,
size = 3.3, fontface = "italic") +
scale_x_continuous(limits = c(-1, 51), breaks = seq(0, 50, 10)) +
scale_y_continuous(limits = c(-0.7, 2.15)) +
theme_minimal(base_size = 12) +
theme(
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor = element_blank(),
axis.title.y = element_blank(),
plot.margin = margin(t = 5, r = 12, b = 5, l = 12)
) +
labs(x = "AQ-Gesamtscore (0-50)", y = NULL)
}
# Horizontales Balkenprofil der fuenf Subskalen, Wertebereich 0-10.
make_subskalen_plot = function(subskalenwerte) {
werte = as.numeric(subskalenwerte[names(aq_subskalen_labels)])
df = data.frame(
skala = factor(unname(aq_subskalen_labels), levels = rev(unname(aq_subskalen_labels))),
wert = werte
)
ggplot(df, aes(x = wert, y = skala)) +
geom_col(fill = AKZENT_FARBE, width = 0.62) +
geom_text(aes(label = wert), hjust = -0.4, size = 3.6, color = "#333333") +
scale_x_continuous(limits = c(0, 10.8), breaks = 0:10) +
theme_minimal(base_size = 12) +
theme(
panel.grid.major.y = element_blank(),
panel.grid.minor = element_blank(),
axis.title.y = element_blank(),
plot.margin = margin(t = 5, r = 12, b = 5, l = 6)
) +
labs(x = "Subskalenwert (0-10)", y = NULL)
}
# Datenaufbereitung ####
# Zustimmungsitems (Punkt bei "stimme voll/eher zu")
aq_z_items = c(2, 4, 5, 6, 7, 9, 12, 13, 16, 18, 19, 20, 21, 22, 23, 26, 33, 35, 39, 41, 42, 43, 45, 46)
# Ablehnungsitems (Punkt bei "stimme eher/ueberhaupt nicht zu")
aq_a_items = c(1, 3, 8, 10, 11, 14, 15, 17, 24, 25, 27, 28, 29, 30, 31, 32, 34, 36, 37, 38, 40, 44, 47, 48, 49, 50)
aq_subskalen = list(
soziale_faehigkeiten = c(1, 11, 13, 15, 22, 36, 44, 45, 47, 48),
aufmerksamkeitswechsel = c(2, 4, 10, 16, 25, 32, 34, 37, 43, 46),
detailwahrnehmung = c(5, 6, 9, 12, 19, 23, 28, 29, 30, 49),
kommunikation = c(7, 17, 18, 26, 27, 31, 33, 35, 38, 39),
vorstellungskraft = c(3, 8, 14, 20, 21, 24, 40, 41, 42, 50)
)
aq_subskalen_labels = c(
soziale_faehigkeiten = "Soziale Fähigkeiten",
aufmerksamkeitswechsel = "Aufmerksamkeitswechsel",
detailwahrnehmung = "Detailwahrnehmung",
kommunikation = "Kommunikation",
vorstellungskraft = "Vorstellungskraft"
)
# Die vier Antwortstufen in fester Reihenfolge (1 = volle Zustimmung ... 4 = volle Ablehnung).
# Normalisierter Text (Kleinbuchstaben) -> Stufe.
aq_antwort_stufen = c("stimme voll zu", "stimme eher zu",
"stimme eher nicht zu", "stimme überhaupt nicht zu")
# UI ####
app_css = "
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; color: #222; }
.input-panel {
background: #fff; 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: #fff !important; border: none !important;
border-radius: 4px !important; padding: 8px 20px !important; font-weight: 600 !important;
}
.btn-laden:hover { background: #6d1e29 !important; color: #fff !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-weight: 500;
}
.abschnitt-karte {
background: #fff; 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;
}
.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: 52px; flex-shrink: 0; }
.item-invers {
display: block; font-size: 0.62em; font-weight: 400; font-style: italic;
color: #999; letter-spacing: 0.03em;
}
.item-text { flex: 1; color: #333; font-size: 0.92em; }
.antwort-badge {
border-radius: 4px; padding: 2px 10px; font-weight: 600; font-size: 0.8em;
white-space: nowrap; display: inline-block; flex-shrink: 0; text-align: center;
}
.antwort-badge-1 { background: #F48FB1; color: #333333; }
.antwort-badge-2 { background: #EF5350; color: #fff; }
.antwort-badge-3 { background: #B71C1C; color: #fff; }
.antwort-badge-4 { background: #4A0000; color: #fff; }
.antwort-badge-na { background: #ECEFF1; color: #546E7A; }
.punkt-0 { color: #9E9E9E; font-weight: 700; }
.punkt-1 { color: #B71C1C; font-weight: 700; }
"
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(style = paste0("background:", AKZENT_FARBE,
"; color:#fff; padding:18px 24px 14px; margin-bottom:20px; border-radius:0 0 6px 6px;"),
tags$h2("AQ - Autism Spectrum Quotient (50 Items)",
style = "margin:0; font-size:1.5rem; font-weight:600;"),
tags$p("Baron-Cohen et al. 2001 | lokale Auswertung",
style = "margin:4px 0 0; opacity:.85; font-size:.9rem;")
),
div(class = "container-fluid", style = "max-width: 1100px;",
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_aq50_docx = function(erg) {
kl = aq_klassifikation(erg$gesamtscore)
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_score = fp_text(bold = TRUE, font.size = 13, color = kl$farbe)
fp_klass = fp_text(font.size = 11, color = kl$farbe)
fp_klein = fp_text(font.size = 9, italic = TRUE, color = "#666666")
fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
ausfuell_str = tryCatch(
format(as.POSIXct(erg$ausfuelldatum), "%d.%m.%Y"),
error = function(e) as.character(erg$ausfuelldatum)
)
if (length(ausfuell_str) == 0 || is.na(ausfuell_str) || !nzchar(ausfuell_str)) {
ausfuell_str = "unbekannt"
}
doc = read_docx()
doc = body_add_fpar(doc, fpar(ftext("AQ-50 - Einzelauswertung", fp_titel)))
doc = body_add_fpar(doc, fpar(
ftext("Chiffre: ", fp_label), ftext(as.character(erg$chiffre), fp_titel)
))
doc = body_add_fpar(doc, fpar(
ftext("Ausfuelldatum: ", fp_label), ftext(ausfuell_str, fp_normal)
))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Gesamtscore", fp_abschnitt)))
doc = body_add_fpar(doc, fpar(ftext(paste0(erg$gesamtscore, " / 50"), fp_score)))
doc = body_add_fpar(doc, fpar(ftext(kl$text, fp_klass)))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Orientierender Prozentwert", fp_abschnitt)))
doc = body_add_fpar(doc, fpar(ftext(paste0(format(erg$prozentwert, nsmall = 1), " %"), fp_normal)))
doc = body_add_fpar(doc, fpar(ftext(AQ_PROZENT_LABEL, fp_klein)))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext("Subskalen", fp_abschnitt)))
for (schluessel in names(aq_subskalen_labels)) {
doc = body_add_fpar(doc, fpar(
ftext(paste0(aq_subskalen_labels[[schluessel]], ": "), fp_label),
ftext(paste0(erg$subskalenwerte[[schluessel]], " von 10"), fp_normal)
))
}
doc = body_add_fpar(doc, fpar(ftext(AQ_SUBSKALEN_HINWEIS, fp_klein)))
doc = body_add_par(doc, "", style = "Normal")
doc = body_add_fpar(doc, fpar(ftext(AQ_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)))
}
})
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", meldung = "Bitte Chiffre oder Pseudonym eingeben."))
}
if (nchar(trimws(input$pseudonym)) == 0 && !grepl("^[A-Z][0-9]{6}$", chiffre)) {
return(list(typ = "format_fehler",
meldung = paste0("Ungueltige Chiffre '", chiffre,
"'. Erwartet: ein Grossbuchstabe + 6 Ziffern (z.B. P000123).")))
}
# Schritt 1: Download-Skript sourcen
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
return(list(typ = "skript_fehler",
meldung = paste("Download-Skript nicht gefunden:", PFAD_DOWNLOAD_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(typ = "skript_fehler",
meldung = paste("Fehler im Download-Skript:", ok_dl$msg)))
}
# Schritt 2: pseudonyme.db suchen und Pseudonym-Skript sourcen
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
return(list(typ = "skript_fehler",
meldung = paste("Pseudonym-Skript nicht gefunden:", PFAD_PSEUDONYM_SKRIPT)))
}
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 = "pseudonyme.db wurde in den uebergeordneten Verzeichnissen nicht gefunden."))
}
alter_wd = getwd()
on.exit(setwd(alter_wd), add = TRUE)
setwd(db_ordner)
ok_ps = tryCatch({
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
list(ok = TRUE)
}, error = function(e) list(ok = FALSE, msg = e$message))
if (!ok_ps$ok) {
return(list(typ = "skript_fehler",
meldung = paste("Fehler im Pseudonym-Skript:", ok_ps$msg)))
}
if (!exists("daten_aq50", envir = .GlobalEnv) || !exists("pseudo", envir = .GlobalEnv)) {
return(list(typ = "skript_fehler",
meldung = "daten_aq50 oder pseudo wurden nach dem Sourcen nicht gefunden."))
}
daten_aq50 = get("daten_aq50", envir = .GlobalEnv)
pseudo = get("pseudo", envir = .GlobalEnv)
# Schritt 3: Chiffre aus Pseudonym rueckaufloesen, falls Pseudonym eingegeben wurde
if (nchar(trimws(input$pseudonym)) > 0) {
pw_treffer = pseudo[as.character(pseudo$pseudonym) == trimws(input$pseudonym), ]
if (nrow(pw_treffer) > 0) chiffre = toupper(trimws(as.character(pw_treffer$chiffre[1])))
}
# Schritt 4: Chiffre in pseudo nachschlagen
treffer_ps = pseudo[toupper(trimws(as.character(pseudo$chiffre))) == chiffre, ]
if (nrow(treffer_ps) == 0) {
return(list(typ = "kein_treffer_chiffre",
meldung = 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)
# Schritt 5: daten_aq50 nach Session(s) filtern
if (!("session" %in% names(daten_aq50))) { # Spaltenname 'session' gegen echte Daten pruefen
return(list(typ = "daten_fehler",
meldung = "Spalte 'session' fehlt in daten_aq50 (Spaltenname der Session-ID pruefen)."))
}
treffer_daten = daten_aq50[as.character(daten_aq50$session) %in% alle_session_ids, , drop = FALSE]
if (nrow(treffer_daten) == 0) {
return(list(typ = "kein_treffer_daten",
meldung = paste0("Kein AQ-50-Datensatz fuer Chiffre '", chiffre, "' gefunden.")))
}
mehrfach_warnung = NULL
if (nrow(treffer_daten) > 1) {
anzahl = nrow(treffer_daten)
if ("created" %in% names(treffer_daten)) { # Spaltenname 'created' gegen echte Daten pruefen
ord = order(as.POSIXct(treffer_daten$created), decreasing = TRUE)
treffer_daten = treffer_daten[ord, , drop = FALSE]
}
treffer_daten = treffer_daten[1, , drop = FALSE]
mehrfach_warnung = paste0("Mehrere Ausfuellungen gefunden (", anzahl,
"). Es wird die zeitlich neueste angezeigt.")
}
# Schritt 6: Dichotomisierung und Scoring
item_spalten = paste0("aq_", sprintf("%02d", 1:50))
fehlende_spalten = setdiff(item_spalten, names(treffer_daten))
if (length(fehlende_spalten) > 0) {
return(list(typ = "daten_fehler",
meldung = paste("Fehlende Item-Spalten:", paste(fehlende_spalten, collapse = ", "))))
}
texte_roh = lapply(item_spalten, function(sp) aq_text_dekodieren(treffer_daten[[sp]][1]))
names(texte_roh) = 1:50
texte_norm = lapply(texte_roh, aq_normalisiere_text)
item_labels = sapply(item_spalten, function(sp) clean_item_label(attr(daten_aq50[[sp]], "label")))
names(item_labels) = 1:50
punkte = sapply(1:50, function(i) {
ist_z = i %in% aq_z_items
aq_dichotom_punkt(texte_norm[[as.character(i)]], ist_z)
})
names(punkte) = 1:50
stufen = sapply(1:50, function(i) match(texte_norm[[as.character(i)]], aq_antwort_stufen))
names(stufen) = 1:50
if (any(is.na(punkte))) {
betroffen = names(punkte)[is.na(punkte)]
return(list(typ = "daten_fehler",
meldung = paste0("Unerwarteter oder fehlender Wert bei Item(s): ",
paste(betroffen, collapse = ", "),
". Der Score wird nicht berechnet (keine Imputation).")))
}
gesamtscore = sum(punkte)
subskalenwerte = sapply(aq_subskalen, function(items) sum(punkte[as.character(items)]))
if (sum(subskalenwerte) != gesamtscore) {
return(list(typ = "daten_fehler",
meldung = "Interner Kontrollfehler: Summe der Subskalen weicht vom Gesamtscore ab."))
}
list(
typ = "erfolg",
chiffre = chiffre,
punkte = punkte,
stufen = stufen,
texte = unlist(texte_roh),
item_labels = item_labels,
gesamtscore = gesamtscore,
subskalenwerte = subskalenwerte,
prozentwert = round(gesamtscore / 40 * 100, 1),
ausfuelldatum = if ("created" %in% names(treffer_daten)) treffer_daten$created[1] else NA, # Format von 'created' gegen echte Daten pruefen
mehrfach_warnung = mehrfach_warnung
)
})
fehler_praefix = function(typ) {
switch(typ,
leere_eingabe = "Eingabe unvollstaendig: ",
format_fehler = "Ungueltige Eingabe: ",
skript_fehler = "Datenzugriff nicht moeglich: ",
kein_treffer_chiffre = "Kein Pseudonym-Eintrag: ",
kein_treffer_daten = "Kein Datensatz gefunden: ",
daten_fehler = "Datenproblem: ",
"Fehler: "
)
}
output$fehler_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (identical(d$typ, "erfolg")) return(NULL)
div(class = "alert-fehler", paste0(fehler_praefix(d$typ), d$meldung))
})
output$warnung_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
if (!identical(d$typ, "erfolg") || is.null(d$mehrfach_warnung)) return(NULL)
div(class = "alert-warnung", d$mehrfach_warnung)
})
output$ergebnis_ui = renderUI({
req(input$btn_suchen)
d = ergebnis_r()
req(identical(d$typ, "erfolg"))
kl = aq_klassifikation(d$gesamtscore)
ausfuell_str = tryCatch(
format(as.POSIXct(d$ausfuelldatum), "%d.%m.%Y %H:%M", tz = "Europe/Berlin"),
error = function(e) as.character(d$ausfuelldatum)
)
if (length(ausfuell_str) == 0 || is.na(ausfuell_str) || !nzchar(ausfuell_str)) {
ausfuell_str = "unbekannt"
}
items_ui = lapply(1:50, function(i) {
lab = d$item_labels[[as.character(i)]]
if (is.null(lab) || is.na(lab) || !nzchar(lab)) lab = paste0("Item ", i)
antwort = d$texte[[as.character(i)]]
if (is.null(antwort) || is.na(antwort)) antwort = "-"
stufe = d$stufen[[as.character(i)]]
ist_invers = i %in% aq_a_items
badge_klasse = if (is.null(stufe) || is.na(stufe)) {
"antwort-badge antwort-badge-na"
} else {
# Bei invers gepolten Items wird die Farbpalette umgekehrt, damit ein
# Punkt-Beitrag ueber alle Items hinweg gleich eingefaerbt ist.
farb_stufe = if (ist_invers) 5 - stufe else stufe
paste0("antwort-badge antwort-badge-", farb_stufe)
}
p = d$punkte[[as.character(i)]]
div(class = "item-zeile",
div(class = "item-nr",
paste0(i, "."),
if (ist_invers) tags$span(class = "item-invers", "invers")
),
div(class = "item-text", lab),
tags$span(class = badge_klasse, antwort),
tags$span(class = paste0("punkt-", p),
style = "flex-shrink:0; min-width:20px; text-align:right;",
title = "AQ-Punkt (0 oder 1)", p)
)
})
tagList(
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "AQ-50 Auswertung"),
div(style = "color:#555; margin-bottom:14px;",
tags$strong("Chiffre: "), d$chiffre,
tags$span(" | ", style = "color:#ccc;"),
tags$strong("Ausfuelldatum: "), ausfuell_str
),
div(style = "display:flex; align-items:center; gap:18px; flex-wrap:wrap;",
div(style = paste0("font-size:2.4rem; font-weight:800; color:", kl$farbe, ";"),
paste0(d$gesamtscore, " / 50")),
div(style = "flex:1; min-width:280px;", plotOutput("gauge_plot", height = "185px"))
),
div(style = paste0("margin-top:10px; padding:12px 16px; border-radius:6px; border-left:5px solid ",
kl$farbe, "; background:", kl$bg, "; color:", kl$farbe,
"; font-size:0.95em; line-height:1.5;"),
kl$text),
div(style = "margin-top:14px; padding-top:10px; border-top:1px solid #eee;",
div(style = "font-size:1.1rem; font-weight:700; color:#444;",
paste0(format(d$prozentwert, nsmall = 1), " %")),
div(style = "font-size:0.82em; color:#777; font-style:italic;", AQ_PROZENT_LABEL)
)
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Subskalen-Profil"),
plotOutput("subskalen_plot", height = "235px"),
div(style = "margin-top:10px; font-size:0.85em; color:#666; font-style:italic; line-height:1.5;",
AQ_SUBSKALEN_HINWEIS)
),
div(class = "abschnitt-karte",
div(class = "abschnitt-titel", "Einzelitems"),
div(style = "font-size:0.82em; color:#777; margin-bottom:10px; line-height:1.5;",
tags$span(style = "font-style:italic;", "invers"),
" = umgekehrt gepoltes Item (Ablehnung ergibt den Punkt); ",
"die Farbskala der Antwort ist bei diesen Items entsprechend gespiegelt. ",
"Zahl rechts = AQ-Punkt (0 oder 1)."),
div(items_ui)
),
div(class = "abschnitt-karte",
div(style = "font-size:0.9em; color:#555; line-height:1.6;",
tags$strong("Hinweis: "), AQ_DISCLAIMER_ANZEIGE)
)
)
})
output$gauge_plot = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(identical(d$typ, "erfolg"))
make_gauge_aq(d$gesamtscore)
}, bg = "transparent")
output$subskalen_plot = renderPlot({
req(input$btn_suchen)
d = ergebnis_r()
req(identical(d$typ, "erfolg"))
make_subskalen_plot(d$subskalenwerte)
}, bg = "transparent")
output$download_word = downloadHandler(
filename = function() {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
if (!is.list(d) || !identical(d$typ, "erfolg")) return("AQ50_export.docx")
chiffre_fn = gsub("[^A-Za-z0-9_-]", "_", as.character(d$chiffre))
ausfuelldatum_fn = tryCatch({
v = format(as.Date(d$ausfuelldatum), "%Y%m%d")
if (is.na(v) || !nzchar(v)) paste0(format(Sys.Date(), "%Y%m%d"), "_ohnedatum") else v
}, error = function(e) paste0(format(Sys.Date(), "%Y%m%d"), "_ohnedatum"))
paste0("AQ50_", chiffre_fn, "_", ausfuelldatum_fn, ".docx")
},
content = function(file) {
d = tryCatch(ergebnis_r(), error = function(e) NULL)
if (!is.list(d) || !identical(d$typ, "erfolg")) {
doc = read_docx()
doc = body_add_par(doc,
"Kein auswertbarer Datensatz geladen. Bitte zuerst Chiffre oder Pseudonym eingeben und 'Auswerten' klicken.",
style = "Normal")
print(doc, target = file)
return()
}
doc = tryCatch(
erstelle_aq50_docx(d),
error = function(e) {
ed = read_docx()
body_add_par(ed, paste0("Fehler beim Erstellen des Word-Dokuments: ", e$message),
style = "Normal")
}
)
print(doc, target = file)
}
)
}
# Start ####
shinyApp(ui, server)

4119
AQ/renv.lock Normal file
View file

File diff suppressed because one or more lines are too long

14
AQ/setup_renv.R Normal file
View file

@ -0,0 +1,14 @@
# Einmalig auf dem Zielrechner ausfuehren, bevor die App zum ersten Mal startet.
# Initialisiert renv fuer diese App und installiert alle benoetigten Pakete.
renv::init()
pakete = c("shiny", "dplyr", "ggplot2", "haven", "officer", "DBI", "RSQLite", "formr")
install.packages(pakete)
# type = "all" statt des impliziten Standard-Scans: DBI und RSQLite werden im
# App-Code nie per library() aufgerufen (nur das gesourcte ../get_pseudo.R braucht
# sie), daher wuerde der Standard-Scan sie nicht in renv.lock aufnehmen.
renv::snapshot(type = "all")
message("Setup abgeschlossen. App starten mit: shiny::runApp()")