Initial commit
This commit is contained in:
commit
3cba772836
1341 changed files with 532924 additions and 0 deletions
735
TAS26/app.R
Normal file
735
TAS26/app.R
Normal file
|
|
@ -0,0 +1,735 @@
|
|||
# Präambel ####
|
||||
|
||||
AKZENT_FARBE = "#8B2635"
|
||||
|
||||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_tas26.R" # liefert beim Sourcen: daten_tas26
|
||||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert beim Sourcen: pseudo
|
||||
PFAD_NORMTABELLEN = "normtabellen"
|
||||
|
||||
TAS26_HINWEIS_SCHULABSCHLUSS_FEHLT = "Schulabschluss nicht angegeben — differenzierte Norm nicht verfügbar."
|
||||
|
||||
TAS26_HINWEIS_T_BAND = "statistischer Durchschnittsbereich (M±1SD), keine klinische Grenze"
|
||||
|
||||
# Item-Badges: sequenzielle Farbskala von hell nach Akzentfarbe (Werte 1-5),
|
||||
# keine Ampel-/Gut-Schlecht-Faerbung, da der TAS-26 kein Klassifikationsschema kennt.
|
||||
TAS26_BADGE_FARBEN = setNames(
|
||||
grDevices::colorRampPalette(c("#F2E4E6", AKZENT_FARBE))(5),
|
||||
as.character(1:5)
|
||||
)
|
||||
TAS26_BADGE_TEXT_FARBEN = setNames(
|
||||
sapply(TAS26_BADGE_FARBEN, function(bg) {
|
||||
rgb = grDevices::col2rgb(bg)
|
||||
luminanz = 0.299 * rgb[1] + 0.587 * rgb[2] + 0.114 * rgb[3]
|
||||
if (luminanz > 150) "#333333" else "white"
|
||||
}),
|
||||
as.character(1:5)
|
||||
)
|
||||
|
||||
TAS26_DISCLAIMER = paste0(
|
||||
"Diese Auswertung ist ein Hilfsmittel für klinisches Fachpersonal und ersetzt keine ",
|
||||
"klinische Diagnose. Die Interpretation obliegt der behandelnden Person. Für den TAS-26 ",
|
||||
"liegt kein Cutoff- oder Klassifikationsschema vor; die Werte sind ausschließlich ",
|
||||
"kontinuierlich (T-Wert, Prozentrang) zu interpretieren."
|
||||
)
|
||||
|
||||
library(shiny)
|
||||
library(dplyr)
|
||||
library(ggplot2)
|
||||
library(haven)
|
||||
library(officer)
|
||||
|
||||
|
||||
# Infrastruktur ####
|
||||
|
||||
APP_VERZEICHNIS = normalizePath(getwd())
|
||||
|
||||
absPath = function(pfad) {
|
||||
if (grepl("^([A-Za-z]:[/\\\\]|/)", pfad)) return(pfad)
|
||||
file.path(APP_VERZEICHNIS, pfad)
|
||||
}
|
||||
|
||||
PFAD_DOWNLOAD_SKRIPT = normalizePath(absPath(PFAD_DOWNLOAD_SKRIPT), mustWork = FALSE)
|
||||
PFAD_PSEUDONYM_SKRIPT = normalizePath(absPath(PFAD_PSEUDONYM_SKRIPT), mustWork = FALSE)
|
||||
PFAD_NORMTABELLEN = normalizePath(absPath(PFAD_NORMTABELLEN), mustWork = FALSE)
|
||||
|
||||
|
||||
# Helper ####
|
||||
|
||||
# Prüft anhand des labels-Attributs der ORIGINAL-Itemspalte (vor jedem Subsetting),
|
||||
# dass Rohwert 1 = "trifft gar nicht zu" und Rohwert 5 = "trifft völlig zu" ist.
|
||||
# Bricht hart ab statt still in die falsche Richtung zu rekodieren, da eine
|
||||
# vertauschte Kodierungsrichtung alle Skalensummen unbemerkt verfälschen würde.
|
||||
tas26_pruefe_kodierungsrichtung = function(spalte) {
|
||||
labels_attr = attr(spalte, "labels")
|
||||
if (is.null(labels_attr) || length(labels_attr) == 0) {
|
||||
stop("TAS-26-Item hat kein labels-Attribut, Kodierungsrichtung kann nicht geprüft werden.")
|
||||
}
|
||||
name_bei_1 = names(labels_attr)[as.vector(labels_attr) == 1]
|
||||
name_bei_5 = names(labels_attr)[as.vector(labels_attr) == 5]
|
||||
if (length(name_bei_1) == 0 || length(name_bei_5) == 0) {
|
||||
stop("TAS-26-Item: Werte 1 und/oder 5 nicht im labels-Attribut gefunden.")
|
||||
}
|
||||
if (name_bei_1[1] != "trifft gar nicht zu" || name_bei_5[1] != "trifft völlig zu") {
|
||||
stop(paste0(
|
||||
"Unerwartete Kodierungsrichtung bei TAS-26-Items: Wert 1 = '", name_bei_1[1],
|
||||
"', Wert 5 = '", name_bei_5[1], "'. Abbruch, um eine falsche Rekodierung zu vermeiden."
|
||||
))
|
||||
}
|
||||
invisible(TRUE)
|
||||
}
|
||||
|
||||
# Rekodiert (6 - Rohwert) und summiert die Items einer Skala. Bei mindestens
|
||||
# einer fehlenden Einzelantwort wird die Summe als NA ausgewiesen statt
|
||||
# stillschweigend durch Mittelwert/0 ersetzt (siehe Abschnitt 3 der Vorgabe).
|
||||
tas26_berechne_skala = function(skala_def, zeile) {
|
||||
rohwerte = sapply(skala_def$items, function(var) as.numeric(zeile[[var]][1]))
|
||||
rekodiert = ifelse(skala_def$invertiert, 6 - rohwerte, rohwerte)
|
||||
vollstaendig = !any(is.na(rekodiert))
|
||||
summe = if (vollstaendig) sum(rekodiert) else NA_real_
|
||||
list(rohwert = summe, vollstaendig = vollstaendig, item_werte = rekodiert)
|
||||
}
|
||||
|
||||
# Entfernt formr-Nummerierungsartefakte am Anfang des Itemtexts (z.B. "4. "),
|
||||
# die im label-Attribut vor dem eigentlichen Fragetext stehen (siehe Abschnitt 2.1).
|
||||
tas26_clean_item_label = function(text) {
|
||||
if (is.null(text) || length(text) == 0 || is.na(text[1])) return(NA_character_)
|
||||
sub("^\\d+[.)\\s]\\s*", "", trimws(as.character(text[1])))
|
||||
}
|
||||
|
||||
# Baut die Item-Liste einer Skala (Nummer, Text, rekodierter Wert), absteigend
|
||||
# nach Wert sortiert; Items mit fehlender Antwort (NA) stehen am Ende.
|
||||
tas26_item_liste = function(skala_def, daten_original, item_werte) {
|
||||
itemnummern = as.integer(gsub("tas26_", "", skala_def$items))
|
||||
texte = sapply(skala_def$items, function(var) tas26_clean_item_label(attr(daten_original[[var]], "label")))
|
||||
df = data.frame(nr = itemnummern, text = texte, wert = as.numeric(item_werte), stringsAsFactors = FALSE)
|
||||
df[order(df$wert, decreasing = TRUE), ]
|
||||
}
|
||||
|
||||
tas26_berechne_gesamt = function(erg_skalen) {
|
||||
vollstaendig = all(sapply(erg_skalen, function(e) e$vollstaendig))
|
||||
summe = if (vollstaendig) sum(sapply(erg_skalen, function(e) e$rohwert)) else NA_real_
|
||||
list(rohwert = summe, vollstaendig = vollstaendig)
|
||||
}
|
||||
|
||||
# Findet die passende Normtabellen-Zeile. Bei der Gesamtskala deckt die letzte
|
||||
# Zeile (RW = ">74") alle Rohwerte ab 74 ab, da die Quelle ab dort keine
|
||||
# feineren Abstufungen mehr liefert (siehe Abschnitt 4 der Vorgabe).
|
||||
tas26_normzeile = function(tabelle, rohwert, ist_gesamtskala) {
|
||||
if (is.na(rohwert)) return(NULL)
|
||||
if (isTRUE(ist_gesamtskala) && rohwert >= 74) {
|
||||
zeile = tabelle[tabelle$RW == ">74", ]
|
||||
} else {
|
||||
zeile = tabelle[tabelle$RW == as.character(rohwert), ]
|
||||
}
|
||||
if (nrow(zeile) != 1) {
|
||||
stop(paste0("Kein eindeutiger Normtabellen-Treffer für Rohwert ", rohwert, "."))
|
||||
}
|
||||
zeile
|
||||
}
|
||||
|
||||
tas26_norm_ergebnis = function(skala_def, rohwert, schulabschluss_suffix) {
|
||||
zeile_a = tas26_normzeile(skala_def$norm_a, rohwert, skala_def$ist_gesamt)
|
||||
gesamtgruppe = list(z = zeile_a$z[1], T = zeile_a$T[1], PR = zeile_a$PR[1])
|
||||
|
||||
schulabschluss = NULL
|
||||
if (!is.na(schulabschluss_suffix)) {
|
||||
zeile_b = tas26_normzeile(skala_def$norm_b, rohwert, skala_def$ist_gesamt)
|
||||
schulabschluss = list(
|
||||
z = zeile_b[[paste0("z_", schulabschluss_suffix)]][1],
|
||||
T = zeile_b[[paste0("T_", schulabschluss_suffix)]][1],
|
||||
PR = zeile_b[[paste0("PR_", schulabschluss_suffix)]][1]
|
||||
)
|
||||
}
|
||||
list(gesamtgruppe = gesamtgruppe, schulabschluss = schulabschluss)
|
||||
}
|
||||
|
||||
tas26_schulabschluss_suffix = function(label) {
|
||||
if (is.na(label)) return(NA_character_)
|
||||
switch(as.character(label),
|
||||
"Hauptschule" = "hauptschule",
|
||||
"Mittlere Reife/POS" = "mittlere_reife",
|
||||
"Abitur" = "abitur",
|
||||
NA_character_
|
||||
)
|
||||
}
|
||||
|
||||
# Normtabellenwerte enthalten Randwert-Strings wie ">80" oder "<20" (siehe
|
||||
# Abschnitt 4). Fuer die Marker-Position im Gauge wird nur das Vorzeichen
|
||||
# entfernt, die angezeigte Beschriftung bleibt der unveraenderte Originaltext.
|
||||
tas26_t_numerisch = function(t_text) {
|
||||
if (is.null(t_text) || is.na(t_text)) return(NA_real_)
|
||||
suppressWarnings(as.numeric(gsub("[<>]", "", t_text)))
|
||||
}
|
||||
|
||||
make_gauge_tas26 = function(t_text) {
|
||||
t_zahl = tas26_t_numerisch(t_text)
|
||||
|
||||
p = ggplot() +
|
||||
geom_rect(aes(xmin = 40, xmax = 60, ymin = 0, ymax = 1), fill = "#F0F0F0", color = NA) +
|
||||
geom_rect(aes(xmin = 20, xmax = 85, ymin = 0, ymax = 1), fill = NA, color = "#9E9E9E", linewidth = 0.6) +
|
||||
geom_vline(xintercept = 40, color = "#9E9E9E", linetype = "dashed", linewidth = 0.7) +
|
||||
geom_vline(xintercept = 60, color = "#9E9E9E", linetype = "dashed", linewidth = 0.7) +
|
||||
scale_x_continuous(limits = c(20, 85), breaks = c(20, 30, 40, 50, 60, 70, 80)) +
|
||||
scale_y_continuous(limits = c(-0.7, 1.6)) +
|
||||
theme_minimal(base_size = 11) +
|
||||
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.background = element_rect(fill = "white", colour = NA),
|
||||
panel.background = element_rect(fill = "white", colour = NA),
|
||||
plot.margin = margin(t = 14, r = 10, b = 20, l = 10)
|
||||
) +
|
||||
labs(x = "T-Wert", y = NULL) +
|
||||
annotate("text", x = 52.5, y = -0.55, label = TAS26_HINWEIS_T_BAND,
|
||||
color = "#777777", size = 2.9, fontface = "italic")
|
||||
|
||||
if (!is.na(t_zahl)) {
|
||||
t_geklemmt = max(20, min(85, t_zahl))
|
||||
p = p +
|
||||
geom_segment(aes(x = t_geklemmt, xend = t_geklemmt, y = -0.2, yend = 1.2),
|
||||
color = AKZENT_FARBE, linewidth = 2.2, lineend = "round") +
|
||||
annotate("text", x = t_geklemmt, y = 1.4, label = paste0("T = ", t_text),
|
||||
color = AKZENT_FARBE, fontface = "bold", size = 3.6)
|
||||
}
|
||||
p
|
||||
}
|
||||
|
||||
|
||||
# Datenaufbereitung ####
|
||||
|
||||
if (!dir.exists(PFAD_NORMTABELLEN)) {
|
||||
stop(paste0("Normtabellen-Ordner nicht gefunden: ", PFAD_NORMTABELLEN,
|
||||
". Bitte die 8 CSV-Dateien in diesen Unterordner legen."))
|
||||
}
|
||||
|
||||
TAS26_NORM_DATEIEN = list(
|
||||
a_skala1 = "norm_a1_skala1.csv", a_skala2 = "norm_a2_skala2.csv",
|
||||
a_skala3 = "norm_a3_skala3.csv", a_gesamt = "norm_a4_gesamt.csv",
|
||||
b_skala1 = "norm_b1_skala1.csv", b_skala2 = "norm_b2_skala2.csv",
|
||||
b_skala3 = "norm_b3_skala3.csv", b_gesamt = "norm_b4_gesamt.csv"
|
||||
)
|
||||
|
||||
# Alle Spalten als character einlesen, da RW/z/T/PR Randwert-Strings wie
|
||||
# ">74", ">99" oder "<20" enthalten (siehe Abschnitt 4 der Vorgabe).
|
||||
tas26_normtabellen = lapply(TAS26_NORM_DATEIEN, function(dateiname) {
|
||||
pfad = file.path(PFAD_NORMTABELLEN, dateiname)
|
||||
if (!file.exists(pfad)) stop(paste0("Normtabelle nicht gefunden: ", pfad))
|
||||
read.csv(pfad, stringsAsFactors = FALSE, colClasses = "character")
|
||||
})
|
||||
|
||||
# 18 von 26 Items werden ausgewertet. Fülleritems (nicht ausgewertet, nirgends
|
||||
# angezeigt): tas26_01, _02, _05, _06, _07, _16, _18, _19.
|
||||
TAS26_SKALEN = list(
|
||||
skala1 = list(
|
||||
bezeichnung = "Schwierigkeiten bei der Identifikation von Gefühlen",
|
||||
items = sprintf("tas26_%02d", c(4, 10, 14, 17, 20, 25, 26)),
|
||||
invertiert = rep(FALSE, 7),
|
||||
range = c(7, 35),
|
||||
norm_a = tas26_normtabellen$a_skala1,
|
||||
norm_b = tas26_normtabellen$b_skala1,
|
||||
ist_gesamt = FALSE
|
||||
),
|
||||
skala2 = list(
|
||||
bezeichnung = "Schwierigkeiten bei der Beschreibung von Gefühlen",
|
||||
items = sprintf("tas26_%02d", c(3, 8, 12, 22, 23)),
|
||||
invertiert = c(FALSE, FALSE, TRUE, FALSE, FALSE),
|
||||
range = c(5, 25),
|
||||
norm_a = tas26_normtabellen$a_skala2,
|
||||
norm_b = tas26_normtabellen$b_skala2,
|
||||
ist_gesamt = FALSE
|
||||
),
|
||||
skala3 = list(
|
||||
bezeichnung = "Extern orientierter Denkstil",
|
||||
items = sprintf("tas26_%02d", c(9, 11, 13, 15, 21, 24)),
|
||||
invertiert = rep(TRUE, 6),
|
||||
range = c(6, 30),
|
||||
norm_a = tas26_normtabellen$a_skala3,
|
||||
norm_b = tas26_normtabellen$b_skala3,
|
||||
ist_gesamt = FALSE
|
||||
)
|
||||
)
|
||||
|
||||
TAS26_GESAMT = list(
|
||||
bezeichnung = "Gesamtskala Alexithymie",
|
||||
range = c(18, 90),
|
||||
norm_a = tas26_normtabellen$a_gesamt,
|
||||
norm_b = tas26_normtabellen$b_gesamt,
|
||||
ist_gesamt = TRUE
|
||||
)
|
||||
|
||||
|
||||
# UI ####
|
||||
|
||||
app_css = "
|
||||
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; }
|
||||
.container-fluid { max-width: 1150px; }
|
||||
.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 !important; color: white !important; border: none !important;
|
||||
font-weight: 600 !important; padding: 8px 20px !important; border-radius: 4px !important;
|
||||
}
|
||||
#download_word: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; }
|
||||
.skala-block { padding: 14px 0; border-bottom: 1px solid #eee; }
|
||||
.skala-block:last-child { border-bottom: none; }
|
||||
.skala-kopf { font-weight: 700; color: #333; font-size: 1rem; margin-bottom: 8px; }
|
||||
.skala-kopf .rohwert { color: #8B2635; font-weight: 700; }
|
||||
.normwert-tabelle { width: 100%; border-collapse: collapse; margin-top: 6px; font-size: 0.9em; }
|
||||
.normwert-tabelle th, .normwert-tabelle td { text-align: left; padding: 4px 10px; border-bottom: 1px solid #f0f0f0; }
|
||||
.normwert-tabelle th { color: #555; font-weight: 600; }
|
||||
.hinweis-block { font-size: 0.82em; color: #777; font-style: italic; margin: 6px 0 4px; }
|
||||
.item-liste { margin-bottom: 10px; }
|
||||
.item-zeile {
|
||||
display: flex; align-items: flex-start; gap: 10px;
|
||||
padding: 5px 0; border-bottom: 1px solid #F5F5F5;
|
||||
}
|
||||
.item-nr { font-weight: 600; color: #8B2635; min-width: 22px; flex-shrink: 0; }
|
||||
.item-text { flex: 1; color: #333; font-size: 0.9em; }
|
||||
.item-badge {
|
||||
border-radius: 4px; padding: 2px 10px; font-weight: 700;
|
||||
font-size: 0.82em; white-space: nowrap; display: inline-block; flex-shrink: 0;
|
||||
}
|
||||
.unvollstaendig-block {
|
||||
background: #FFF3E0; border-left: 4px solid #E65100;
|
||||
padding: 8px 12px; border-radius: 4px; color: #BF360C; font-size: 0.92em;
|
||||
}
|
||||
"
|
||||
|
||||
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("TAS-26 – Toronto-Alexithymie-Skala"),
|
||||
tags$p("deutsche Version, Kupfer/Brosig/Brähler 2001")
|
||||
),
|
||||
|
||||
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_tas26_docx = function(d) {
|
||||
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("TAS-26 — Auswertung", fp_titel)))
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext("Chiffre: ", fp_label), ftext(d$chiffre, fp_normal),
|
||||
ftext(" Datum: ", fp_label), ftext(d$datum_str, fp_normal)
|
||||
))
|
||||
if (!is.null(d$info_mehrere)) {
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(d$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("Übersicht", fp_abschnitt)))
|
||||
|
||||
hole_wert = function(sk, feld, gruppe) {
|
||||
if (!sk$vollstaendig) return("-")
|
||||
if (gruppe == "schulabschluss" && is.null(sk$norm$schulabschluss)) return("-")
|
||||
sk$norm[[gruppe]][[feld]]
|
||||
}
|
||||
|
||||
tbl_df = data.frame(
|
||||
Skala = sapply(d$skalen, function(sk) sk$titel),
|
||||
Rohwert = sapply(d$skalen, function(sk) if (sk$vollstaendig) as.character(sk$rohwert) else "nicht auswertbar"),
|
||||
`T (Gesamtgruppe)` = sapply(d$skalen, function(sk) hole_wert(sk, "T", "gesamtgruppe")),
|
||||
`PR (Gesamtgruppe)` = sapply(d$skalen, function(sk) hole_wert(sk, "PR", "gesamtgruppe")),
|
||||
`T (Schulabschluss)` = sapply(d$skalen, function(sk) hole_wert(sk, "T", "schulabschluss")),
|
||||
`PR (Schulabschluss)` = sapply(d$skalen, function(sk) hole_wert(sk, "PR", "schulabschluss")),
|
||||
check.names = FALSE, stringsAsFactors = FALSE
|
||||
)
|
||||
tabellenstile_vorhanden = styles_info(doc)
|
||||
tabellenstile_vorhanden = tabellenstile_vorhanden[tabellenstile_vorhanden$style_type == "table", "style_name"]
|
||||
if ("Table Grid" %in% tabellenstile_vorhanden) {
|
||||
doc = body_add_table(doc, tbl_df, style = "Table Grid")
|
||||
} else {
|
||||
doc = body_add_table(doc, tbl_df)
|
||||
}
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext(TAS26_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.
|
||||
ergebnis_r = eventReactive(input$btn_suchen, {
|
||||
|
||||
chiffre = toupper(trimws(input$chiffre))
|
||||
|
||||
if (nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0) {
|
||||
return(list(error = "Bitte Chiffre oder Pseudonym 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)))
|
||||
}
|
||||
|
||||
res_dl = tryCatch(
|
||||
{ source(PFAD_DOWNLOAD_SKRIPT, local = FALSE); list(ok = TRUE) },
|
||||
error = function(e) list(ok = FALSE, msg = e$message)
|
||||
)
|
||||
if (!res_dl$ok) return(list(error = paste0("Fehler im Download-Skript: ", res_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
|
||||
})
|
||||
|
||||
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)
|
||||
|
||||
res_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 (!res_ps$ok) return(list(error = paste0("Fehler im Pseudonym-Skript: ", res_ps$msg)))
|
||||
|
||||
if (!exists("daten_tas26", envir = .GlobalEnv)) {
|
||||
return(list(error = "Objekt 'daten_tas26' 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 = get("daten_tas26", envir = .GlobalEnv)
|
||||
pseudo_df = get("pseudo", envir = .GlobalEnv)
|
||||
|
||||
kodierung_ok = tryCatch(
|
||||
{ tas26_pruefe_kodierungsrichtung(daten[["tas26_01"]]); list(ok = TRUE) },
|
||||
error = function(e) list(ok = FALSE, msg = e$message)
|
||||
)
|
||||
if (!kodierung_ok$ok) return(list(error = kodierung_ok$msg))
|
||||
|
||||
# Eine Chiffre kann mehrere Pseudonyme haben (eines pro Instrument/Run).
|
||||
treffer_ps = pseudo_df[pseudo_df$chiffre == chiffre, ]
|
||||
if (nrow(treffer_ps) == 0) {
|
||||
return(list(error = paste0("Chiffre '", chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden.")))
|
||||
}
|
||||
|
||||
alle_session_ids = unique(treffer_ps$pseudonym)
|
||||
if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)
|
||||
|
||||
treffer_dat = daten[daten$session %in% alle_session_ids, ]
|
||||
if (nrow(treffer_dat) == 0) {
|
||||
return(list(error = paste0(
|
||||
"Kein TAS-26-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)
|
||||
treffer_dat = treffer_dat[order(treffer_dat$created, decreasing = TRUE), ]
|
||||
datum_neu = tryCatch(
|
||||
format(as.POSIXct(treffer_dat$created[1]), "%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[1, , drop = FALSE]
|
||||
}
|
||||
|
||||
zeile = treffer_dat[1, , drop = FALSE]
|
||||
|
||||
ausfuelldatum = tryCatch(as.Date(as.POSIXct(zeile[["created"]][1])), error = function(e) Sys.Date())
|
||||
datum_str = tryCatch(format(ausfuelldatum, "%d.%m.%Y"), error = function(e) format(Sys.Date(), "%d.%m.%Y"))
|
||||
|
||||
schulabschluss_label = NA_character_
|
||||
if ("tas26_schulabschluss" %in% colnames(daten)) {
|
||||
schulabschluss_faktor = haven::as_factor(zeile[["tas26_schulabschluss"]])
|
||||
schulabschluss_label = as.character(schulabschluss_faktor[1])
|
||||
}
|
||||
schulabschluss_suffix = tas26_schulabschluss_suffix(schulabschluss_label)
|
||||
|
||||
erg_skalen_roh = lapply(TAS26_SKALEN, function(sk_def) tas26_berechne_skala(sk_def, zeile))
|
||||
erg_gesamt_roh = tas26_berechne_gesamt(erg_skalen_roh)
|
||||
|
||||
skalen = list()
|
||||
for (key in names(TAS26_SKALEN)) {
|
||||
sk_def = TAS26_SKALEN[[key]]
|
||||
roh = erg_skalen_roh[[key]]
|
||||
norm = if (roh$vollstaendig) tas26_norm_ergebnis(sk_def, roh$rohwert, schulabschluss_suffix) else NULL
|
||||
items = tas26_item_liste(sk_def, daten, roh$item_werte)
|
||||
skalen[[key]] = list(
|
||||
key = key, titel = sk_def$bezeichnung, range = sk_def$range,
|
||||
rohwert = roh$rohwert, vollstaendig = roh$vollstaendig, norm = norm, items = items
|
||||
)
|
||||
}
|
||||
norm_gesamt = if (erg_gesamt_roh$vollstaendig)
|
||||
tas26_norm_ergebnis(TAS26_GESAMT, erg_gesamt_roh$rohwert, schulabschluss_suffix) else NULL
|
||||
skalen[["gesamt"]] = list(
|
||||
key = "gesamt", titel = TAS26_GESAMT$bezeichnung, range = TAS26_GESAMT$range,
|
||||
rohwert = erg_gesamt_roh$rohwert, vollstaendig = erg_gesamt_roh$vollstaendig, norm = norm_gesamt, items = NULL
|
||||
)
|
||||
|
||||
list(
|
||||
chiffre = chiffre,
|
||||
datum_str = datum_str,
|
||||
ausfuelldatum = ausfuelldatum,
|
||||
info_mehrere = info_mehrere,
|
||||
schulabschluss_label = schulabschluss_label,
|
||||
skalen = skalen,
|
||||
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)
|
||||
|
||||
reihenfolge = c("gesamt", "skala1", "skala2", "skala3")
|
||||
skala_blocke = lapply(d$skalen[reihenfolge], function(sk) {
|
||||
div(class = "skala-block",
|
||||
div(class = "skala-kopf",
|
||||
paste0(sk$titel, " — Rohwert "),
|
||||
if (sk$vollstaendig)
|
||||
span(class = "rohwert", paste0(sk$rohwert, " von ", sk$range[1], "–", sk$range[2]))
|
||||
else
|
||||
span(class = "rohwert", "nicht auswertbar")
|
||||
),
|
||||
if (!sk$vollstaendig) {
|
||||
div(class = "unvollstaendig-block", "Skala nicht vollständig beantwortet, keine Auswertung möglich.")
|
||||
} else {
|
||||
tagList(
|
||||
plotOutput(paste0("gauge_", sk$key), height = "150px"),
|
||||
tags$table(class = "normwert-tabelle",
|
||||
tags$tr(tags$th(""), tags$th("z-Wert"), tags$th("T-Wert"), tags$th("Prozentrang")),
|
||||
tags$tr(
|
||||
tags$td("Gesamtgruppe"),
|
||||
tags$td(sk$norm$gesamtgruppe$z), tags$td(sk$norm$gesamtgruppe$T), tags$td(sk$norm$gesamtgruppe$PR)
|
||||
),
|
||||
if (!is.null(sk$norm$schulabschluss))
|
||||
tags$tr(
|
||||
tags$td("Schulabschluss-differenziert"),
|
||||
tags$td(sk$norm$schulabschluss$z), tags$td(sk$norm$schulabschluss$T), tags$td(sk$norm$schulabschluss$PR)
|
||||
)
|
||||
),
|
||||
if (is.null(sk$norm$schulabschluss))
|
||||
div(class = "hinweis-block", TAS26_HINWEIS_SCHULABSCHLUSS_FEHLT)
|
||||
)
|
||||
},
|
||||
if (!is.null(sk$items)) {
|
||||
div(class = "item-liste",
|
||||
lapply(seq_len(nrow(sk$items)), function(i) {
|
||||
zeile_item = sk$items[i, ]
|
||||
wert_key = if (!is.na(zeile_item$wert)) as.character(zeile_item$wert) else NA_character_
|
||||
bg_farbe = if (!is.na(wert_key)) TAS26_BADGE_FARBEN[[wert_key]] else "#E0E0E0"
|
||||
txt_farbe = if (!is.na(wert_key)) TAS26_BADGE_TEXT_FARBEN[[wert_key]] else "#666666"
|
||||
div(class = "item-zeile",
|
||||
div(class = "item-nr", paste0(zeile_item$nr, ".")),
|
||||
div(class = "item-text", if (!is.na(zeile_item$text)) zeile_item$text else paste0("Item ", zeile_item$nr)),
|
||||
span(class = "item-badge",
|
||||
style = paste0("background:", bg_farbe, "; color:", txt_farbe, ";"),
|
||||
if (!is.na(zeile_item$wert)) zeile_item$wert else "k. A.")
|
||||
)
|
||||
})
|
||||
)
|
||||
}
|
||||
)
|
||||
})
|
||||
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "TAS-26 Auswertung"),
|
||||
div(class = "meta-block",
|
||||
tags$strong("Chiffre: "), d$chiffre,
|
||||
tags$span(" | ", style = "color:#ccc;"),
|
||||
tags$strong("Ausfülldatum: "), d$datum_str
|
||||
),
|
||||
tags$hr(),
|
||||
skala_blocke
|
||||
)
|
||||
})
|
||||
|
||||
for (sk_key in c(names(TAS26_SKALEN), "gesamt")) {
|
||||
local({
|
||||
key_lokal = sk_key
|
||||
output[[paste0("gauge_", key_lokal)]] = renderPlot({
|
||||
d = ergebnis_r()
|
||||
req(is.null(d$error))
|
||||
e = d$skalen[[key_lokal]]
|
||||
req(e$vollstaendig)
|
||||
make_gauge_tas26(e$norm$gesamtgruppe$T)
|
||||
}, bg = "transparent")
|
||||
})
|
||||
}
|
||||
|
||||
output$download_word = downloadHandler(
|
||||
filename = function() {
|
||||
d = tryCatch(ergebnis_r(), error = function(e) NULL)
|
||||
chiffre = if (is.list(d) && is.null(d$error) && nchar(d$chiffre) > 0) d$chiffre else "export"
|
||||
datum = if (is.list(d) && is.null(d$error) && !is.null(d$ausfuelldatum))
|
||||
tryCatch(format(d$ausfuelldatum, "%Y%m%d"), error = function(e) format(Sys.Date(), "%Y%m%d"))
|
||||
else
|
||||
format(Sys.Date(), "%Y%m%d")
|
||||
paste0("TAS26_", chiffre, "_", datum, ".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 oder Pseudonym eingeben und 'Auswerten' klicken.",
|
||||
style = "Normal")
|
||||
print(doc, target = file)
|
||||
return()
|
||||
}
|
||||
doc = tryCatch(
|
||||
erstelle_tas26_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)
|
||||
Loading…
Add table
Add a link
Reference in a new issue