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