1220 lines
50 KiB
R
1220 lines
50 KiB
R
# Präambel ####
|
||
|
||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_ist_screening_a.R" # liefert: daten_ist_screening_a
|
||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo
|
||
AKZENT_FARBE = "#8B2635"
|
||
PFAD_NORMTABELLEN = "normtabellen"
|
||
|
||
IST_DISCLAIMER = paste0(
|
||
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
|
||
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ",
|
||
"Die Testsituation der digitalen Selbstausfuellung entspricht nicht der im Manual ",
|
||
"beschriebenen testleiter-administrierten Gruppentestung."
|
||
)
|
||
|
||
# --- Lösungsschlüssel Testheft A (Teil des App-Codes, NICHT der formr-xlsx) ----
|
||
|
||
# Analogien (Items 1-20): Vergleich ueber den Choice-TEXT im labels-Attribut,
|
||
# nie ueber den 1-5-Index. Wortlaut exakt wie in der xlsx.
|
||
IST_A_ANALOGIEN_LOESUNG = c(
|
||
"nein", "Mut", "Unterseeboot", "laufen", "Verachtung",
|
||
"Nagel", "riechen", "landen", "Kugel", "Trommel",
|
||
"hart", "extrem", "Dichte", "Schirm", "hüpfen",
|
||
"beherzt", "Lob", "Kohle", "Versöhnung", "Gewinn"
|
||
)
|
||
|
||
# Zahlenreihen (Items 21-40): direkter Zahlenvergleich.
|
||
IST_A_ZAHLENREIHEN_LOESUNG = c(
|
||
30, 8, 27, 12, 25, 47, 19, 20, 13, 20,
|
||
35, 13, 9, 10, 38, 21, 10, 63, 16, 156
|
||
)
|
||
|
||
# Matrizen (Items 41-60): Vergleich ueber das alt-Attribut der Bild-Choice
|
||
# (alt="a" ... alt="e"), nie ueber den 1-5-Index.
|
||
IST_A_MATRIZEN_LOESUNG = c(
|
||
"c", "c", "a", "b", "a", "d", "b", "b", "c", "a",
|
||
"c", "c", "d", "a", "a", "d", "a", "b", "b", "e"
|
||
)
|
||
|
||
# --- SW-Luecke unter 70 (vom Nutzer fachlich festgelegt, zentral aenderbar) ----
|
||
SW_A13_MINIMUM = 70
|
||
IST_IQ_UNTER_MINIMUM_TEXT = "< 55"
|
||
IST_PR_UNTER_MINIMUM = 0
|
||
|
||
# Menschenlesbare Bezeichnung der Normgruppen (Dateikuerzel -> Text).
|
||
IST_NORM_LABEL = c(
|
||
A1 = "Gymnasiasten, 15-16 Jahre",
|
||
A2 = "Gymnasiasten, 17-18 Jahre",
|
||
A3 = "Gymnasiasten, 19-20 Jahre",
|
||
A4 = "Gymnasiasten, 21-25 Jahre",
|
||
A5 = "Gymnasiasten, 26-30 Jahre",
|
||
A6 = "Nicht-Gymnasiasten, 15-20 Jahre",
|
||
A7 = "Nicht-Gymnasiasten, 21-25 Jahre",
|
||
A8 = "Nicht-Gymnasiasten, 26-30 Jahre",
|
||
A9 = "Gesamtgruppe (ohne Schulform), 15-20 Jahre",
|
||
A10 = "Gesamtgruppe (ohne Schulform), 21-25 Jahre",
|
||
A11 = "Gesamtgruppe (ohne Schulform), 26-30 Jahre",
|
||
A12 = "Gesamtstichprobe (ohne Alters-/Schulformdifferenzierung)"
|
||
)
|
||
|
||
IST_HINWEIS_A13_UNTERTESTS = paste0(
|
||
"Prozentrang und IQ werden hier auch auf die drei Untertest-Standardwerte ",
|
||
"angewendet. Ob Tabelle A13 dafuer gedacht ist, ist nicht explizit im Manual ",
|
||
"belegt, sondern aus der linearen SW->IQ-Transformation abgeleitet ",
|
||
"(Interpretationsfreiheit, keine gesicherte Manual-Aussage)."
|
||
)
|
||
IST_HINWEIS_SW_UNTER_70 = paste0(
|
||
"Tabelle A13 beginnt bei Standardwert 70. Fuer niedrigere Standardwerte zeigt ",
|
||
"die App IQ \"", IST_IQ_UNTER_MINIMUM_TEXT, "\" und Prozentrang ",
|
||
IST_PR_UNTER_MINIMUM, " (Bodenwert). Der Standardwert selbst wird normal ",
|
||
"ausgewiesen. Bewusst festgelegte Konvention, keine Manual-Aussage."
|
||
)
|
||
IST_HINWEIS_KODIERUNG = paste0(
|
||
"Die Zuordnung der mc-/mc_button-Antworten erfolgt textbasiert ueber das ",
|
||
"labels-Attribut (Analogien: Antworttext, Matrizen: alt-Attribut der Bild-Choice), ",
|
||
"nicht ueber den 1-5-Index. Der ausklappbare Rohdaten-Check in der App zeigt fuer ",
|
||
"je drei Analogie- und Matrizen-Items den gespeicherten Rohwert und das komplette ",
|
||
"labels-Attribut, damit vor Nutzung der Auswertung manuell verifiziert werden kann, ",
|
||
"dass das Text-Matching greift."
|
||
)
|
||
|
||
library(shiny)
|
||
library(dplyr)
|
||
library(ggplot2)
|
||
library(haven)
|
||
library(officer)
|
||
library(DBI)
|
||
library(RSQLite)
|
||
|
||
|
||
# Infrastruktur ####
|
||
|
||
APP_VERZEICHNIS = normalizePath(getwd())
|
||
|
||
absPath = function(pfad) {
|
||
if (grepl("^([A-Za-z]:[/\\\\]|/)", pfad)) return(pfad)
|
||
file.path(APP_VERZEICHNIS, pfad)
|
||
}
|
||
|
||
PFAD_DOWNLOAD_SKRIPT = normalizePath(absPath(PFAD_DOWNLOAD_SKRIPT), mustWork = FALSE)
|
||
PFAD_PSEUDONYM_SKRIPT = normalizePath(absPath(PFAD_PSEUDONYM_SKRIPT), mustWork = FALSE)
|
||
PFAD_NORMTABELLEN = normalizePath(absPath(PFAD_NORMTABELLEN), mustWork = FALSE)
|
||
|
||
|
||
# Helper ####
|
||
|
||
ist_col = function(i) sprintf("ist_a_%02d", i)
|
||
|
||
# Erste vorhandene Spalte aus einer Prioritaetenliste. NA_character_, wenn keine
|
||
# passt (dann bricht die Auswertung mit klarer Meldung ab).
|
||
ist_finde_spalte = function(df, kandidaten) {
|
||
vorhanden = kandidaten[kandidaten %in% names(df)]
|
||
if (length(vorhanden) == 0) return(NA_character_)
|
||
vorhanden[1]
|
||
}
|
||
|
||
# Analogie-Item: Vergleich ueber den Choice-TEXT im labels-Attribut der
|
||
# Original-Spalte. Kein Treffer im labels-Attribut -> "nicht auswertbar"
|
||
# (kein stiller Rueckfall auf Index-Vergleich).
|
||
ist_pruefe_analogie = function(spalte_original, wert, korrekter_text) {
|
||
labels_attr = attr(spalte_original, "labels")
|
||
if (is.null(labels_attr) || length(labels_attr) == 0) {
|
||
return(list(status = "nicht_auswertbar", richtig = FALSE,
|
||
grund = "kein labels-Attribut", gegeben = NA_real_, korrekter_code = NA_real_))
|
||
}
|
||
namen = names(labels_attr)
|
||
pos = which(namen == korrekter_text)
|
||
if (length(pos) == 0) pos = which(trimws(namen) == trimws(korrekter_text))
|
||
if (length(pos) == 0) {
|
||
return(list(status = "nicht_auswertbar", richtig = FALSE,
|
||
grund = paste0("Choice-Text '", korrekter_text, "' nicht im labels-Attribut"),
|
||
gegeben = suppressWarnings(as.numeric(wert[1])), korrekter_code = NA_real_))
|
||
}
|
||
korrekter_code = suppressWarnings(as.numeric(labels_attr[pos[1]]))
|
||
gegeben = suppressWarnings(as.numeric(wert[1]))
|
||
richtig = !is.na(gegeben) && !is.na(korrekter_code) && gegeben == korrekter_code
|
||
list(status = "ok", richtig = isTRUE(richtig),
|
||
gegeben = gegeben, korrekter_code = korrekter_code)
|
||
}
|
||
|
||
# Zahlenreihen-Item: direkter Zahlenvergleich (number-Feld ggf. als String).
|
||
ist_pruefe_zahlenreihe = function(wert, korrekte_zahl) {
|
||
gegeben = suppressWarnings(as.numeric(wert[1]))
|
||
richtig = !is.na(gegeben) && gegeben == as.numeric(korrekte_zahl)
|
||
list(status = "ok", richtig = isTRUE(richtig),
|
||
gegeben = gegeben, korrekter_code = as.numeric(korrekte_zahl))
|
||
}
|
||
|
||
# Matrizen-Item: Buchstabe->Code-Zuordnung aus den <img alt="x">-Choice-Labels
|
||
# der Original-Spalte aufbauen, dann ueber den Buchstaben vergleichen. Kein
|
||
# alt-Attribut gefunden -> "nicht auswertbar" (kein Rueckfall auf Index).
|
||
ist_pruefe_matrix = function(spalte_original, wert, korrekter_buchstabe) {
|
||
labels_attr = attr(spalte_original, "labels")
|
||
if (is.null(labels_attr) || length(labels_attr) == 0) {
|
||
return(list(status = "nicht_auswertbar", richtig = FALSE,
|
||
grund = "kein labels-Attribut", gegeben = NA_real_, korrekter_code = NA_real_))
|
||
}
|
||
namen = names(labels_attr)
|
||
mapping = list()
|
||
for (i in seq_along(namen)) {
|
||
m = regmatches(namen[i], regexec('alt=["\']([a-eA-E])["\']', namen[i]))[[1]]
|
||
if (length(m) == 2) mapping[[tolower(m[2])]] = suppressWarnings(as.numeric(labels_attr[i]))
|
||
}
|
||
if (length(mapping) == 0) {
|
||
return(list(status = "nicht_auswertbar", richtig = FALSE,
|
||
grund = "kein alt-Attribut in den Choice-Labels",
|
||
gegeben = suppressWarnings(as.numeric(wert[1])), korrekter_code = NA_real_))
|
||
}
|
||
korrekter_code = mapping[[tolower(korrekter_buchstabe)]]
|
||
if (is.null(korrekter_code) || is.na(korrekter_code)) {
|
||
return(list(status = "nicht_auswertbar", richtig = FALSE,
|
||
grund = paste0("Buchstabe '", korrekter_buchstabe, "' nicht in der Zuordnung"),
|
||
gegeben = suppressWarnings(as.numeric(wert[1])), korrekter_code = NA_real_))
|
||
}
|
||
gegeben = suppressWarnings(as.numeric(wert[1]))
|
||
richtig = !is.na(gegeben) && gegeben == korrekter_code
|
||
list(status = "ok", richtig = isTRUE(richtig),
|
||
gegeben = gegeben, korrekter_code = korrekter_code)
|
||
}
|
||
|
||
# Untertest-SW: exakter Rohwert-Match in einer rw_X/sw_X-Spalte (RW 0-20).
|
||
ist_sw_untertest = function(tab, rw_spalte, sw_spalte, rohwert) {
|
||
if (is.null(tab) || !(rw_spalte %in% names(tab)) || !(sw_spalte %in% names(tab))) return(NA_real_)
|
||
zeile = tab[suppressWarnings(as.numeric(tab[[rw_spalte]])) == rohwert, , drop = FALSE]
|
||
if (nrow(zeile) == 0) return(NA_real_)
|
||
suppressWarnings(as.numeric(zeile[[sw_spalte]][1]))
|
||
}
|
||
|
||
# Gesamtwert-SW: Rohwert 0-60 in einen Klassen-String ("58-60") einordnen.
|
||
# Einzelwerte koennen als "n" oder als "n-n" (von == bis) vorkommen.
|
||
ist_sw_gesamt = function(tab, rw_spalte, sw_spalte, rohwert) {
|
||
if (is.null(tab) || !(rw_spalte %in% names(tab)) || !(sw_spalte %in% names(tab))) return(NA_real_)
|
||
klassen = as.character(tab[[rw_spalte]])
|
||
for (i in seq_along(klassen)) {
|
||
k = trimws(klassen[i])
|
||
m = regmatches(k, regexec("^([0-9]+)\\s*-\\s*([0-9]+)$", k))[[1]]
|
||
if (length(m) == 3) {
|
||
von = as.numeric(m[2]); bis = as.numeric(m[3])
|
||
if (!is.na(von) && !is.na(bis) && rohwert >= von && rohwert <= bis) {
|
||
return(suppressWarnings(as.numeric(tab[[sw_spalte]][i])))
|
||
}
|
||
} else {
|
||
einzel = suppressWarnings(as.numeric(k))
|
||
if (!is.na(einzel) && rohwert == einzel) {
|
||
return(suppressWarnings(as.numeric(tab[[sw_spalte]][i])))
|
||
}
|
||
}
|
||
}
|
||
NA_real_
|
||
}
|
||
|
||
ist_iq_anzeige = function(x) {
|
||
if (is.null(x) || length(x) == 0 || is.na(x)) return(NA_character_)
|
||
sub(".", ",", sprintf("%.2f", x), fixed = TRUE)
|
||
}
|
||
|
||
# A13: Standardwert -> Prozentrang / IQ. Unterhalb SW 70 gilt die festgelegte
|
||
# Konvention (IQ-Text "< 55", PR 0). Oberhalb des tabellierten Bereichs: n. t.
|
||
ist_pr_iq_von_sw = function(a13, sw) {
|
||
if (is.null(sw) || length(sw) == 0 || is.na(sw)) {
|
||
return(list(pr = NA_character_, iq = NA_character_, unter_minimum = FALSE, ausserhalb = FALSE))
|
||
}
|
||
if (sw < SW_A13_MINIMUM) {
|
||
return(list(pr = as.character(IST_PR_UNTER_MINIMUM), iq = IST_IQ_UNTER_MINIMUM_TEXT,
|
||
unter_minimum = TRUE, ausserhalb = FALSE))
|
||
}
|
||
zeile = a13[a13$sw == round(sw), , drop = FALSE]
|
||
if (nrow(zeile) == 0) {
|
||
return(list(pr = NA_character_, iq = NA_character_, unter_minimum = FALSE, ausserhalb = TRUE))
|
||
}
|
||
list(pr = as.character(zeile$pr[1]), iq = ist_iq_anzeige(zeile$iq_num[1]),
|
||
unter_minimum = FALSE, ausserhalb = FALSE)
|
||
}
|
||
|
||
# Primaere schulform-spezifische Normtabelle (Dateikuerzel) oder NULL.
|
||
ist_primaere_tabelle = function(schulform_gruppe, alter) {
|
||
if (is.na(schulform_gruppe) || is.na(alter) || alter < 15 || alter > 30) return(NULL)
|
||
if (schulform_gruppe == "Gymnasiasten") {
|
||
if (alter <= 16) return("A1")
|
||
if (alter <= 18) return("A2")
|
||
if (alter <= 20) return("A3")
|
||
if (alter <= 25) return("A4")
|
||
return("A5")
|
||
}
|
||
if (alter <= 20) return("A6")
|
||
if (alter <= 25) return("A7")
|
||
return("A8")
|
||
}
|
||
|
||
# Schulform-unabhaengige Gesamtgruppen-Norm (A9-A11) oder NULL.
|
||
ist_gesamtgruppe_tabelle = function(alter) {
|
||
if (is.na(alter) || alter < 15 || alter > 30) return(NULL)
|
||
if (alter <= 20) return("A9")
|
||
if (alter <= 25) return("A10")
|
||
return("A11")
|
||
}
|
||
|
||
# Ein Normblock: SW je Komponente plus PR/IQ (A13) je Komponente.
|
||
ist_berechne_normblock = function(tab_key, rw_ana, rw_zr, rw_mat, rw_ges,
|
||
nur_gesamt = FALSE) {
|
||
tab = ist_normtabellen[[tab_key]]
|
||
a13 = ist_normtabellen$A13
|
||
res = list(tab_key = tab_key, label = unname(IST_NORM_LABEL[tab_key]))
|
||
sw_g = ist_sw_gesamt(tab, "rw_gesamtwert", "sw_gesamtwert", rw_ges)
|
||
res$gesamt = c(list(rw = rw_ges, sw = sw_g), ist_pr_iq_von_sw(a13, sw_g))
|
||
if (nur_gesamt) return(res)
|
||
sw_a = ist_sw_untertest(tab, "rw_analogien", "sw_analogien", rw_ana)
|
||
sw_z = ist_sw_untertest(tab, "rw_zahlenreihen", "sw_zahlenreihen", rw_zr)
|
||
sw_m = ist_sw_untertest(tab, "rw_matrizen", "sw_matrizen", rw_mat)
|
||
res$analogien = c(list(rw = rw_ana, sw = sw_a), ist_pr_iq_von_sw(a13, sw_a))
|
||
res$zahlenreihen = c(list(rw = rw_zr, sw = sw_z), ist_pr_iq_von_sw(a13, sw_z))
|
||
res$matrizen = c(list(rw = rw_mat, sw = sw_m), ist_pr_iq_von_sw(a13, sw_m))
|
||
res
|
||
}
|
||
|
||
ist_oder_strich = function(x) {
|
||
if (is.null(x) || length(x) == 0 || is.na(x)) return("–")
|
||
as.character(x)
|
||
}
|
||
|
||
# PR-/IQ-Anzeigetext einer Komponente (beruecksichtigt Boden-/Randfaelle).
|
||
ist_pr_text = function(comp) {
|
||
if (isTRUE(comp$ausserhalb)) return("n. t.")
|
||
if (is.null(comp$pr) || is.na(comp$pr)) return("–")
|
||
as.character(comp$pr)
|
||
}
|
||
ist_iq_text = function(comp) {
|
||
if (isTRUE(comp$ausserhalb)) return("n. t.")
|
||
if (is.null(comp$iq) || is.na(comp$iq)) return("–")
|
||
as.character(comp$iq)
|
||
}
|
||
|
||
|
||
# Datenaufbereitung ####
|
||
|
||
IST_NORM_DATEIEN = c(
|
||
A1 = "A1_gymnasiasten_15-16.csv",
|
||
A2 = "A2_gymnasiasten_17-18.csv",
|
||
A3 = "A3_gymnasiasten_19-20.csv",
|
||
A4 = "A4_gymnasiasten_21-25.csv",
|
||
A5 = "A5_gymnasiasten_26-30.csv",
|
||
A6 = "A6_nicht_gymnasiasten_15-20.csv",
|
||
A7 = "A7_nicht_gymnasiasten_21-25.csv",
|
||
A8 = "A8_nicht_gymnasiasten_26-30.csv",
|
||
A9 = "A9_gesamtgruppe_15-20.csv",
|
||
A10 = "A10_gesamtgruppe_21-25.csv",
|
||
A11 = "A11_gesamtgruppe_26-30.csv",
|
||
A12 = "A12_gesamtwert_gesamtgruppe.csv",
|
||
A13 = "tabelle_A13_standardwert_prozentrang_iq.csv"
|
||
)
|
||
|
||
IST_SPALTEN_A1_11 = c(
|
||
"rw_analogien", "sw_analogien", "rw_zahlenreihen", "sw_zahlenreihen",
|
||
"rw_matrizen", "sw_matrizen", "rw_gesamtwert", "sw_gesamtwert"
|
||
)
|
||
|
||
if (!dir.exists(PFAD_NORMTABELLEN)) {
|
||
stop(paste0(
|
||
"Normtabellen-Ordner nicht gefunden: ", PFAD_NORMTABELLEN,
|
||
"\nBitte den Unterordner 'normtabellen/' mit den 13 CSV-Dateien neben app.R ablegen."))
|
||
}
|
||
|
||
ist_normtabellen = list()
|
||
for (key in names(IST_NORM_DATEIEN)) {
|
||
pfad = file.path(PFAD_NORMTABELLEN, IST_NORM_DATEIEN[[key]])
|
||
if (!file.exists(pfad)) {
|
||
stop(paste0(
|
||
"Normtabelle nicht gefunden: ", pfad,
|
||
"\nDie 13 Normtabellen-CSVs (A1-A13) muessen vom Nutzer bereitgestellt werden ",
|
||
"und sind nicht Teil der App."))
|
||
}
|
||
tab = tryCatch(
|
||
read.csv(pfad, stringsAsFactors = FALSE, na.strings = c("", "NA"),
|
||
fileEncoding = "UTF-8", check.names = FALSE),
|
||
error = function(e) stop(paste0("Fehler beim Einlesen von '", IST_NORM_DATEIEN[[key]],
|
||
"': ", e$message))
|
||
)
|
||
ist_normtabellen[[key]] = tab
|
||
}
|
||
|
||
for (key in c(paste0("A", 1:11))) {
|
||
fehlend = setdiff(IST_SPALTEN_A1_11, names(ist_normtabellen[[key]]))
|
||
if (length(fehlend) > 0) {
|
||
stop(paste0("Normtabelle '", IST_NORM_DATEIEN[[key]], "' fehlt Spalte(n): ",
|
||
paste(fehlend, collapse = ", ")))
|
||
}
|
||
}
|
||
if (!all(c("rw_gesamtwert", "sw_gesamtwert") %in% names(ist_normtabellen$A12))) {
|
||
stop(paste0("Normtabelle '", IST_NORM_DATEIEN[["A12"]],
|
||
"' braucht die Spalten rw_gesamtwert und sw_gesamtwert."))
|
||
}
|
||
if (!all(c("sw", "iq", "pr") %in% names(ist_normtabellen$A13))) {
|
||
stop(paste0("Normtabelle '", IST_NORM_DATEIEN[["A13"]],
|
||
"' braucht die Spalten sw, iq und pr."))
|
||
}
|
||
|
||
# A13: iq ist ein String mit Komma als Dezimaltrennzeichen ("101,50").
|
||
ist_normtabellen$A13$sw = suppressWarnings(as.numeric(ist_normtabellen$A13$sw))
|
||
ist_normtabellen$A13$pr = suppressWarnings(as.integer(ist_normtabellen$A13$pr))
|
||
ist_normtabellen$A13$iq_num = suppressWarnings(as.numeric(gsub(",", ".", ist_normtabellen$A13$iq)))
|
||
|
||
|
||
# UI ####
|
||
|
||
app_css = "
|
||
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; }
|
||
.container-fluid { max-width: 1100px; }
|
||
.app-header {
|
||
background: #8B2635; color: white; padding: 18px 24px 14px;
|
||
margin-bottom: 20px; border-radius: 0 0 6px 6px;
|
||
}
|
||
.app-header h2 { margin: 0; font-size: 1.5rem; font-weight: 600; }
|
||
.app-header p { margin: 4px 0 0; opacity: 0.85; font-size: 0.9rem; }
|
||
.input-panel {
|
||
background: white; border-radius: 6px; padding: 16px 20px;
|
||
margin-bottom: 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12);
|
||
display: flex; align-items: flex-end; gap: 12px; flex-wrap: wrap;
|
||
}
|
||
.input-panel .form-group { margin-bottom: 0; }
|
||
.input-panel label { font-weight: 600; color: #333; }
|
||
.btn-laden {
|
||
background: #8B2635 !important; color: white !important;
|
||
border: none !important; border-radius: 4px !important;
|
||
padding: 8px 20px !important; font-weight: 600 !important; cursor: pointer;
|
||
}
|
||
.btn-laden:hover { background: #6d1e29 !important; }
|
||
.alert-fehler {
|
||
background: #FFEBEE; border-left: 5px solid #C62828;
|
||
padding: 12px 16px; border-radius: 4px; color: #B71C1C;
|
||
margin-bottom: 12px; font-weight: 500; white-space: pre-wrap;
|
||
}
|
||
.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; }
|
||
.hinweis-block {
|
||
font-size: 0.86em; color: #777; font-style: italic; margin: 8px 0 12px;
|
||
}
|
||
.norm-tabelle { width: 100%; border-collapse: collapse; margin: 6px 0 4px; }
|
||
.norm-tabelle th, .norm-tabelle td {
|
||
border: 1px solid #E0E0E0; padding: 7px 12px; text-align: center; font-size: 0.95em;
|
||
}
|
||
.norm-tabelle th { background: #F5F5F5; color: #333; font-weight: 700; }
|
||
.norm-tabelle td:first-child, .norm-tabelle th:first-child { text-align: left; }
|
||
.norm-tabelle tr.gesamt-zeile td { font-weight: 700; background: #FAF3F4; }
|
||
.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: 46px; flex-shrink: 0; }
|
||
.item-text { flex: 1; color: #333; font-size: 0.9em; }
|
||
.rohcheck-box {
|
||
background: #FAFAFA; border: 1px solid #E0E0E0; border-radius: 4px;
|
||
padding: 8px 12px; margin: 6px 0; font-family: 'Consolas', monospace;
|
||
font-size: 0.8em; color: #444; white-space: pre-wrap; word-break: break-all;
|
||
}
|
||
details.rohcheck { margin-top: 8px; }
|
||
details.rohcheck > summary {
|
||
cursor: pointer; font-weight: 600; color: #8B2635; font-size: 0.9em;
|
||
}
|
||
"
|
||
|
||
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("IST-Screening Testheft A – Auswertung"),
|
||
tags$p("Intelligenz-Struktur-Test Screening (Hogrefe) | Liepmann/Beauducel/Brocke/Nettelnstroth | Einzelfall-Auswertung")
|
||
),
|
||
|
||
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_ist_screening_a_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_warnung = fp_text(font.size = 10, italic = TRUE, color = "#BF360C")
|
||
fp_hinweis = fp_text(font.size = 9, italic = TRUE, color = "#777777")
|
||
|
||
norm_tabelle_df = function(block) {
|
||
max_rw = c(20, 20, 20, 60)
|
||
data.frame(
|
||
Bereich = c("Analogien", "Zahlenreihen", "Matrizen", "Gesamtwert"),
|
||
RW = sprintf("%s / %d",
|
||
c(block$analogien$rw, block$zahlenreihen$rw, block$matrizen$rw, block$gesamt$rw),
|
||
max_rw),
|
||
SW = c(ist_oder_strich(block$analogien$sw), ist_oder_strich(block$zahlenreihen$sw),
|
||
ist_oder_strich(block$matrizen$sw), ist_oder_strich(block$gesamt$sw)),
|
||
PR = c(ist_pr_text(block$analogien), ist_pr_text(block$zahlenreihen),
|
||
ist_pr_text(block$matrizen), ist_pr_text(block$gesamt)),
|
||
IQ = c(ist_iq_text(block$analogien), ist_iq_text(block$zahlenreihen),
|
||
ist_iq_text(block$matrizen), ist_iq_text(block$gesamt)),
|
||
check.names = FALSE, stringsAsFactors = FALSE
|
||
)
|
||
}
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("IST-Screening Testheft A – Auswertung", fp_titel)))
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext("Chiffre: ", fp_label), ftext(erg$chiffre, fp_normal),
|
||
ftext(" Ausfuelldatum: ", fp_label), ftext(erg$ausfuelldatum, fp_normal)
|
||
))
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext("Alter: ", fp_label),
|
||
ftext(if (is.na(erg$alter)) "k. A." else as.character(erg$alter), fp_normal),
|
||
ftext(" Schulform: ", fp_label),
|
||
ftext(if (is.na(erg$schulform_text)) "k. A." else erg$schulform_text, fp_normal)
|
||
))
|
||
if (!is.null(erg$mehrfach_warnung)) {
|
||
doc = body_add_fpar(doc, fpar(ftext(
|
||
paste0("Mehrere Ausfuellungen gefunden (", erg$mehrfach_warnung$n,
|
||
" Eintraege), angezeigt wird die neueste."), fp_warnung)))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Primaere Norm", fp_abschnitt)))
|
||
if (is.null(erg$norm_primaer)) {
|
||
doc = body_add_fpar(doc, fpar(ftext(erg$norm_primaer_grund, fp_warnung)))
|
||
roh_df = data.frame(
|
||
Bereich = c("Analogien", "Zahlenreihen", "Matrizen", "Gesamtwert"),
|
||
RW = sprintf("%s / %d",
|
||
c(erg$rw_analogien, erg$rw_zahlenreihen, erg$rw_matrizen, erg$rw_gesamt),
|
||
c(20, 20, 20, 60)),
|
||
check.names = FALSE, stringsAsFactors = FALSE
|
||
)
|
||
doc = body_add_table(doc, roh_df, style = "table_template")
|
||
} else {
|
||
doc = body_add_fpar(doc, fpar(ftext(paste0("Normgruppe: ", erg$norm_primaer$label), fp_normal)))
|
||
doc = body_add_table(doc, norm_tabelle_df(erg$norm_primaer), style = "table_template")
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Zusatzangabe: Gesamtgruppe (ohne Schulform)", fp_abschnitt)))
|
||
if (is.null(erg$norm_gesamtgruppe)) {
|
||
doc = body_add_fpar(doc, fpar(ftext(
|
||
"Nicht verfuegbar (Alter ausserhalb 15-30 Jahre oder fehlend).", fp_warnung)))
|
||
} else {
|
||
doc = body_add_fpar(doc, fpar(ftext(paste0("Normgruppe: ", erg$norm_gesamtgruppe$label), fp_normal)))
|
||
doc = body_add_table(doc, norm_tabelle_df(erg$norm_gesamtgruppe), style = "table_template")
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Zusatzangabe: Gesamtstichprobe (Gesamtwert, Tabelle A12)", fp_abschnitt)))
|
||
g12 = erg$norm_a12$gesamt
|
||
doc = body_add_fpar(doc, fpar(
|
||
ftext("Gesamtwert: ", fp_label),
|
||
ftext(sprintf("RW %d / 60 SW %s PR %s IQ %s",
|
||
g12$rw, ist_oder_strich(g12$sw), ist_pr_text(g12), ist_iq_text(g12)), fp_normal)
|
||
))
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext("Technische Hinweise", fp_abschnitt)))
|
||
for (h in erg$tech_hinweise) {
|
||
doc = body_add_fpar(doc, fpar(ftext(h, fp_hinweis)))
|
||
}
|
||
doc = body_add_par(doc, "", style = "Normal")
|
||
|
||
doc = body_add_fpar(doc, fpar(ftext(IST_DISCLAIMER, fp_hinweis)))
|
||
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))
|
||
pseudonym_eingabe = trimws(input$pseudonym)
|
||
|
||
# 1. Leere Eingabe
|
||
if (nchar(pseudonym_eingabe) == 0 && nchar(chiffre) == 0) {
|
||
return(list(typ = "leere_eingabe",
|
||
meldung = "Bitte Chiffre oder Pseudonym eingeben."))
|
||
}
|
||
if (nchar(pseudonym_eingabe) == 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).")))
|
||
}
|
||
|
||
# 2. Skriptpfade
|
||
fehlende_skripte = c(
|
||
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) PFAD_DOWNLOAD_SKRIPT,
|
||
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) PFAD_PSEUDONYM_SKRIPT
|
||
)
|
||
if (length(fehlende_skripte) > 0) {
|
||
return(list(typ = "pfad_fehler",
|
||
meldung = paste0("Skript(e) nicht gefunden:\n", paste(fehlende_skripte, collapse = "\n"))))
|
||
}
|
||
|
||
# 3. Download-Skript sourcen
|
||
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 = paste0("Fehler im Download-Skript: ", ok_dl$msg)))
|
||
}
|
||
|
||
# 4. daten_ist_screening_a vorhanden?
|
||
if (!exists("daten_ist_screening_a", envir = .GlobalEnv) ||
|
||
!is.data.frame(get("daten_ist_screening_a", envir = .GlobalEnv))) {
|
||
return(list(typ = "daten_fehler",
|
||
meldung = paste0("Objekt 'daten_ist_screening_a' nach dem Sourcen des ",
|
||
"Download-Skripts nicht gefunden oder kein Dataframe.")))
|
||
}
|
||
daten_ist_a = get("daten_ist_screening_a", envir = .GlobalEnv)
|
||
|
||
# 4b. Notwendige Spaltenmuster zur Laufzeit verifizieren
|
||
alle_item_cols = vapply(1:60, ist_col, character(1))
|
||
fehlende_item_cols = alle_item_cols[!(alle_item_cols %in% names(daten_ist_a))]
|
||
if (length(fehlende_item_cols) == length(alle_item_cols)) {
|
||
return(list(typ = "struktur_fehler",
|
||
meldung = "Keine der 60 Item-Spalten (ist_a_01 ... ist_a_60) im Datensatz gefunden."))
|
||
}
|
||
# Einzelne fehlende Item-Spalten sind KEIN Abbruch: formr laesst beim Export
|
||
# Spalten weg, die von keiner Person beantwortet wurden (typisch fuer eine
|
||
# spaete number-Aufgabe im Speed-Test). Solche Items werden wie unbeantwortet
|
||
# als falsch (0 Punkte) gewertet und weiter unten gesondert ausgewiesen
|
||
# (Manual Kap. 8, keine Mindestbeantwortungsquote).
|
||
|
||
session_spalte = ist_finde_spalte(daten_ist_a,
|
||
c("session", "session_id", "code", "pseudonym"))
|
||
if (is.na(session_spalte)) {
|
||
return(list(typ = "struktur_fehler",
|
||
meldung = paste0("Keine Session-/Pseudonym-Spalte im Datensatz identifizierbar ",
|
||
"(gesucht: session, session_id, code, pseudonym).")))
|
||
}
|
||
|
||
zeitstempel_kandidaten = intersect(c("ended", "completed", "created", "modified"),
|
||
names(daten_ist_a))
|
||
if (length(zeitstempel_kandidaten) == 0) {
|
||
return(list(typ = "struktur_fehler",
|
||
meldung = paste0("Keine Zeitstempel-Spalte im Datensatz identifizierbar ",
|
||
"(gesucht: ended, completed, created, modified). Fuer den Word-Export ",
|
||
"wird ein Ausfuelldatum benoetigt.")))
|
||
}
|
||
|
||
hat_alter = "alter" %in% names(daten_ist_a)
|
||
hat_schulform = "schulform" %in% names(daten_ist_a)
|
||
|
||
# 5. pseudonyme.db suchen
|
||
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 = "db_fehler",
|
||
meldung = paste0("pseudonyme.db nicht gefunden (bis 5 Ebenen oberhalb von ",
|
||
dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE)), " gesucht).")))
|
||
}
|
||
|
||
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 = "db_fehler",
|
||
meldung = paste0("Fehler im Pseudonym-Skript: ", ok_ps$msg)))
|
||
}
|
||
|
||
# 6. pseudo vorhanden?
|
||
if (!exists("pseudo", envir = .GlobalEnv) ||
|
||
!is.data.frame(get("pseudo", envir = .GlobalEnv))) {
|
||
return(list(typ = "db_fehler",
|
||
meldung = "Objekt 'pseudo' nach dem Sourcen nicht gefunden oder kein Dataframe."))
|
||
}
|
||
pseudo = get("pseudo", envir = .GlobalEnv)
|
||
|
||
# 7. Chiffre-Rueckaufloesung aus Pseudonym
|
||
if (nchar(pseudonym_eingabe) > 0) {
|
||
pw_treffer = pseudo[trimws(as.character(pseudo$pseudonym)) == pseudonym_eingabe, , drop = FALSE]
|
||
if (nrow(pw_treffer) > 0) chiffre = toupper(trimws(as.character(pw_treffer$chiffre[1])))
|
||
}
|
||
|
||
# 8. Chiffre -> Pseudonym(e)
|
||
treffer_ps = pseudo[toupper(trimws(as.character(pseudo$chiffre))) == chiffre, , drop = FALSE]
|
||
if (nrow(treffer_ps) == 0) {
|
||
meldung = if (nchar(pseudonym_eingabe) > 0 && nchar(chiffre) == 0) {
|
||
paste0("Pseudonym '", pseudonym_eingabe, "' wurde in der Pseudonym-Datenbank nicht gefunden.")
|
||
} else {
|
||
paste0("Chiffre '", chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden.")
|
||
}
|
||
return(list(typ = "chiffre_nicht_gefunden", meldung = meldung))
|
||
}
|
||
|
||
alle_session_ids = unique(as.character(treffer_ps$pseudonym))
|
||
if (nchar(pseudonym_eingabe) > 0) alle_session_ids = pseudonym_eingabe
|
||
|
||
idx_kandidaten = which(as.character(daten_ist_a[[session_spalte]]) %in% alle_session_ids)
|
||
if (length(idx_kandidaten) == 0) {
|
||
return(list(typ = "datensatz_nicht_gefunden",
|
||
meldung = paste0("Kein IST-Screening-A-Datensatz fuer Chiffre '", chiffre, "' gefunden. (",
|
||
length(alle_session_ids), " Pseudonym(e) geprueft)")))
|
||
}
|
||
|
||
mehrfach_warnung = NULL
|
||
if (length(idx_kandidaten) > 1) {
|
||
zeitwerte = suppressWarnings(as.POSIXct(daten_ist_a[[zeitstempel_kandidaten[1]]][idx_kandidaten]))
|
||
idx_final = idx_kandidaten[which.max(zeitwerte)]
|
||
if (length(idx_final) == 0) idx_final = idx_kandidaten[length(idx_kandidaten)]
|
||
mehrfach_warnung = list(n = length(idx_kandidaten))
|
||
} else {
|
||
idx_final = idx_kandidaten[1]
|
||
}
|
||
zeile = daten_ist_a[idx_final, , drop = FALSE]
|
||
|
||
# --- Ausfuelldatum ---
|
||
zt = NULL
|
||
for (sp in zeitstempel_kandidaten) {
|
||
ts_try = suppressWarnings(as.POSIXct(zeile[[sp]][1]))
|
||
if (!is.na(ts_try)) { zt = list(ts = ts_try, spalte = sp); break }
|
||
}
|
||
if (is.null(zt)) zt = list(ts = as.POSIXct(NA), spalte = zeitstempel_kandidaten[1])
|
||
ausfuelldatum = if (is.na(zt$ts)) "unbekannt" else format(zt$ts, "%d.%m.%Y")
|
||
ausfuelldatum_ymd = if (is.na(zt$ts)) NA_character_ else format(zt$ts, "%Y%m%d")
|
||
|
||
# --- Alter / Schulform ---
|
||
alter_roh = if (hat_alter) suppressWarnings(as.numeric(zeile[["alter"]][1])) else NA_real_
|
||
alter = if (!is.na(alter_roh) && alter_roh > 0) alter_roh else NA_real_
|
||
|
||
schulform_text = NA_character_
|
||
if (hat_schulform) {
|
||
schulform_factor = tryCatch(haven::as_factor(daten_ist_a[["schulform"]]),
|
||
error = function(e) NULL)
|
||
if (!is.null(schulform_factor)) {
|
||
schulform_text = as.character(schulform_factor[idx_final])
|
||
}
|
||
}
|
||
schulform_gruppe = if (is.na(schulform_text)) {
|
||
NA_character_
|
||
} else if (schulform_text == "Gymnasium") {
|
||
"Gymnasiasten"
|
||
} else if (schulform_text %in% c("Hauptschule", "Realschule")) {
|
||
"Nicht-Gymnasiasten"
|
||
} else {
|
||
NA_character_
|
||
}
|
||
|
||
# --- Itemauswertung ---
|
||
# Fehlende Item-Spalte -> eigener Status "fehlende_spalte" (zaehlt als falsch,
|
||
# wird aber getrennt von echten Falschantworten und von Matching-Fehlern
|
||
# ("nicht_auswertbar") ausgewiesen).
|
||
eval_item = function(i, typ) {
|
||
col = ist_col(i)
|
||
if (!(col %in% names(daten_ist_a))) {
|
||
return(list(status = "fehlende_spalte", richtig = FALSE,
|
||
grund = "Item-Spalte im Datenexport nicht enthalten",
|
||
gegeben = NA_real_, korrekter_code = NA_real_))
|
||
}
|
||
if (typ == "analogie") {
|
||
ist_pruefe_analogie(daten_ist_a[[col]], zeile[[col]], IST_A_ANALOGIEN_LOESUNG[i])
|
||
} else if (typ == "zahl") {
|
||
ist_pruefe_zahlenreihe(zeile[[col]], IST_A_ZAHLENREIHEN_LOESUNG[i - 20])
|
||
} else {
|
||
ist_pruefe_matrix(daten_ist_a[[col]], zeile[[col]], IST_A_MATRIZEN_LOESUNG[i - 40])
|
||
}
|
||
}
|
||
analogien_res = lapply(1:20, function(i) eval_item(i, "analogie"))
|
||
zahlenreihen_res = lapply(21:40, function(i) eval_item(i, "zahl"))
|
||
matrizen_res = lapply(41:60, function(i) eval_item(i, "matrix"))
|
||
|
||
zusammenfassen = function(res_liste, offset) {
|
||
richtig = sum(vapply(res_liste, function(x) isTRUE(x$richtig), logical(1)))
|
||
na_idx = which(vapply(res_liste, function(x) identical(x$status, "nicht_auswertbar"), logical(1)))
|
||
fs_idx = which(vapply(res_liste, function(x) identical(x$status, "fehlende_spalte"), logical(1)))
|
||
list(
|
||
rw = richtig,
|
||
n_nicht_auswertbar = length(na_idx),
|
||
nicht_auswertbar_items = if (length(na_idx)) offset + na_idx else integer(0),
|
||
n_fehlende_spalte = length(fs_idx),
|
||
fehlende_spalte_items = if (length(fs_idx)) offset + fs_idx else integer(0)
|
||
)
|
||
}
|
||
z_ana = zusammenfassen(analogien_res, 0)
|
||
z_zr = zusammenfassen(zahlenreihen_res, 20)
|
||
z_mat = zusammenfassen(matrizen_res, 40)
|
||
|
||
rw_analogien = z_ana$rw
|
||
rw_zahlenreihen = z_zr$rw
|
||
rw_matrizen = z_mat$rw
|
||
rw_gesamt = rw_analogien + rw_zahlenreihen + rw_matrizen
|
||
|
||
# --- Normbloecke ---
|
||
prim_key = ist_primaere_tabelle(schulform_gruppe, alter)
|
||
norm_primaer = NULL
|
||
norm_primaer_grund = NULL
|
||
if (is.null(prim_key)) {
|
||
norm_primaer_grund = if (is.na(schulform_gruppe) && (is.na(alter) || alter < 15 || alter > 30)) {
|
||
"Keine Norm verfuegbar: Schulform fehlt und Alter ausserhalb 15-30 Jahre (oder fehlend)."
|
||
} else if (is.na(schulform_gruppe)) {
|
||
"Keine Norm verfuegbar: Schulform fehlt oder ist nicht zuordenbar."
|
||
} else {
|
||
"Keine Norm verfuegbar: Alter ausserhalb des normierten Bereichs 15-30 Jahre (oder fehlend)."
|
||
}
|
||
} else {
|
||
norm_primaer = ist_berechne_normblock(prim_key, rw_analogien, rw_zahlenreihen,
|
||
rw_matrizen, rw_gesamt)
|
||
}
|
||
|
||
gg_key = ist_gesamtgruppe_tabelle(alter)
|
||
norm_gesamtgruppe = if (is.null(gg_key)) NULL else
|
||
ist_berechne_normblock(gg_key, rw_analogien, rw_zahlenreihen, rw_matrizen, rw_gesamt)
|
||
|
||
norm_a12 = ist_berechne_normblock("A12", rw_analogien, rw_zahlenreihen,
|
||
rw_matrizen, rw_gesamt, nur_gesamt = TRUE)
|
||
|
||
# --- Rohdaten-Check (Analogien 1-3, Matrizen 41-43) ---
|
||
rohdaten_check = lapply(c(1, 2, 3, 41, 42, 43), function(i) {
|
||
col = ist_col(i)
|
||
la = attr(daten_ist_a[[col]], "labels")
|
||
list(
|
||
item = col,
|
||
roh = {
|
||
rv = zeile[[col]][1]
|
||
if (is.null(rv) || is.na(rv)) "NA" else as.character(rv)
|
||
},
|
||
labels = if (is.null(la) || length(la) == 0) "kein labels-Attribut" else
|
||
paste(sprintf("%s = %s", names(la), as.vector(la)), collapse = "\n")
|
||
)
|
||
})
|
||
|
||
# --- Einzelitem-Details ---
|
||
baue_details = function(res_liste, offset, typ) {
|
||
lapply(seq_along(res_liste), function(k) {
|
||
r = res_liste[[k]]
|
||
list(
|
||
nr = offset + k,
|
||
typ = typ,
|
||
gegeben = if (is.null(r$gegeben) || is.na(r$gegeben)) NA else r$gegeben,
|
||
korrekt = if (typ == "zahl") r$korrekter_code else NA,
|
||
soll_text = switch(typ,
|
||
"analogie" = IST_A_ANALOGIEN_LOESUNG[offset + k],
|
||
"zahl" = as.character(IST_A_ZAHLENREIHEN_LOESUNG[offset + k - 20]),
|
||
"matrix" = IST_A_MATRIZEN_LOESUNG[offset + k - 40]),
|
||
status = r$status,
|
||
richtig = isTRUE(r$richtig),
|
||
grund = if (!is.null(r$grund)) r$grund else NA_character_
|
||
)
|
||
})
|
||
}
|
||
details_ana = baue_details(analogien_res, 0, "analogie")
|
||
details_zr = baue_details(zahlenreihen_res, 20, "zahl")
|
||
details_mat = baue_details(matrizen_res, 40, "matrix")
|
||
|
||
# --- Technische Hinweise ---
|
||
tech_hinweise = c(IST_HINWEIS_KODIERUNG)
|
||
na_bereiche = c()
|
||
if (z_ana$n_nicht_auswertbar > 0) na_bereiche = c(na_bereiche,
|
||
paste0("Analogien: ", z_ana$n_nicht_auswertbar, " (Items ",
|
||
paste(z_ana$nicht_auswertbar_items, collapse = ", "), ")"))
|
||
if (z_mat$n_nicht_auswertbar > 0) na_bereiche = c(na_bereiche,
|
||
paste0("Matrizen: ", z_mat$n_nicht_auswertbar, " (Items ",
|
||
paste(z_mat$nicht_auswertbar_items, collapse = ", "), ")"))
|
||
if (length(na_bereiche) > 0) {
|
||
tech_hinweise = c(tech_hinweise, paste0(
|
||
"Nicht auswertbare Items (Text-/Regex-Matching fehlgeschlagen, als falsch gewertet, ",
|
||
"aber gesondert ausgewiesen): ", paste(na_bereiche, collapse = "; "), "."))
|
||
}
|
||
if (length(fehlende_item_cols) > 0) {
|
||
tech_hinweise = c(tech_hinweise, paste0(
|
||
"Nicht im Datenexport enthaltene Item-Spalten (", length(fehlende_item_cols), "): ",
|
||
paste(fehlende_item_cols, collapse = ", "),
|
||
". Wie unbeantwortet als falsch (0 Punkte) gewertet – typischerweise eine von keiner ",
|
||
"Person beantwortete Aufgabe, die formr beim Export weglaesst."))
|
||
}
|
||
if (length(na_bereiche) == 0 && length(fehlende_item_cols) == 0) {
|
||
tech_hinweise = c(tech_hinweise,
|
||
"Alle 60 Items konnten regulaer ausgewertet werden (kein Matching-Fehler, keine fehlende Spalte).")
|
||
}
|
||
tech_hinweise = c(tech_hinweise, paste0(
|
||
"Als Ausfuelldatum wurde die Spalte '", zt$spalte, "' verwendet (zur Laufzeit ",
|
||
"aus den vorhandenen Zeitstempel-Spalten gewaehlt)."))
|
||
tech_hinweise = c(tech_hinweise, IST_HINWEIS_A13_UNTERTESTS, IST_HINWEIS_SW_UNTER_70)
|
||
|
||
list(
|
||
typ = "ok",
|
||
chiffre = chiffre,
|
||
ausfuelldatum = ausfuelldatum,
|
||
ausfuelldatum_ymd = ausfuelldatum_ymd,
|
||
alter = alter,
|
||
schulform_text = schulform_text,
|
||
schulform_gruppe = schulform_gruppe,
|
||
mehrfach_warnung = mehrfach_warnung,
|
||
rw_analogien = rw_analogien,
|
||
rw_zahlenreihen = rw_zahlenreihen,
|
||
rw_matrizen = rw_matrizen,
|
||
rw_gesamt = rw_gesamt,
|
||
z_ana = z_ana,
|
||
z_zr = z_zr,
|
||
z_mat = z_mat,
|
||
fehlende_item_cols = fehlende_item_cols,
|
||
norm_primaer = norm_primaer,
|
||
norm_primaer_grund = norm_primaer_grund,
|
||
norm_gesamtgruppe = norm_gesamtgruppe,
|
||
norm_a12 = norm_a12,
|
||
rohdaten_check = rohdaten_check,
|
||
details_ana = details_ana,
|
||
details_zr = details_zr,
|
||
details_mat = details_mat,
|
||
tech_hinweise = tech_hinweise
|
||
)
|
||
})
|
||
|
||
output$fehler_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
if (!identical(d$typ, "ok")) div(class = "alert-fehler", d$meldung)
|
||
})
|
||
|
||
output$warnung_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
if (!identical(d$typ, "ok")) return(NULL)
|
||
|
||
meldungen = list()
|
||
if (!is.null(d$mehrfach_warnung)) {
|
||
meldungen = c(meldungen, paste0(
|
||
"Mehrere Ausfuellungen fuer diese Chiffre gefunden (", d$mehrfach_warnung$n,
|
||
" Eintraege). Angezeigt wird die neueste (nach Zeitstempel)."))
|
||
}
|
||
if (is.null(d$norm_primaer)) {
|
||
meldungen = c(meldungen, d$norm_primaer_grund)
|
||
}
|
||
if ((d$z_ana$n_nicht_auswertbar + d$z_mat$n_nicht_auswertbar) > 0) {
|
||
teile = c()
|
||
if (d$z_ana$n_nicht_auswertbar > 0) teile = c(teile,
|
||
paste0("Analogien: ", d$z_ana$n_nicht_auswertbar, " (Items ",
|
||
paste(d$z_ana$nicht_auswertbar_items, collapse = ", "), ")"))
|
||
if (d$z_mat$n_nicht_auswertbar > 0) teile = c(teile,
|
||
paste0("Matrizen: ", d$z_mat$n_nicht_auswertbar, " (Items ",
|
||
paste(d$z_mat$nicht_auswertbar_items, collapse = ", "), ")"))
|
||
meldungen = c(meldungen, paste0(
|
||
"Nicht auswertbare Items (Text-/Regex-Matching fehlgeschlagen): ",
|
||
paste(teile, collapse = "; "),
|
||
". Diese zaehlen als falsch, sind aber keine gesicherten Falschantworten – ",
|
||
"bitte den Rohdaten-Check pruefen."))
|
||
}
|
||
n_fehlend = d$z_ana$n_fehlende_spalte + d$z_zr$n_fehlende_spalte + d$z_mat$n_fehlende_spalte
|
||
if (n_fehlend > 0) {
|
||
teile = c()
|
||
if (d$z_ana$n_fehlende_spalte > 0) teile = c(teile,
|
||
paste0("Analogien: Item(s) ", paste(d$z_ana$fehlende_spalte_items, collapse = ", ")))
|
||
if (d$z_zr$n_fehlende_spalte > 0) teile = c(teile,
|
||
paste0("Zahlenreihen: Item(s) ", paste(d$z_zr$fehlende_spalte_items, collapse = ", ")))
|
||
if (d$z_mat$n_fehlende_spalte > 0) teile = c(teile,
|
||
paste0("Matrizen: Item(s) ", paste(d$z_mat$fehlende_spalte_items, collapse = ", ")))
|
||
meldungen = c(meldungen, paste0(
|
||
"Item-Spalten fehlen im Datenexport (", n_fehlend, "): ", paste(teile, collapse = "; "),
|
||
". Diese Items werden wie unbeantwortet als falsch (0 Punkte) gewertet – ",
|
||
"meist eine Aufgabe, die niemand beantwortet hat und die formr beim Export weglaesst."))
|
||
}
|
||
if (length(meldungen) == 0) return(NULL)
|
||
tagList(lapply(meldungen, function(m) div(class = "alert-warnung", m)))
|
||
})
|
||
|
||
# Vier-Zeilen-Tabelle RW / SW / PR / IQ fuer einen Normblock.
|
||
norm_tabelle_ui = function(block) {
|
||
zeile_ui = function(name, comp, max_rw, gesamt = FALSE) {
|
||
tags$tr(class = if (gesamt) "gesamt-zeile" else NULL,
|
||
tags$td(name),
|
||
tags$td(paste0(comp$rw, " / ", max_rw)),
|
||
tags$td(ist_oder_strich(comp$sw)),
|
||
tags$td(ist_pr_text(comp)),
|
||
tags$td(ist_iq_text(comp))
|
||
)
|
||
}
|
||
tags$table(class = "norm-tabelle",
|
||
tags$thead(tags$tr(
|
||
tags$th("Bereich"), tags$th("Rohwert"), tags$th("Standardwert"),
|
||
tags$th("Prozentrang"), tags$th("IQ")
|
||
)),
|
||
tags$tbody(
|
||
zeile_ui("Analogien", block$analogien, 20),
|
||
zeile_ui("Zahlenreihen", block$zahlenreihen, 20),
|
||
zeile_ui("Matrizen", block$matrizen, 20),
|
||
zeile_ui("Gesamtwert", block$gesamt, 60, gesamt = TRUE)
|
||
)
|
||
)
|
||
}
|
||
|
||
rohwert_tabelle_ui = function(d) {
|
||
zeile_ui = function(name, rw, max_rw) tags$tr(
|
||
tags$td(name), tags$td(paste0(rw, " / ", max_rw)),
|
||
tags$td("–"), tags$td("–"), tags$td("–")
|
||
)
|
||
tags$table(class = "norm-tabelle",
|
||
tags$thead(tags$tr(
|
||
tags$th("Bereich"), tags$th("Rohwert"), tags$th("Standardwert"),
|
||
tags$th("Prozentrang"), tags$th("IQ")
|
||
)),
|
||
tags$tbody(
|
||
zeile_ui("Analogien", d$rw_analogien, 20),
|
||
zeile_ui("Zahlenreihen", d$rw_zahlenreihen, 20),
|
||
zeile_ui("Matrizen", d$rw_matrizen, 20),
|
||
tags$tr(class = "gesamt-zeile",
|
||
tags$td("Gesamtwert"), tags$td(paste0(d$rw_gesamt, " / 60")),
|
||
tags$td("–"), tags$td("–"), tags$td("–"))
|
||
)
|
||
)
|
||
}
|
||
|
||
detail_liste_ui = function(details) {
|
||
div(
|
||
lapply(details, function(it) {
|
||
if (identical(it$status, "fehlende_spalte")) {
|
||
badge = span(style = "color:#BF360C; font-weight:700;", "Spalte fehlt")
|
||
info = paste0("Soll: ", it$soll_text, " | Item-Spalte nicht im Datenexport (als falsch gewertet)")
|
||
} else if (identical(it$status, "nicht_auswertbar")) {
|
||
badge = span(style = "color:#BF360C; font-weight:700;", "nicht auswertbar")
|
||
info = paste0("Soll: ", it$soll_text, " | ", it$grund)
|
||
} else if (isTRUE(it$richtig)) {
|
||
badge = span(style = "color:#2E7D32; font-weight:700;", "richtig")
|
||
info = paste0("Antwort-Code: ", ist_oder_strich(it$gegeben), " | Soll: ", it$soll_text)
|
||
} else {
|
||
badge = span(style = "color:#B71C1C; font-weight:700;", "falsch")
|
||
info = paste0("Antwort-Code: ", ist_oder_strich(it$gegeben), " | Soll: ", it$soll_text)
|
||
}
|
||
div(class = "item-zeile",
|
||
span(class = "item-nr", paste0(it$nr, ".")),
|
||
span(class = "item-text", info),
|
||
badge
|
||
)
|
||
})
|
||
)
|
||
}
|
||
|
||
output$ergebnis_ui = renderUI({
|
||
req(input$btn_suchen)
|
||
d = ergebnis_r()
|
||
if (!identical(d$typ, "ok")) return(NULL)
|
||
|
||
kopf = div(class = "meta-block",
|
||
tags$strong("Chiffre: "), d$chiffre,
|
||
tags$span(" | ", style = "color:#ccc;"),
|
||
tags$strong("Ausfuelldatum: "), d$ausfuelldatum,
|
||
tags$span(" | ", style = "color:#ccc;"),
|
||
tags$strong("Alter: "), if (is.na(d$alter)) "k. A." else d$alter,
|
||
tags$span(" | ", style = "color:#ccc;"),
|
||
tags$strong("Schulform: "), if (is.na(d$schulform_text)) "k. A." else d$schulform_text
|
||
)
|
||
|
||
primaer_karte = div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Primaere Norm (schulform- und altersspezifisch)"),
|
||
if (is.null(d$norm_primaer)) {
|
||
tagList(
|
||
div(class = "alert-warnung", d$norm_primaer_grund),
|
||
rohwert_tabelle_ui(d)
|
||
)
|
||
} else {
|
||
tagList(
|
||
div(class = "meta-block", tags$strong("Normgruppe: "), d$norm_primaer$label),
|
||
norm_tabelle_ui(d$norm_primaer),
|
||
div(class = "hinweis-block", IST_HINWEIS_A13_UNTERTESTS),
|
||
if (any(vapply(d$norm_primaer[c("analogien","zahlenreihen","matrizen","gesamt")],
|
||
function(c) isTRUE(c$unter_minimum), logical(1)))) {
|
||
div(class = "hinweis-block", IST_HINWEIS_SW_UNTER_70)
|
||
}
|
||
)
|
||
}
|
||
)
|
||
|
||
gesamtgruppe_karte = div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Zusatzangabe: Gesamtgruppe (ohne Schulform)"),
|
||
if (is.null(d$norm_gesamtgruppe)) {
|
||
div(class = "alert-warnung",
|
||
"Nicht verfuegbar: Alter ausserhalb 15-30 Jahre oder fehlend.")
|
||
} else {
|
||
tagList(
|
||
div(class = "meta-block", tags$strong("Normgruppe: "), d$norm_gesamtgruppe$label),
|
||
norm_tabelle_ui(d$norm_gesamtgruppe),
|
||
div(class = "hinweis-block", IST_HINWEIS_A13_UNTERTESTS),
|
||
if (any(vapply(d$norm_gesamtgruppe[c("analogien","zahlenreihen","matrizen","gesamt")],
|
||
function(c) isTRUE(c$unter_minimum), logical(1)))) {
|
||
div(class = "hinweis-block", IST_HINWEIS_SW_UNTER_70)
|
||
}
|
||
)
|
||
}
|
||
)
|
||
|
||
g12 = d$norm_a12$gesamt
|
||
a12_karte = div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Zusatzangabe: Gesamtstichprobe (Tabelle A12, nur Gesamtwert)"),
|
||
div(class = "hinweis-block",
|
||
"Ohne Alters- und Schulformdifferenzierung, ausschliesslich fuer den Gesamtwert."),
|
||
tags$table(class = "norm-tabelle",
|
||
tags$thead(tags$tr(
|
||
tags$th("Bereich"), tags$th("Rohwert"), tags$th("Standardwert"),
|
||
tags$th("Prozentrang"), tags$th("IQ")
|
||
)),
|
||
tags$tbody(tags$tr(class = "gesamt-zeile",
|
||
tags$td("Gesamtwert"), tags$td(paste0(g12$rw, " / 60")),
|
||
tags$td(ist_oder_strich(g12$sw)), tags$td(ist_pr_text(g12)), tags$td(ist_iq_text(g12))
|
||
))
|
||
),
|
||
if (isTRUE(g12$unter_minimum)) div(class = "hinweis-block", IST_HINWEIS_SW_UNTER_70)
|
||
)
|
||
|
||
rohcheck_karte = div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Rohdaten-Check und Einzelitems"),
|
||
tags$details(class = "rohcheck",
|
||
tags$summary("Rohdaten-Check: gespeicherte Werte und labels-Attribut (Analogien 1-3, Matrizen 41-43)"),
|
||
div(class = "hinweis-block",
|
||
"Zur manuellen Verifikation, dass das textbasierte Matching greift, bevor die ",
|
||
"Auswertung genutzt wird."),
|
||
lapply(d$rohdaten_check, function(rc) {
|
||
div(class = "rohcheck-box",
|
||
paste0(rc$item, " | gespeicherter Rohwert: ", rc$roh, "\nlabels:\n", rc$labels))
|
||
})
|
||
),
|
||
tags$details(class = "rohcheck",
|
||
tags$summary("Einzelitems: Analogien (1-20)"),
|
||
detail_liste_ui(d$details_ana)
|
||
),
|
||
tags$details(class = "rohcheck",
|
||
tags$summary("Einzelitems: Zahlenreihen (21-40)"),
|
||
detail_liste_ui(d$details_zr)
|
||
),
|
||
tags$details(class = "rohcheck",
|
||
tags$summary("Einzelitems: Matrizen (41-60)"),
|
||
detail_liste_ui(d$details_mat)
|
||
)
|
||
)
|
||
|
||
hinweis_karte = div(class = "abschnitt-karte",
|
||
div(class = "abschnitt-titel", "Hinweise und Einschraenkungen"),
|
||
tags$ul(
|
||
tags$li("Die digitale Selbstausfuell-Version repliziert nicht die im Manual ",
|
||
"beschriebene testleiter-administrierte Gruppentestsituation."),
|
||
tags$li("Ob Tabelle A13 fuer Untertest-Standardwerte gedacht ist, ist eine ",
|
||
"Interpretationsfrage, keine gesicherte Manual-Aussage."),
|
||
tags$li("Standardwerte unter 70 sind in Tabelle A13 nicht direkt tabelliert; ",
|
||
"die App zeigt hier IQ \"", IST_IQ_UNTER_MINIMUM_TEXT, "\" und Prozentrang ",
|
||
IST_PR_UNTER_MINIMUM, " (Bodenwert) – bewusste, vom Nutzer festgelegte Konvention."),
|
||
tags$li("Fehlende oder nicht beantwortete Items zaehlen als falsch (Speed-Test-Charakter, ",
|
||
"keine Mindestbeantwortungsquote).")
|
||
),
|
||
div(class = "hinweis-block", IST_DISCLAIMER)
|
||
)
|
||
|
||
tagList(kopf, primaer_karte, gesamtgruppe_karte, a12_karte, rohcheck_karte, hinweis_karte)
|
||
})
|
||
|
||
output$download_word = downloadHandler(
|
||
filename = function() {
|
||
d = tryCatch(ergebnis_r(), error = function(e) NULL)
|
||
chiffre_fn = if (is.list(d) && identical(d$typ, "ok") && nchar(d$chiffre) > 0) {
|
||
gsub("[^A-Za-z0-9_-]", "_", d$chiffre)
|
||
} else {
|
||
"export"
|
||
}
|
||
datum_fn = if (is.list(d) && identical(d$typ, "ok") && !is.na(d$ausfuelldatum_ymd)) {
|
||
d$ausfuelldatum_ymd
|
||
} else {
|
||
format(Sys.Date(), "%Y%m%d")
|
||
}
|
||
paste0("IST-Screening-A_", chiffre_fn, "_", datum_fn, ".docx")
|
||
},
|
||
content = function(file) {
|
||
d = tryCatch(ergebnis_r(), error = function(e) NULL)
|
||
if (!is.list(d) || !identical(d$typ, "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_ist_screening_a_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)
|