Initial commit
This commit is contained in:
commit
3cba772836
1341 changed files with 532924 additions and 0 deletions
970
HZI/app.R
Normal file
970
HZI/app.R
Normal file
|
|
@ -0,0 +1,970 @@
|
|||
# Präambel ####
|
||||
|
||||
library(shiny)
|
||||
library(dplyr)
|
||||
library(ggplot2)
|
||||
library(haven)
|
||||
library(readr)
|
||||
library(officer)
|
||||
library(DBI)
|
||||
library(RSQLite)
|
||||
|
||||
AKZENT_FARBE = "#8B2635"
|
||||
|
||||
SKALEN_NAMEN = c(
|
||||
A = "Kontrollieren, Wiederholen, Denken nach einer Handlung",
|
||||
B = "Waschen, Reinigen",
|
||||
C = "Ordnen",
|
||||
D = "Zählen, Berühren, Sprechen",
|
||||
E = "Denken von Worten, Bildern, Gedankenketten",
|
||||
F = "Gedanken, sich selbst/anderen ein Leid zuzufügen"
|
||||
)
|
||||
|
||||
KENNWERT_NAMEN = c(
|
||||
A = "Skala A - Kontrollieren, Wiederholen, Denken nach einer Handlung",
|
||||
B = "Skala B - Waschen, Reinigen",
|
||||
C = "Skala C - Ordnen",
|
||||
D = "Skala D - Zählen, Berühren, Sprechen",
|
||||
E = "Skala E - Denken von Worten, Bildern, Gedankenketten",
|
||||
F = "Skala F - Gedanken, sich selbst/anderen ein Leid zuzufügen",
|
||||
G = "Gesamtskala",
|
||||
P1 = "Prüfskala P1",
|
||||
P2 = "Prüfskala P2",
|
||||
P3 = "Prüfskala P3",
|
||||
P4 = "Prüfskala P4"
|
||||
)
|
||||
|
||||
TABELLE_KONFIDENZINTERVALLE = data.frame(
|
||||
skala = c("A","B","C","D","E","F","G","P1","P2","P3","P4"),
|
||||
r_tt = c(.88,.96,.94,.95,.86,.78,.93,.86,.90,.90,.91),
|
||||
s_e = c(0.69,0.40,0.49,0.45,0.75,0.94,0.53,0.75,0.63,0.63,0.60),
|
||||
cl_5proz = c(1.35,0.78,0.96,0.87,1.47,1.84,1.03,1.47,1.23,1.23,1.17),
|
||||
cl_1proz = c(1.78,1.03,1.26,1.15,1.93,2.42,1.36,1.93,1.62,1.62,1.54),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
PRUEFSKALEN_D_CRIT_5PROZ = 3
|
||||
PRUEFSKALEN_D_CRIT_1PROZ = 4
|
||||
PRUEFSKALEN_D_CRIT_01PROZ = 5
|
||||
|
||||
HZI_DISCLAIMER = paste0(
|
||||
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
|
||||
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ",
|
||||
"Angaben zu Normal- und Extrembereich sowie die 54%-Markierung des Originalprofilbogens ",
|
||||
"sind in dieser digitalen Auswertung nicht abgebildet, da hierfuer keine im Manual ",
|
||||
"textuell belegten Zahlenwerte vorliegen."
|
||||
)
|
||||
|
||||
PRUEFSKALA_ERKLAERUNG = paste0(
|
||||
"Die Prüfskalen P1–P4 sind keine inhaltlichen Symptomskalen wie A–F, sondern fassen die Items ",
|
||||
"aller sechs Skalen auf derselben Schwierigkeitsstufe zusammen (z. B. P1 = alle Stufe-1-Items ",
|
||||
"über alle Skalen hinweg). Sie dienen als Kontrollwert für die Konsistenz des Antwortverhaltens: ",
|
||||
"weichen die vier Prüfskalen stark voneinander ab, deutet dies auf ein untypisches Antwortmuster ",
|
||||
"hin (HZI-Non-Skalen-Typ), nicht auf ein bestimmtes Symptombild."
|
||||
)
|
||||
|
||||
#### Infrastruktur ####
|
||||
|
||||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_hzi.R"
|
||||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"
|
||||
PFAD_NORMTABELLEN_ORDNER = "./normtabellen"
|
||||
|
||||
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_ORDNER = normalizePath(absPath(PFAD_NORMTABELLEN_ORDNER), mustWork = FALSE)
|
||||
|
||||
app_css = "
|
||||
.input-panel {
|
||||
display: flex;
|
||||
align-items: center;
|
||||
gap: 16px;
|
||||
flex-wrap: wrap;
|
||||
padding: 16px;
|
||||
margin-bottom: 20px;
|
||||
background: #f5f5f5;
|
||||
border-radius: 6px;
|
||||
}
|
||||
.btn-laden {
|
||||
background-color: #8B2635;
|
||||
border-color: #8B2635;
|
||||
color: #fff;
|
||||
}
|
||||
.btn-laden:hover, .btn-laden:focus {
|
||||
background-color: #6f1e2a;
|
||||
border-color: #6f1e2a;
|
||||
color: #fff;
|
||||
}
|
||||
.abschnitt-karte {
|
||||
padding: 16px 20px;
|
||||
margin-bottom: 18px;
|
||||
border: 1px solid #ddd;
|
||||
border-radius: 6px;
|
||||
background: #fff;
|
||||
}
|
||||
.abschnitt-titel {
|
||||
font-size: 1.15em;
|
||||
font-weight: 700;
|
||||
color: #8B2635;
|
||||
margin-bottom: 12px;
|
||||
}
|
||||
.alert-fehler {
|
||||
padding: 12px 16px;
|
||||
margin-bottom: 14px;
|
||||
background: #f8d7da;
|
||||
border: 1px solid #c0392b;
|
||||
border-radius: 5px;
|
||||
color: #58151c;
|
||||
}
|
||||
.alert-warnung {
|
||||
padding: 12px 16px;
|
||||
margin-bottom: 14px;
|
||||
background: #fff3cd;
|
||||
border: 1px solid #b8860b;
|
||||
border-radius: 5px;
|
||||
color: #6b5100;
|
||||
}
|
||||
.item-zeile {
|
||||
display: flex;
|
||||
align-items: flex-start;
|
||||
gap: 10px;
|
||||
padding: 4px 0;
|
||||
border-bottom: 1px solid #eee;
|
||||
}
|
||||
.item-nr {
|
||||
font-weight: 600;
|
||||
min-width: 60px;
|
||||
color: #8B2635;
|
||||
flex-shrink: 0;
|
||||
}
|
||||
.item-text {
|
||||
flex: 1;
|
||||
}
|
||||
.badge {
|
||||
display: inline-block;
|
||||
align-self: flex-start;
|
||||
flex-shrink: 0;
|
||||
padding: 2px 10px;
|
||||
border-radius: 12px;
|
||||
font-size: 0.85em;
|
||||
font-weight: 600;
|
||||
line-height: 1.4;
|
||||
white-space: nowrap;
|
||||
}
|
||||
.badge-positiv {
|
||||
background: #8B2635;
|
||||
color: #fff;
|
||||
}
|
||||
.badge-negativ {
|
||||
background: #e0e0e0;
|
||||
color: #444;
|
||||
}
|
||||
.badge-fehlend {
|
||||
background: #fff3cd;
|
||||
color: #6b5100;
|
||||
border: 1px solid #b8860b;
|
||||
}
|
||||
table.tabelle-werte {
|
||||
width: 100%;
|
||||
border-collapse: collapse;
|
||||
}
|
||||
table.tabelle-werte th, table.tabelle-werte td {
|
||||
padding: 6px 10px;
|
||||
border-bottom: 1px solid #ddd;
|
||||
text-align: left;
|
||||
}
|
||||
table.tabelle-werte th {
|
||||
background: #8B2635;
|
||||
color: #fff;
|
||||
}
|
||||
"
|
||||
app_css = gsub("#8B2635", AKZENT_FARBE, app_css, fixed = TRUE)
|
||||
|
||||
#### Helper ####
|
||||
|
||||
validiere_chiffre = function(chiffre_roh) {
|
||||
chiffre = toupper(trimws(chiffre_roh))
|
||||
if (!grepl("^[A-Z][0-9]{6}$", chiffre)) {
|
||||
return(list(ok = FALSE, typ = "format_fehler", chiffre = chiffre))
|
||||
}
|
||||
list(ok = TRUE, chiffre = chiffre)
|
||||
}
|
||||
|
||||
extrahiere_item_zuordnung = function(spaltennamen) {
|
||||
treffer = regmatches(spaltennamen, regexec("^hzi_(\\d{3})_([a-f])([1-4])$", spaltennamen))
|
||||
gefunden = vapply(treffer, function(x) length(x) == 4, logical(1))
|
||||
if (sum(gefunden) == 0) {
|
||||
stop("Keine Item-Spalten im Muster 'hzi_NNN_[a-f][1-4]' in daten_hzi gefunden.")
|
||||
}
|
||||
passende = treffer[gefunden]
|
||||
data.frame(
|
||||
spalte = spaltennamen[gefunden],
|
||||
item_nr = vapply(passende, function(x) x[2], character(1)),
|
||||
skala = toupper(vapply(passende, function(x) x[3], character(1))),
|
||||
stufe = as.integer(vapply(passende, function(x) x[4], character(1))),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
ermittle_stimmt_code = function(daten_hzi, spalte) {
|
||||
labels = attr(daten_hzi[[spalte]], "labels")
|
||||
if (is.null(labels)) {
|
||||
stop(sprintf("Item-Spalte '%s': keine Kodierungs-Labels (labelled-Attribut 'labels') gefunden.", spalte))
|
||||
}
|
||||
namen = trimws(names(labels))
|
||||
treffer = which(namen == "stimmt")
|
||||
if (length(treffer) == 0) {
|
||||
stop(sprintf("Item-Spalte '%s': keine Antwortoption exakt 'stimmt' in den Labels gefunden.", spalte))
|
||||
}
|
||||
if (length(treffer) > 1) {
|
||||
stop(sprintf("Item-Spalte '%s': mehrdeutige Kodierung, mehrere Labels 'stimmt' gefunden.", spalte))
|
||||
}
|
||||
unname(labels[treffer])
|
||||
}
|
||||
|
||||
bereinige_markdown = function(text) {
|
||||
if (is.na(text)) return(text)
|
||||
t = text
|
||||
# Fuehrende Itemnummerierung entfernen, z. B. "6\. " oder "12. " (redundant zur Itemnummer-Badge)
|
||||
t = sub(r"(^\s*\d+\\?[.\)]\s*)", "", t, perl = TRUE)
|
||||
# Escapte Markdown-Sonderzeichen entschaerfen, z. B. "\." -> "."
|
||||
t = gsub(r"(\\([[:punct:]]))", "\\1", t, perl = TRUE)
|
||||
trimws(t)
|
||||
}
|
||||
|
||||
ermittle_item_text = function(daten_hzi, spalte) {
|
||||
text = attr(daten_hzi[[spalte]], "label", exact = TRUE)
|
||||
if (is.null(text) || length(text) != 1 || is.na(text) || trimws(text) == "") {
|
||||
return(NA_character_)
|
||||
}
|
||||
bereinige_markdown(trimws(text))
|
||||
}
|
||||
|
||||
baue_item_info = function(daten_hzi) {
|
||||
item_zuordnung = extrahiere_item_zuordnung(colnames(daten_hzi))
|
||||
item_zuordnung$stimmt_code = vapply(
|
||||
item_zuordnung$spalte,
|
||||
function(sp) ermittle_stimmt_code(daten_hzi, sp),
|
||||
numeric(1)
|
||||
)
|
||||
item_zuordnung$item_text = vapply(
|
||||
item_zuordnung$spalte,
|
||||
function(sp) ermittle_item_text(daten_hzi, sp),
|
||||
character(1)
|
||||
)
|
||||
item_zuordnung
|
||||
}
|
||||
|
||||
berechne_itemwerte = function(zeile, item_info) {
|
||||
werte = vapply(seq_len(nrow(item_info)), function(i) {
|
||||
spalte = item_info$spalte[i]
|
||||
stimmt_code = item_info$stimmt_code[i]
|
||||
roh = zeile[[spalte]][1]
|
||||
val = suppressWarnings(as.numeric(roh))
|
||||
if (is.na(val)) return(NA_integer_)
|
||||
if (val == stimmt_code) 1L else 0L
|
||||
}, integer(1))
|
||||
item_info$wert = werte
|
||||
item_info
|
||||
}
|
||||
|
||||
berechne_rohwerte = function(item_info_mit_werten) {
|
||||
zellwerte = item_info_mit_werten %>%
|
||||
group_by(skala, stufe) %>%
|
||||
summarise(rohwert = sum(wert, na.rm = TRUE), n_fehlend = sum(is.na(wert)), .groups = "drop")
|
||||
|
||||
skalenrohwerte = zellwerte %>%
|
||||
group_by(skala) %>%
|
||||
summarise(rohwert = sum(rohwert), n_fehlend = sum(n_fehlend), .groups = "drop")
|
||||
|
||||
gesamtrohwert = sum(skalenrohwerte$rohwert)
|
||||
|
||||
pruefskalen = zellwerte %>%
|
||||
group_by(stufe) %>%
|
||||
summarise(rohwert = sum(rohwert), n_fehlend = sum(n_fehlend), .groups = "drop")
|
||||
|
||||
rohwerte = c(setNames(skalenrohwerte$rohwert, skalenrohwerte$skala), G = gesamtrohwert)
|
||||
rohwerte = c(rohwerte, setNames(pruefskalen$rohwert, paste0("P", pruefskalen$stufe)))
|
||||
|
||||
n_fehlend_gesamt = sum(item_info_mit_werten$wert %>% is.na())
|
||||
|
||||
list(
|
||||
zellwerte = zellwerte,
|
||||
skalenrohwerte = skalenrohwerte,
|
||||
pruefskalen = pruefskalen,
|
||||
rohwerte = rohwerte,
|
||||
gesamtrohwert = gesamtrohwert,
|
||||
n_fehlend = n_fehlend_gesamt
|
||||
)
|
||||
}
|
||||
|
||||
rohwert_zu_stanine = function(tabelle, rohwert) {
|
||||
zeile = tabelle[tabelle$rohwert == rohwert, ]
|
||||
if (nrow(zeile) == 0) {
|
||||
stop(sprintf(
|
||||
"Rohwert %s liegt außerhalb des gültigen Bereichs der Normtabelle (%s–%s). Dies deutet auf einen Rechenfehler hin.",
|
||||
rohwert, min(tabelle$rohwert, na.rm = TRUE), max(tabelle$rohwert, na.rm = TRUE)
|
||||
))
|
||||
}
|
||||
zeile$stanine[1]
|
||||
}
|
||||
|
||||
NORM_KEY_ZUORDNUNG = c(
|
||||
A = "a", B = "b", C = "c", D = "d", E = "e", F = "f",
|
||||
G = "gesamt", P1 = "p1", P2 = "p2", P3 = "p3", P4 = "p4"
|
||||
)
|
||||
|
||||
berechne_stanine_alle = function(rohwerte, normtabellen) {
|
||||
namen = names(rohwerte)
|
||||
stanine = vapply(namen, function(n) {
|
||||
key = NORM_KEY_ZUORDNUNG[[n]]
|
||||
tabelle = normtabellen[[key]]
|
||||
stanine_wert = rohwert_zu_stanine(tabelle, rohwerte[[n]])
|
||||
if (is.na(stanine_wert)) NA_real_ else as.numeric(stanine_wert)
|
||||
}, numeric(1))
|
||||
names(stanine) = namen
|
||||
stanine
|
||||
}
|
||||
|
||||
pruefe_skalenpaar_differenzen = function(stanine_werte, differenzen_tabelle) {
|
||||
ergebnisse = lapply(seq_len(nrow(differenzen_tabelle)), function(i) {
|
||||
s1 = differenzen_tabelle$skala_1[i]
|
||||
s2 = differenzen_tabelle$skala_2[i]
|
||||
st1 = stanine_werte[[s1]]
|
||||
st2 = stanine_werte[[s2]]
|
||||
if (is.null(st1) || is.null(st2) || is.na(st1) || is.na(st2)) return(NULL)
|
||||
d = abs(st1 - st2)
|
||||
crit5 = differenzen_tabelle$d_crit_5proz[i]
|
||||
crit1 = differenzen_tabelle$d_crit_1proz[i]
|
||||
if (d < crit5) return(NULL)
|
||||
signifikanz_1proz = d >= crit1
|
||||
data.frame(
|
||||
skala_1 = s1, skala_2 = s2, differenz = d,
|
||||
signifikant_1proz = signifikanz_1proz,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
})
|
||||
ergebnisse = ergebnisse[!vapply(ergebnisse, is.null, logical(1))]
|
||||
if (length(ergebnisse) == 0) return(data.frame())
|
||||
do.call(rbind, ergebnisse)
|
||||
}
|
||||
|
||||
formatiere_skalenpaar_text = function(zeile) {
|
||||
basis = sprintf(
|
||||
"Skala %s unterscheidet sich bedeutsam von Skala %s (Differenz %s, überschreitet kritische Differenz bei p<.05",
|
||||
zeile$skala_1, zeile$skala_2, zeile$differenz
|
||||
)
|
||||
if (isTRUE(zeile$signifikant_1proz)) {
|
||||
paste0(basis, ", auch p<.01).")
|
||||
} else {
|
||||
paste0(basis, ").")
|
||||
}
|
||||
}
|
||||
|
||||
pruefskalen_streuung_hinweis = function(stanine_werte) {
|
||||
p_werte = stanine_werte[c("P1", "P2", "P3", "P4")]
|
||||
p_werte = p_werte[!is.na(p_werte)]
|
||||
if (length(p_werte) < 2) return(NULL)
|
||||
spanne = max(p_werte) - min(p_werte)
|
||||
schwelle = NULL
|
||||
if (spanne >= PRUEFSKALEN_D_CRIT_01PROZ) {
|
||||
schwelle = list(text = "p<.001", grenze = PRUEFSKALEN_D_CRIT_01PROZ)
|
||||
} else if (spanne >= PRUEFSKALEN_D_CRIT_1PROZ) {
|
||||
schwelle = list(text = "p<.01", grenze = PRUEFSKALEN_D_CRIT_1PROZ)
|
||||
} else if (spanne >= PRUEFSKALEN_D_CRIT_5PROZ) {
|
||||
schwelle = list(text = "p<.05", grenze = PRUEFSKALEN_D_CRIT_5PROZ)
|
||||
}
|
||||
if (is.null(schwelle)) return(NULL)
|
||||
list(
|
||||
spanne = spanne,
|
||||
text = sprintf(
|
||||
"Streuung der Prüfskalen: %s Stanine-Punkte, überschreitet die kritische Differenz bei %s — Hinweis auf möglicherweise untypisches Antwortmuster (HZI-Non-Skalen-Typ).",
|
||||
spanne, schwelle$text
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
dissimulation_hinweis = function(gesamtrohwert) {
|
||||
if (gesamtrohwert < 8 || gesamtrohwert > 145) {
|
||||
return(paste0(
|
||||
"Gesamtrohwert liegt außerhalb des in der Validierungsstichprobe beobachteten Wertebereichs (8–145) — ",
|
||||
"möglicher Hinweis auf verzerrtes Antwortverhalten (Unter- oder Übertreibung)."
|
||||
))
|
||||
}
|
||||
NULL
|
||||
}
|
||||
|
||||
formatiere_ci_text = function(stanine, cl_5proz) {
|
||||
if (is.na(stanine)) return("–")
|
||||
sprintf("%s ± %s", stanine, cl_5proz)
|
||||
}
|
||||
|
||||
item_status_text = function(wert) {
|
||||
if (is.na(wert)) return("fehlend")
|
||||
if (wert == 1) "stimmt" else "stimmt nicht"
|
||||
}
|
||||
|
||||
item_status_klasse = function(wert) {
|
||||
if (is.na(wert)) return("badge-fehlend")
|
||||
if (wert == 1) "badge-positiv" else "badge-negativ"
|
||||
}
|
||||
|
||||
sortiere_items_pro_skala = function(item_info) {
|
||||
item_info$prioritaet = ifelse(is.na(item_info$wert), 3L, ifelse(item_info$wert == 1L, 1L, 2L))
|
||||
item_info[order(item_info$skala, item_info$prioritaet, item_info$item_nr), ]
|
||||
}
|
||||
|
||||
sichere_datumsparse = function(text) {
|
||||
formate = c("%Y-%m-%d", "%d.%m.%Y", "%Y-%m-%dT%H:%M:%S", "%Y-%m-%d %H:%M:%S")
|
||||
for (fmt in formate) {
|
||||
d = suppressWarnings(as.Date(text, format = fmt))
|
||||
if (!is.na(d)) return(d)
|
||||
}
|
||||
NA
|
||||
}
|
||||
|
||||
#### Datenaufbereitung ####
|
||||
|
||||
ERWARTETE_NORMTABELLEN = list(
|
||||
a = "skala_a_kontrollieren.csv",
|
||||
b = "skala_b_waschen.csv",
|
||||
c = "skala_c_ordnen.csv",
|
||||
d = "skala_d_zaehlen.csv",
|
||||
e = "skala_e_denken.csv",
|
||||
f = "skala_f_selbstfremdschaedigung.csv",
|
||||
gesamt = "gesamtskala.csv",
|
||||
p1 = "pruefskala_p1.csv",
|
||||
p2 = "pruefskala_p2.csv",
|
||||
p3 = "pruefskala_p3.csv",
|
||||
p4 = "pruefskala_p4.csv"
|
||||
)
|
||||
|
||||
if (!dir.exists(PFAD_NORMTABELLEN_ORDNER)) {
|
||||
stop(sprintf(
|
||||
"Normtabellen-Ordner nicht gefunden. Geprüfter Pfad: '%s'. Bitte die 11 Normtabellen-CSVs dort ablegen.",
|
||||
PFAD_NORMTABELLEN_ORDNER
|
||||
))
|
||||
}
|
||||
|
||||
normtabellen = list()
|
||||
for (schluessel in names(ERWARTETE_NORMTABELLEN)) {
|
||||
dateiname = ERWARTETE_NORMTABELLEN[[schluessel]]
|
||||
dateipfad = file.path(PFAD_NORMTABELLEN_ORDNER, dateiname)
|
||||
if (!file.exists(dateipfad)) {
|
||||
stop(sprintf(
|
||||
"Normtabelle fehlt: '%s'. Erwarteter Pfad: '%s'.",
|
||||
dateiname, dateipfad
|
||||
))
|
||||
}
|
||||
normtabellen[[schluessel]] = read_csv(
|
||||
dateipfad,
|
||||
col_types = cols(rohwert = col_integer(), stanine = col_integer()),
|
||||
show_col_types = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
pfad_differenzen = file.path(PFAD_NORMTABELLEN_ORDNER, "kritische_differenzen_skalenpaare.csv")
|
||||
if (!file.exists(pfad_differenzen)) {
|
||||
stop(sprintf(
|
||||
"Normtabelle fehlt: 'kritische_differenzen_skalenpaare.csv'. Erwarteter Pfad: '%s'.",
|
||||
pfad_differenzen
|
||||
))
|
||||
}
|
||||
normtabellen$differenzen = read_csv(
|
||||
pfad_differenzen,
|
||||
col_types = cols(
|
||||
skala_1 = col_character(),
|
||||
skala_2 = col_character(),
|
||||
d_crit_5proz = col_double(),
|
||||
d_crit_1proz = col_double()
|
||||
),
|
||||
show_col_types = FALSE
|
||||
)
|
||||
|
||||
#### UI ####
|
||||
|
||||
ui = fluidPage(
|
||||
tags$head(tags$style(HTML(app_css))),
|
||||
titlePanel("HZI (Langform) — Auswertung"),
|
||||
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("ergebnis_ui")
|
||||
)
|
||||
|
||||
#### Word-Export ####
|
||||
|
||||
erstelle_hzi_docx = function(erg) {
|
||||
doc = read_docx()
|
||||
|
||||
doc = doc %>% body_add_fpar(fpar(
|
||||
ftext(sprintf("HZI (Langform) — Auswertung — Chiffre %s — Ausfülldatum: %s",
|
||||
erg$chiffre, erg$ausfuelldatum_anzeige),
|
||||
fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18))
|
||||
))
|
||||
|
||||
if (!is.null(erg$ausfuelldatum_hinweis)) {
|
||||
doc = doc %>% body_add_fpar(fpar(ftext(erg$ausfuelldatum_hinweis, fp_text(italic = TRUE, font.size = 10))))
|
||||
}
|
||||
|
||||
if (length(erg$warnungen) > 0) {
|
||||
doc = doc %>% body_add_fpar(fpar(ftext("Hinweise", fp_text(bold = TRUE, font.size = 14))))
|
||||
for (w in erg$warnungen) {
|
||||
doc = doc %>% body_add_fpar(fpar(ftext(w, fp_text(color = "#B8860B", font.size = 11))))
|
||||
}
|
||||
}
|
||||
|
||||
if (!is.null(erg$mehrfach_hinweis)) {
|
||||
doc = doc %>% body_add_fpar(fpar(ftext(erg$mehrfach_hinweis, fp_text(color = "#B8860B", font.size = 11))))
|
||||
}
|
||||
|
||||
bild_pfad_profil = tempfile(fileext = ".png")
|
||||
ggsave(bild_pfad_profil, plot = erg$plot_profil, width = 7, height = 3.5, dpi = 150)
|
||||
doc = doc %>% body_add_img(src = bild_pfad_profil, width = 6, height = 3)
|
||||
|
||||
doc = doc %>% body_add_fpar(fpar(ftext(PRUEFSKALA_ERKLAERUNG, fp_text(italic = TRUE, font.size = 9))))
|
||||
|
||||
bild_pfad_pruef = tempfile(fileext = ".png")
|
||||
ggsave(bild_pfad_pruef, plot = erg$plot_pruefskalen, width = 7, height = 3.5, dpi = 150)
|
||||
doc = doc %>% body_add_img(src = bild_pfad_pruef, width = 6, height = 3)
|
||||
|
||||
doc = doc %>% body_add_fpar(fpar(ftext("Werteübersicht", fp_text(bold = TRUE, font.size = 14))))
|
||||
for (i in seq_len(nrow(erg$tabelle_werte))) {
|
||||
zeile = erg$tabelle_werte[i, ]
|
||||
doc = doc %>% body_add_fpar(fpar(ftext(sprintf(
|
||||
"%s — Rohwert: %s, Stanine: %s, ± CL(5%%): %s",
|
||||
zeile$name, zeile$rohwert, zeile$stanine_anzeige, zeile$ci_text
|
||||
), fp_text(font.size = 11))))
|
||||
}
|
||||
|
||||
doc = doc %>% body_add_fpar(fpar(ftext("Items pro Skala", fp_text(bold = TRUE, font.size = 14))))
|
||||
items_sortiert = sortiere_items_pro_skala(erg$item_info)
|
||||
status_farbe = c(stimmt = AKZENT_FARBE, "stimmt nicht" = "#666666", fehlend = "#B8860B")
|
||||
for (sk in names(SKALEN_NAMEN)) {
|
||||
doc = doc %>% body_add_fpar(fpar(ftext(
|
||||
sprintf("Skala %s – %s", sk, SKALEN_NAMEN[[sk]]), fp_text(bold = TRUE, font.size = 12)
|
||||
)))
|
||||
items_sk = items_sortiert[items_sortiert$skala == sk, ]
|
||||
for (i in seq_len(nrow(items_sk))) {
|
||||
zeile = items_sk[i, ]
|
||||
text_anzeige = if (is.na(zeile$item_text)) {
|
||||
sprintf("Item %s (kein Itemtext im Export vorhanden)", zeile$item_nr)
|
||||
} else {
|
||||
zeile$item_text
|
||||
}
|
||||
status = item_status_text(zeile$wert)
|
||||
doc = doc %>% body_add_fpar(fpar(
|
||||
ftext(sprintf("%s — %s — ", zeile$item_nr, text_anzeige), fp_text(font.size = 10)),
|
||||
ftext(status, fp_text(bold = TRUE, font.size = 10, color = status_farbe[[status]]))
|
||||
))
|
||||
}
|
||||
}
|
||||
|
||||
doc = doc %>% body_add_fpar(fpar(ftext(HZI_DISCLAIMER, fp_text(italic = TRUE, font.size = 9))))
|
||||
|
||||
doc
|
||||
}
|
||||
|
||||
#### Server ####
|
||||
|
||||
server = function(input, output, session) {
|
||||
# --- pseudonym-support-injection v1 ---
|
||||
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_roh = input$chiffre
|
||||
if (is.null(chiffre_roh) || (nchar(trimws(input$pseudonym)) == 0 && trimws(chiffre_roh) == "")) {
|
||||
return(list(ok = FALSE, meldung = "Bitte eine Patientenchiffre eingeben."))
|
||||
}
|
||||
|
||||
validierung = validiere_chiffre(chiffre_roh)
|
||||
if (!validierung$ok) {
|
||||
return(list(ok = FALSE, meldung = sprintf(
|
||||
"Chiffre '%s' hat kein gültiges Format (erwartet: ein Buchstabe gefolgt von 6 Ziffern, z.B. P000123).",
|
||||
validierung$chiffre
|
||||
)))
|
||||
}
|
||||
chiffre = validierung$chiffre
|
||||
|
||||
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
|
||||
return(list(ok = FALSE, meldung = sprintf(
|
||||
"Download-Skript nicht gefunden. Geprüfter Pfad: '%s'.", PFAD_DOWNLOAD_SKRIPT
|
||||
)))
|
||||
}
|
||||
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
|
||||
return(list(ok = FALSE, meldung = sprintf(
|
||||
"Pseudonym-Skript nicht gefunden. Geprüfter Pfad: '%s'.", PFAD_PSEUDONYM_SKRIPT
|
||||
)))
|
||||
}
|
||||
|
||||
ok = tryCatch({
|
||||
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
|
||||
list(ok = TRUE)
|
||||
}, error = function(e) list(ok = FALSE, msg = e$message))
|
||||
if (!ok$ok) {
|
||||
return(list(ok = FALSE, meldung = sprintf("Fehler beim Ausführen des Download-Skripts: %s", ok$msg)))
|
||||
}
|
||||
|
||||
db_ordner = NULL
|
||||
kandidat = dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT))
|
||||
for (i in 1:5) {
|
||||
if (file.exists(file.path(kandidat, "pseudonyme.db"))) {
|
||||
db_ordner = kandidat
|
||||
break
|
||||
}
|
||||
neuer_kandidat = dirname(kandidat)
|
||||
if (neuer_kandidat == kandidat) break
|
||||
kandidat = neuer_kandidat
|
||||
}
|
||||
if (is.null(db_ordner)) {
|
||||
return(list(ok = FALSE, meldung = "Datei 'pseudonyme.db' konnte in den übergeordneten Verzeichnissen des Pseudonym-Skripts nicht gefunden werden."))
|
||||
}
|
||||
|
||||
alter_wd = getwd()
|
||||
on.exit(setwd(alter_wd), add = TRUE)
|
||||
setwd(db_ordner)
|
||||
|
||||
ok2 = 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 (!ok2$ok) {
|
||||
return(list(ok = FALSE, meldung = sprintf("Fehler beim Ausführen des Pseudonym-Skripts: %s", ok2$msg)))
|
||||
}
|
||||
|
||||
if (!exists("daten_hzi", envir = .GlobalEnv)) {
|
||||
return(list(ok = FALSE, meldung = "Objekt 'daten_hzi' wurde nach dem Sourcen des Download-Skripts nicht gefunden."))
|
||||
}
|
||||
if (!exists("pseudo", envir = .GlobalEnv)) {
|
||||
return(list(ok = FALSE, meldung = "Objekt 'pseudo' wurde nach dem Sourcen des Pseudonym-Skripts nicht gefunden."))
|
||||
}
|
||||
daten_hzi = get("daten_hzi", envir = .GlobalEnv)
|
||||
pseudo = get("pseudo", envir = .GlobalEnv)
|
||||
|
||||
treffer_pseudo = pseudo[toupper(trimws(pseudo$chiffre)) == chiffre, ]
|
||||
if (nrow(treffer_pseudo) == 0) {
|
||||
return(list(ok = FALSE, meldung = sprintf("Keine Zuordnung für Chiffre '%s' in der Pseudonym-Tabelle gefunden.", chiffre)))
|
||||
}
|
||||
session_id = treffer_pseudo$pseudonym[1]
|
||||
if (nchar(trimws(input$pseudonym)) > 0) session_id = trimws(input$pseudonym)
|
||||
|
||||
treffer_daten = daten_hzi[daten_hzi$session == session_id |
|
||||
(("pseudonym" %in% colnames(daten_hzi)) && daten_hzi$pseudonym == session_id), ]
|
||||
if (nrow(treffer_daten) == 0 && "pseudonym" %in% colnames(daten_hzi)) {
|
||||
treffer_daten = daten_hzi[daten_hzi$pseudonym == session_id, ]
|
||||
}
|
||||
if (nrow(treffer_daten) == 0 && "session" %in% colnames(daten_hzi)) {
|
||||
treffer_daten = daten_hzi[daten_hzi$session == session_id, ]
|
||||
}
|
||||
if (nrow(treffer_daten) == 0) {
|
||||
return(list(ok = FALSE, meldung = sprintf("Keine HZI-Antworten für Chiffre '%s' (Session '%s') in den Exportdaten gefunden.", chiffre, session_id)))
|
||||
}
|
||||
|
||||
mehrfach_hinweis = NULL
|
||||
if (nrow(treffer_daten) > 1) {
|
||||
if ("created" %in% colnames(treffer_daten)) {
|
||||
treffer_daten = treffer_daten[order(treffer_daten$created, decreasing = TRUE), ]
|
||||
treffer_daten = treffer_daten[1, ]
|
||||
mehrfach_hinweis = "Hinweis: Der Bogen wurde mehrfach ausgefüllt. Es wurde die Auswertung mit dem neuesten Ausfülldatum verwendet."
|
||||
} else {
|
||||
treffer_daten = treffer_daten[1, ]
|
||||
mehrfach_hinweis = "Hinweis: Der Bogen wurde mehrfach ausgefüllt. Es konnte kein Ausfülldatum zur Auswahl der neuesten Version ermittelt werden, es wurde der erste Treffer verwendet."
|
||||
}
|
||||
}
|
||||
|
||||
ausfuelldatum_hinweis = NULL
|
||||
if ("created" %in% colnames(treffer_daten)) {
|
||||
ausfuelldatum = sichere_datumsparse(as.character(treffer_daten$created[1]))
|
||||
if (is.na(ausfuelldatum)) {
|
||||
ausfuelldatum = Sys.Date()
|
||||
ausfuelldatum_hinweis = "Ausfülldatum nicht in Exportdaten gefunden, Downloaddatum verwendet."
|
||||
}
|
||||
} else {
|
||||
ausfuelldatum = Sys.Date()
|
||||
ausfuelldatum_hinweis = "Ausfülldatum nicht in Exportdaten gefunden, Downloaddatum verwendet."
|
||||
}
|
||||
|
||||
item_info_roh = tryCatch(
|
||||
baue_item_info(daten_hzi),
|
||||
error = function(e) e
|
||||
)
|
||||
if (inherits(item_info_roh, "error")) {
|
||||
return(list(ok = FALSE, meldung = sprintf("Fehler bei der Item-Zuordnung: %s", conditionMessage(item_info_roh))))
|
||||
}
|
||||
|
||||
item_info = berechne_itemwerte(treffer_daten, item_info_roh)
|
||||
n_fehlend = sum(is.na(item_info$wert))
|
||||
|
||||
ergebnis_rohwerte = berechne_rohwerte(item_info)
|
||||
stanine_werte = tryCatch(
|
||||
berechne_stanine_alle(ergebnis_rohwerte$rohwerte, normtabellen),
|
||||
error = function(e) e
|
||||
)
|
||||
if (inherits(stanine_werte, "error")) {
|
||||
return(list(ok = FALSE, meldung = sprintf("Fehler bei der Stanine-Umrechnung: %s", conditionMessage(stanine_werte))))
|
||||
}
|
||||
|
||||
skalenpaar_differenzen = pruefe_skalenpaar_differenzen(stanine_werte, normtabellen$differenzen)
|
||||
streuung_hinweis = pruefskalen_streuung_hinweis(stanine_werte)
|
||||
dissim_hinweis = dissimulation_hinweis(ergebnis_rohwerte$gesamtrohwert)
|
||||
|
||||
warnungen = c()
|
||||
if (!is.null(dissim_hinweis)) warnungen = c(warnungen, dissim_hinweis)
|
||||
if (!is.null(streuung_hinweis)) warnungen = c(warnungen, streuung_hinweis$text)
|
||||
if (nrow(skalenpaar_differenzen) > 0) {
|
||||
for (i in seq_len(nrow(skalenpaar_differenzen))) {
|
||||
warnungen = c(warnungen, formatiere_skalenpaar_text(skalenpaar_differenzen[i, ]))
|
||||
}
|
||||
}
|
||||
if (n_fehlend > 0) {
|
||||
warnungen = c(warnungen, sprintf(
|
||||
"%s Item(s) wurden nicht beantwortet (fehlende Werte) und wurden bei der Rohwertberechnung nicht mitgezählt.",
|
||||
n_fehlend
|
||||
))
|
||||
}
|
||||
|
||||
tabelle_werte = data.frame(
|
||||
kennwert = names(stanine_werte),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
tabelle_werte$name = KENNWERT_NAMEN[tabelle_werte$kennwert]
|
||||
tabelle_werte$rohwert = ergebnis_rohwerte$rohwerte[tabelle_werte$kennwert]
|
||||
tabelle_werte$stanine_num = stanine_werte[tabelle_werte$kennwert]
|
||||
tabelle_werte$stanine_anzeige = ifelse(is.na(tabelle_werte$stanine_num), "–", as.character(tabelle_werte$stanine_num))
|
||||
tabelle_werte = merge(tabelle_werte, TABELLE_KONFIDENZINTERVALLE, by.x = "kennwert", by.y = "skala", sort = FALSE)
|
||||
tabelle_werte$ci_text = mapply(formatiere_ci_text, tabelle_werte$stanine_num, tabelle_werte$cl_5proz)
|
||||
reihenfolge = c("A","B","C","D","E","F","G","P1","P2","P3","P4")
|
||||
tabelle_werte = tabelle_werte[match(reihenfolge, tabelle_werte$kennwert), ]
|
||||
|
||||
list(
|
||||
ok = TRUE,
|
||||
chiffre = chiffre,
|
||||
ausfuelldatum = ausfuelldatum,
|
||||
ausfuelldatum_anzeige = format(ausfuelldatum, "%d.%m.%Y"),
|
||||
ausfuelldatum_hinweis = ausfuelldatum_hinweis,
|
||||
mehrfach_hinweis = mehrfach_hinweis,
|
||||
rohwerte = ergebnis_rohwerte$rohwerte,
|
||||
stanine_werte = stanine_werte,
|
||||
tabelle_werte = tabelle_werte,
|
||||
warnungen = warnungen,
|
||||
item_info = item_info
|
||||
)
|
||||
})
|
||||
|
||||
baue_profil_plot = function(erg) {
|
||||
daten = data.frame(
|
||||
skala = factor(names(SKALEN_NAMEN), levels = names(SKALEN_NAMEN)),
|
||||
stanine = as.numeric(erg$stanine_werte[names(SKALEN_NAMEN)])
|
||||
)
|
||||
ggplot(daten, aes(x = skala, y = stanine)) +
|
||||
geom_hline(yintercept = 5, linetype = "dashed", color = "grey40") +
|
||||
annotate("text", x = -Inf, y = 5.3, label = "Mittelwert Normstichprobe", hjust = -0.05, size = 3, color = "grey40") +
|
||||
geom_col(fill = AKZENT_FARBE, width = 0.5, na.rm = TRUE) +
|
||||
scale_y_continuous(limits = c(0, 9), breaks = 1:9) +
|
||||
labs(x = "Skala", y = "Stanine", title = "Profil Skalen A–F") +
|
||||
theme_minimal(base_size = 12)
|
||||
}
|
||||
|
||||
baue_pruefskalen_plot = function(erg) {
|
||||
daten = data.frame(
|
||||
skala = factor(c("P1","P2","P3","P4"), levels = c("P1","P2","P3","P4")),
|
||||
stanine = as.numeric(erg$stanine_werte[c("P1","P2","P3","P4")])
|
||||
)
|
||||
ggplot(daten, aes(x = skala, y = stanine)) +
|
||||
geom_hline(yintercept = 5, linetype = "dashed", color = "grey40") +
|
||||
annotate("text", x = -Inf, y = 5.3, label = "Mittelwert Normstichprobe", hjust = -0.05, size = 3, color = "grey40") +
|
||||
geom_col(fill = AKZENT_FARBE, width = 0.5, na.rm = TRUE) +
|
||||
scale_y_continuous(limits = c(0, 9), breaks = 1:9) +
|
||||
labs(x = "Prüfskala", y = "Stanine", title = "Profil Prüfskalen P1–P4") +
|
||||
theme_minimal(base_size = 12)
|
||||
}
|
||||
|
||||
baue_gesamt_plot = function(erg) {
|
||||
stanine_g = as.numeric(erg$stanine_werte["G"])
|
||||
daten = data.frame(x = 1:9, y = 1)
|
||||
ggplot(daten, aes(x = x, y = y)) +
|
||||
geom_col(fill = "grey85", width = 1, color = "white") +
|
||||
geom_col(data = data.frame(x = stanine_g, y = 1), aes(x = x, y = y), fill = AKZENT_FARBE, width = 1) +
|
||||
scale_x_continuous(breaks = 1:9, limits = c(0.5, 9.5)) +
|
||||
labs(x = "Stanine", y = NULL, title = "Gesamtskala G") +
|
||||
theme_minimal(base_size = 12) +
|
||||
theme(axis.text.y = element_blank(), axis.ticks.y = element_blank())
|
||||
}
|
||||
|
||||
output$ergebnis_ui = renderUI({
|
||||
erg = ergebnis_r()
|
||||
if (is.null(erg)) return(NULL)
|
||||
|
||||
if (!isTRUE(erg$ok)) {
|
||||
return(div(class = "alert-fehler", erg$meldung))
|
||||
}
|
||||
|
||||
blocks = list()
|
||||
|
||||
if (!is.null(erg$mehrfach_hinweis)) {
|
||||
blocks = c(blocks, list(div(class = "alert-warnung", erg$mehrfach_hinweis)))
|
||||
}
|
||||
if (!is.null(erg$ausfuelldatum_hinweis)) {
|
||||
blocks = c(blocks, list(div(class = "alert-warnung", erg$ausfuelldatum_hinweis)))
|
||||
}
|
||||
if (length(erg$warnungen) > 0) {
|
||||
blocks = c(blocks, list(
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Hinweise"),
|
||||
tags$ul(lapply(erg$warnungen, function(w) tags$li(class = "alert-warnung", w)))
|
||||
)
|
||||
))
|
||||
}
|
||||
|
||||
items_sortiert = sortiere_items_pro_skala(erg$item_info)
|
||||
|
||||
blocks = c(blocks, list(
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Profil Skalen A–F"),
|
||||
plotOutput("plot_profil", height = "320px")
|
||||
),
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Gesamtskala"),
|
||||
plotOutput("plot_gesamt", height = "180px"),
|
||||
p(sprintf("Rohwert: %s, Stanine: %s, ± CL(5%%): %s",
|
||||
erg$rohwerte[["G"]],
|
||||
ifelse(is.na(erg$stanine_werte[["G"]]), "–", erg$stanine_werte[["G"]]),
|
||||
erg$tabelle_werte[erg$tabelle_werte$kennwert == "G", "ci_text"]))
|
||||
),
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Prüfskalen P1–P4"),
|
||||
p(style = "font-style: italic; color: #555; font-size: 0.9em;", PRUEFSKALA_ERKLAERUNG),
|
||||
tags$table(class = "tabelle-werte",
|
||||
tags$thead(tags$tr(
|
||||
tags$th("Prüfskala"), tags$th("Rohwert"), tags$th("Stanine"), tags$th("± CL (5%)")
|
||||
)),
|
||||
tags$tbody(
|
||||
lapply(c("P1", "P2", "P3", "P4"), function(k) {
|
||||
zeile = erg$tabelle_werte[erg$tabelle_werte$kennwert == k, ]
|
||||
tags$tr(
|
||||
tags$td(zeile$name), tags$td(zeile$rohwert),
|
||||
tags$td(zeile$stanine_anzeige), tags$td(zeile$ci_text)
|
||||
)
|
||||
})
|
||||
)
|
||||
),
|
||||
plotOutput("plot_pruefskalen", height = "320px")
|
||||
),
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Werteübersicht"),
|
||||
tableOutput("tabelle_werte")
|
||||
),
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Items pro Skala"),
|
||||
lapply(names(SKALEN_NAMEN), function(sk) {
|
||||
items_sk = items_sortiert[items_sortiert$skala == sk, ]
|
||||
tags$details(
|
||||
tags$summary(sprintf("Skala %s – %s (Rohwert: %s)", sk, SKALEN_NAMEN[[sk]], erg$rohwerte[[sk]])),
|
||||
lapply(seq_len(nrow(items_sk)), function(i) {
|
||||
zeile = items_sk[i, ]
|
||||
text_anzeige = if (is.na(zeile$item_text)) {
|
||||
sprintf("Item %s (kein Itemtext im Export vorhanden)", zeile$item_nr)
|
||||
} else {
|
||||
zeile$item_text
|
||||
}
|
||||
div(class = "item-zeile",
|
||||
span(class = "item-nr", zeile$item_nr),
|
||||
span(class = "item-text", text_anzeige),
|
||||
span(class = paste("badge", item_status_klasse(zeile$wert)), item_status_text(zeile$wert))
|
||||
)
|
||||
})
|
||||
)
|
||||
})
|
||||
)
|
||||
))
|
||||
|
||||
div(blocks)
|
||||
})
|
||||
|
||||
output$plot_profil = renderPlot({
|
||||
erg = ergebnis_r()
|
||||
req(erg$ok)
|
||||
baue_profil_plot(erg)
|
||||
})
|
||||
|
||||
output$plot_pruefskalen = renderPlot({
|
||||
erg = ergebnis_r()
|
||||
req(erg$ok)
|
||||
baue_pruefskalen_plot(erg)
|
||||
})
|
||||
|
||||
output$plot_gesamt = renderPlot({
|
||||
erg = ergebnis_r()
|
||||
req(erg$ok)
|
||||
baue_gesamt_plot(erg)
|
||||
})
|
||||
|
||||
output$tabelle_werte = renderTable({
|
||||
erg = ergebnis_r()
|
||||
req(erg$ok)
|
||||
anzeige = erg$tabelle_werte[, c("name", "rohwert", "stanine_anzeige", "ci_text")]
|
||||
colnames(anzeige) = c("Skala/Kennwert", "Rohwert", "Stanine", "± CL (5%)")
|
||||
anzeige
|
||||
}, striped = TRUE, bordered = TRUE)
|
||||
|
||||
output$download_word = downloadHandler(
|
||||
filename = function() {
|
||||
erg = ergebnis_r()
|
||||
if (is.null(erg) || !isTRUE(erg$ok)) return("HZI_Auswertung.docx")
|
||||
datum_fn = format(erg$ausfuelldatum, "%Y%m%d")
|
||||
chiffre_esc = gsub("[^A-Za-z0-9]", "", erg$chiffre)
|
||||
paste0("HZI_", chiffre_esc, "_", datum_fn, ".docx")
|
||||
},
|
||||
content = function(file) {
|
||||
erg = ergebnis_r()
|
||||
req(erg$ok)
|
||||
erg$plot_profil = baue_profil_plot(erg)
|
||||
erg$plot_pruefskalen = baue_pruefskalen_plot(erg)
|
||||
doc = erstelle_hzi_docx(erg)
|
||||
print(doc, target = file)
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
#### Start ####
|
||||
|
||||
shinyApp(ui = ui, server = server)
|
||||
Loading…
Add table
Add a link
Reference in a new issue