620 lines
23 KiB
R
620 lines
23 KiB
R
# Präambel ####
|
|
|
|
# Pfade zu den beiden extern gepflegten Skripten, die den eigentlichen Datenzugriff
|
|
# uebernehmen. Diese App selbst spricht NIE direkt mit der formr-API und oeffnet NIE
|
|
# direkt die SQLite-Pseudonymdatenbank - das passiert ausschliesslich in diesen beiden
|
|
# Skripten.
|
|
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_whiteley.R" # liefert beim Sourcen: daten_whiteley
|
|
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert beim Sourcen: pseudo
|
|
AKZENT_FARBE = "#8B2635"
|
|
|
|
# Pflicht-Disclaimer, der am Ende jedes Word-Exports erscheint.
|
|
WHITELEY_DISCLAIMER = paste0(
|
|
"Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
|
|
"keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person."
|
|
)
|
|
|
|
# Vierstufige Cutoff-Klassifikation (Summenscore 0-14), woertliche Texte aus der
|
|
# lizenzierten Auswertungsvorschrift (auswertung_normen_gbb.md Abschnitt 4.2).
|
|
WHITELEY_KLASSIFIKATION = list(
|
|
list(von = 0, bis = 2, text = "Kein Hinweis auf hypochondrische Störung. Sie machen sich keine unbegründeten Sorgen um Ihre Gesundheit und scheinen gut mit Ihrem Körper im Einklang zu leben."),
|
|
list(von = 3, bis = 6, text = "Es besteht bei Ihnen ein leichter Hang zur Hypochondrie. Es kommt vor, dass Sie sich vermehrt Sorgen um Ihre Gesundheit machen. Allgemein achten Sie stärker auf Ihren Körper als andere. Bei Interesse an einer eindeutigen Abklärung kann ein Arztbesuch helfen."),
|
|
list(von = 7, bis = 10, text = "Sie haben einen erhöhten Wert erreicht. Sie achten vermehrt auf Ihren Körper und machen sich oft Gedanken um Ihre Gesundheit. Häufig haben Sie das Gefühl, dass man Sie wegen Ihrer körperlichen Sorgen nicht ernst nimmt. Eine ärztliche Abklärung ist ernsthaft angeraten."),
|
|
list(von = 11, bis = 14, text = "Sie haben einen sehr hohen Wert erreicht. Sie leiden unter ausgeprägten Krankheitsängsten und sollten einen Psychologen oder Arzt für Psychiatrie aufsuchen.")
|
|
)
|
|
|
|
# Klassifikationsfarben fuer Gauge, Diagnose-Box und Word-Export (aufsteigend
|
|
# gruen -> gelb -> orange -> rot, konsistent mit dem Badge-Farbmuster anderer
|
|
# Instrumente in diesem Projekt). Eigene Variablen, nicht mit AKZENT_FARBE
|
|
# zu verwechseln.
|
|
WI_FARBE_STUFE_1 = "#2E7D32"
|
|
WI_FARBE_STUFE_2 = "#F57F17"
|
|
WI_FARBE_STUFE_3 = "#E65100"
|
|
WI_FARBE_STUFE_4 = "#B71C1C"
|
|
|
|
# Passende Pastelltoene fuer Hintergrundflaechen (Gauge-Zonen, Diagnose-Box).
|
|
WI_FARBE_STUFE_1_BG = "#E8F5E9"
|
|
WI_FARBE_STUFE_2_BG = "#FFF8E1"
|
|
WI_FARBE_STUFE_3_BG = "#FFF3E0"
|
|
WI_FARBE_STUFE_4_BG = "#FFEBEE"
|
|
|
|
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)
|
|
|
|
|
|
# Helper ####
|
|
|
|
# Entfernt formr-Nummerierungsartefakte am Anfang des Itemtexts (z.B. "1. ",
|
|
# "01) " oder mit Markdown-Escape wie "1\. ", das die Original-xlsx nutzt, um
|
|
# die automatische Markdown-Listeninterpretation von "1." zu verhindern) -
|
|
# die Itemnummer wird separat als eigenes Element angezeigt. Zwei Durchgaenge,
|
|
# damit auch ein nach der Nummer verbleibendes, alleinstehendes Escape-Trennzeichen
|
|
# vollstaendig verschwindet.
|
|
clean_item_label = function(text) {
|
|
if (is.null(text) || length(text) == 0 || is.na(text[1])) return(NA_character_)
|
|
x = trimws(as.character(text[1]))
|
|
x = sub("^(?:\\s*\\d+\\\\?[.)]?\\s*)+", "", x, perl = TRUE)
|
|
x = sub("^\\\\?[.)]\\s*", "", x, perl = TRUE)
|
|
trimws(x)
|
|
}
|
|
|
|
# Loest den Antwort-Ankertext ("Ja"/"Nein") ausschliesslich ueber das
|
|
# labels-Attribut der ORIGINAL-Spalte auf. Die Choice-Reihenfolge in der
|
|
# Whiteley-Vorlage ist Ja/Nein statt der sonst ueblichen Nein/Ja-Konvention -
|
|
# deshalb wird hier NIE eine feste Zahl-zu-Ja/Nein-Zuordnung angenommen.
|
|
wi_get_anker = function(original_col, wert) {
|
|
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_character_)
|
|
lbl_attr = attr(original_col, "labels")
|
|
if (!is.null(lbl_attr) && length(lbl_attr) > 0) {
|
|
pos = which(as.vector(lbl_attr) == as.numeric(wert[1]))
|
|
if (length(pos) > 0) return(trimws(names(lbl_attr)[pos[1]]))
|
|
}
|
|
NA_character_
|
|
}
|
|
|
|
# Punktvergabe ausschliesslich ueber den aufgeloesten Ankertext, nie ueber die
|
|
# gespeicherte Rohzahl.
|
|
wi_ist_ja = function(anker_text) {
|
|
!is.na(anker_text) && identical(anker_text, "Ja")
|
|
}
|
|
|
|
# Ordnet einem Summenscore (0-14) die passende Klassifikationsstufe zu.
|
|
# Defensiv: Werte ausserhalb 0-14 fuehren zu einem NA-Ergebnis statt
|
|
# stillschweigend die letzte Kategorie zu waehlen.
|
|
wi_klassifikation = function(score) {
|
|
farben = c(WI_FARBE_STUFE_1, WI_FARBE_STUFE_2, WI_FARBE_STUFE_3, WI_FARBE_STUFE_4)
|
|
farben_bg = c(WI_FARBE_STUFE_1_BG, WI_FARBE_STUFE_2_BG, WI_FARBE_STUFE_3_BG, WI_FARBE_STUFE_4_BG)
|
|
|
|
if (is.null(score) || length(score) == 0 || is.na(score) ||
|
|
score < 0 || score > 14) {
|
|
return(list(stufe = NA_integer_, von = NA, bis = NA,
|
|
text = NA_character_, farbe = "#888888", farbe_bg = "#EEEEEE"))
|
|
}
|
|
|
|
for (i in seq_along(WHITELEY_KLASSIFIKATION)) {
|
|
kat = WHITELEY_KLASSIFIKATION[[i]]
|
|
if (score >= kat$von && score <= kat$bis) {
|
|
return(list(stufe = i, von = kat$von, bis = kat$bis, text = kat$text,
|
|
farbe = farben[i], farbe_bg = farben_bg[i]))
|
|
}
|
|
}
|
|
|
|
# Sollte bei Score 0-14 nie erreicht werden (Bereiche decken 0-14 lueckenlos ab).
|
|
list(stufe = NA_integer_, von = NA, bis = NA,
|
|
text = NA_character_, farbe = "#888888", farbe_bg = "#EEEEEE")
|
|
}
|
|
|
|
make_gauge_whiteley = function(score) {
|
|
zonen = data.frame(
|
|
von = sapply(WHITELEY_KLASSIFIKATION, function(k) k$von),
|
|
bis = sapply(WHITELEY_KLASSIFIKATION, function(k) k$bis),
|
|
farbe = c(WI_FARBE_STUFE_1_BG, WI_FARBE_STUFE_2_BG, WI_FARBE_STUFE_3_BG, WI_FARBE_STUFE_4_BG),
|
|
stringsAsFactors = FALSE
|
|
)
|
|
zonen$zone = factor(seq_len(nrow(zonen)), levels = seq_len(nrow(zonen)))
|
|
zonen$mitte = (zonen$von + zonen$bis) / 2
|
|
zonen$label = paste0(zonen$von, "-", zonen$bis)
|
|
|
|
p = ggplot() +
|
|
geom_rect(data = zonen,
|
|
aes(xmin = von, xmax = bis + 1, ymin = 0, ymax = 1, fill = zone),
|
|
colour = "white", linewidth = 1) +
|
|
scale_fill_manual(values = setNames(zonen$farbe, zonen$zone), guide = "none") +
|
|
annotate("text", x = zonen$mitte + 0.5, y = 0.5, label = zonen$label,
|
|
size = 3.4, colour = "#444444", fontface = "bold") +
|
|
scale_x_continuous(limits = c(0, 15), expand = c(0, 0), breaks = c(0, 3, 7, 11, 15)) +
|
|
scale_y_continuous(limits = c(-0.25, 1.35), expand = c(0, 0)) +
|
|
labs(x = "Summenscore (0-14)", y = NULL) +
|
|
theme_minimal(base_size = 11) +
|
|
theme(
|
|
axis.text.y = element_blank(),
|
|
axis.ticks.y = element_blank(),
|
|
panel.grid = element_blank(),
|
|
plot.background = element_rect(fill = "white", colour = NA),
|
|
panel.background = element_rect(fill = "white", colour = NA),
|
|
axis.line.x = element_line(colour = "#cccccc", linewidth = 0.5),
|
|
axis.text.x = element_text(colour = "#666666", size = 9)
|
|
)
|
|
|
|
if (!is.na(score)) {
|
|
p = p +
|
|
geom_segment(aes(x = score + 0.5, xend = score + 0.5, y = -0.1, yend = 1.1),
|
|
colour = AKZENT_FARBE, linewidth = 2.5, lineend = "round") +
|
|
annotate("text", x = score + 0.5, y = 1.26, label = as.character(score),
|
|
colour = AKZENT_FARBE, fontface = "bold", size = 4.2)
|
|
}
|
|
|
|
p
|
|
}
|
|
|
|
|
|
# UI ####
|
|
|
|
app_css = "
|
|
body { font-family: 'Segoe UI', Arial, sans-serif; background: #f5f5f5; }
|
|
.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;
|
|
}
|
|
.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; }
|
|
.score-zahl { font-size: 2.2rem; font-weight: 800; color: #8B2635; }
|
|
.cutoff-info { font-size: 0.88em; color: #555; margin-top: 4px; }
|
|
.item-zeile {
|
|
display: flex; align-items: flex-start; gap: 10px;
|
|
padding: 7px 0; border-bottom: 1px solid #F0F0F0;
|
|
}
|
|
.item-nr { font-weight: 600; color: #8B2635; min-width: 26px; flex-shrink: 0; }
|
|
.item-text { flex: 1; color: #333; font-size: 0.92em; }
|
|
.item-zeile.ist-ja {
|
|
background: #FDECEA; border-radius: 4px; padding-left: 8px;
|
|
border-bottom: 1px solid #F5D5D2;
|
|
}
|
|
.item-zeile.ist-ja .item-text { color: #8B2635; font-weight: 600; }
|
|
"
|
|
|
|
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("Whiteley-Index"),
|
|
tags$p("Krankheitsangst-Screening | 14 Ja/Nein-Items, Summenscore 0-14")
|
|
),
|
|
|
|
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_whiteley_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_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
|
|
|
|
kl = erg$klassifikation
|
|
|
|
fp_score = fp_text(bold = TRUE, font.size = 14, color = kl$farbe)
|
|
fp_kat_text = fp_text(font.size = 11, color = kl$farbe, shading.color = kl$farbe_bg)
|
|
|
|
fp_ja = fp_text(font.size = 10, bold = TRUE, color = AKZENT_FARBE, shading.color = "#FDECEA")
|
|
fp_nein = fp_text(font.size = 10, color = "#555555")
|
|
|
|
doc = body_add_fpar(doc, fpar(ftext("Whiteley-Index - Einzelauswertung", fp_titel)))
|
|
doc = body_add_fpar(doc, fpar(
|
|
ftext("Chiffre: ", fp_label),
|
|
ftext(erg$chiffre, fp_normal),
|
|
ftext(" Ausfülldatum: ", fp_label),
|
|
ftext(erg$datum_str, fp_normal)
|
|
))
|
|
if (!is.null(erg$info_mehrere)) {
|
|
doc = body_add_fpar(doc, fpar(
|
|
ftext(erg$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("Auswertung", fp_abschnitt)))
|
|
doc = body_add_fpar(doc, fpar(
|
|
ftext("Summenscore: ", fp_label),
|
|
ftext(paste0(erg$summenscore, " / 14"), fp_score)
|
|
))
|
|
doc = body_add_par(doc, "", style = "Normal")
|
|
|
|
doc = body_add_fpar(doc, fpar(ftext("Klassifikation", fp_abschnitt)))
|
|
doc = body_add_fpar(doc, fpar(ftext(kl$text, fp_kat_text)))
|
|
doc = body_add_par(doc, "", style = "Normal")
|
|
|
|
doc = body_add_fpar(doc, fpar(ftext("Whiteley-Index Einzelitems", fp_abschnitt)))
|
|
|
|
for (i in seq_len(14)) {
|
|
item_txt = if (!is.na(erg$item_texte[i])) erg$item_texte[i] else paste0("Item ", i)
|
|
anker = erg$anker_texte[i]
|
|
anker_txt = if (!is.na(anker)) anker else "k. A."
|
|
ist_ja = wi_ist_ja(anker)
|
|
|
|
doc = body_add_fpar(doc, fpar(
|
|
ftext(paste0(i, ". ", item_txt, " "), fp_normal),
|
|
ftext(paste0(" ", anker_txt, " "), if (ist_ja) fp_ja else fp_nein)
|
|
))
|
|
}
|
|
|
|
doc = body_add_par(doc, "", style = "Normal")
|
|
doc = body_add_fpar(doc, fpar(ftext(WHITELEY_DISCLAIMER, fp_disclaimer)))
|
|
|
|
doc
|
|
}
|
|
|
|
|
|
# Server ####
|
|
|
|
server = function(input, output, session) {
|
|
|
|
observe({
|
|
query = parseQueryString(session$clientData$url_search)
|
|
if (!is.null(query$pseudonym) && nchar(trimws(query$pseudonym)) > 0) {
|
|
updateTextInput(session, "pseudonym", value = trimws(query$pseudonym))
|
|
}
|
|
})
|
|
|
|
observe({
|
|
query = parseQueryString(session$clientData$url_search)
|
|
if (!is.null(query$chiffre) && nchar(trimws(query$chiffre)) > 0) {
|
|
updateTextInput(session, "chiffre", value = toupper(trimws(query$chiffre)))
|
|
}
|
|
})
|
|
|
|
ergebnis_r = eventReactive(input$btn_suchen, {
|
|
|
|
chiffre = toupper(trimws(input$chiffre))
|
|
|
|
if (nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0) {
|
|
return(list(typ = "leere_eingabe", meldung = "Bitte Chiffre oder Pseudonym eingeben."))
|
|
}
|
|
if (nchar(trimws(input$pseudonym)) == 0 && !grepl("^[A-Z][0-9]{6}$", chiffre)) {
|
|
return(list(typ = "format_fehler", chiffre = chiffre,
|
|
meldung = paste0(
|
|
"Ungültige Chiffre '", chiffre, "'. Erwartet: ein Großbuchstabe + ",
|
|
"6 Ziffern (z.B. P000123).")))
|
|
}
|
|
|
|
if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
|
|
return(list(typ = "skript_fehler", meldung = paste0(
|
|
"Download-Skript nicht gefunden:\n", PFAD_DOWNLOAD_SKRIPT)))
|
|
}
|
|
if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
|
|
return(list(typ = "skript_fehler", meldung = paste0(
|
|
"Pseudonym-Skript nicht gefunden:\n", 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(typ = "skript_fehler",
|
|
meldung = paste0("Fehler im Download-Skript: ", ok$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)
|
|
|
|
ok_ps = tryCatch({
|
|
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
|
|
list(ok = TRUE)
|
|
}, error = function(e) list(ok = FALSE, msg = e$message))
|
|
if (!ok_ps$ok) {
|
|
return(list(typ = "skript_fehler",
|
|
meldung = paste0("Fehler im Pseudonym-Skript: ", ok_ps$msg)))
|
|
}
|
|
|
|
if (!exists("daten_whiteley", envir = .GlobalEnv)) {
|
|
return(list(typ = "skript_fehler", meldung = paste0(
|
|
"Objekt 'daten_whiteley' nach dem Sourcen nicht gefunden. ",
|
|
"Bitte Download-Skript prüfen.")))
|
|
}
|
|
if (!exists("pseudo", envir = .GlobalEnv)) {
|
|
return(list(typ = "skript_fehler", meldung = paste0(
|
|
"Objekt 'pseudo' nach dem Sourcen nicht gefunden. ",
|
|
"Bitte Pseudonym-Skript prüfen.")))
|
|
}
|
|
|
|
daten = get("daten_whiteley", envir = .GlobalEnv)
|
|
pseudo_df = get("pseudo", envir = .GlobalEnv)
|
|
|
|
if (nchar(trimws(input$pseudonym)) > 0) {
|
|
pw_treffer = pseudo_df[pseudo_df$pseudonym == trimws(input$pseudonym), ]
|
|
if (nrow(pw_treffer) > 0) chiffre = toupper(trimws(pw_treffer$chiffre[1]))
|
|
}
|
|
|
|
treffer_ps = pseudo_df[pseudo_df$chiffre == chiffre, ]
|
|
if (nrow(treffer_ps) == 0) {
|
|
return(list(typ = "kein_treffer", meldung = 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(typ = "kein_treffer", meldung = paste0(
|
|
"Kein Whiteley-Index-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]
|
|
datum_str = tryCatch(
|
|
format(as.POSIXct(zeile[["created"]][1]), "%d.%m.%Y"),
|
|
error = function(e) format(Sys.Date(), "%d.%m.%Y")
|
|
)
|
|
|
|
item_texte = sapply(seq_len(14), function(i) {
|
|
var = paste0("wi_", sprintf("%02d", i))
|
|
clean_item_label(attr(daten[[var]], "label"))
|
|
})
|
|
anker_texte = sapply(seq_len(14), function(i) {
|
|
var = paste0("wi_", sprintf("%02d", i))
|
|
wi_get_anker(daten[[var]], zeile[[var]])
|
|
})
|
|
ist_ja_vec = sapply(anker_texte, wi_ist_ja)
|
|
|
|
summenscore = sum(ist_ja_vec, na.rm = TRUE)
|
|
klassifikation = wi_klassifikation(summenscore)
|
|
|
|
list(
|
|
typ = "erfolg",
|
|
chiffre = chiffre,
|
|
datum_str = datum_str,
|
|
info_mehrere = info_mehrere,
|
|
item_texte = item_texte,
|
|
anker_texte = anker_texte,
|
|
ist_ja_vec = ist_ja_vec,
|
|
summenscore = summenscore,
|
|
klassifikation = klassifikation
|
|
)
|
|
})
|
|
|
|
output$fehler_ui = renderUI({
|
|
req(input$btn_suchen)
|
|
erg = ergebnis_r()
|
|
if (erg$typ %in% c("leere_eingabe", "format_fehler", "skript_fehler", "kein_treffer")) {
|
|
div(class = "alert-fehler", erg$meldung)
|
|
}
|
|
})
|
|
|
|
output$warnung_ui = renderUI({
|
|
req(input$btn_suchen)
|
|
erg = ergebnis_r()
|
|
if (!identical(erg$typ, "erfolg") || is.null(erg$info_mehrere)) return(NULL)
|
|
div(class = "alert-warnung", erg$info_mehrere)
|
|
})
|
|
|
|
output$ergebnis_ui = renderUI({
|
|
req(input$btn_suchen)
|
|
erg = ergebnis_r()
|
|
if (!identical(erg$typ, "erfolg")) return(NULL)
|
|
|
|
kl = erg$klassifikation
|
|
|
|
items_ui = lapply(seq_len(14), function(i) {
|
|
item_txt = if (!is.na(erg$item_texte[i])) erg$item_texte[i] else paste0("Item ", i)
|
|
anker = erg$anker_texte[i]
|
|
anker_txt = if (!is.na(anker)) anker else "k. A."
|
|
ist_ja = isTRUE(erg$ist_ja_vec[i])
|
|
|
|
div(class = paste("item-zeile", if (ist_ja) "ist-ja"),
|
|
div(class = "item-nr", paste0(i, ".")),
|
|
div(class = "item-text", item_txt),
|
|
div(style = "min-width: 50px; text-align: right; font-weight: 600;",
|
|
anker_txt)
|
|
)
|
|
})
|
|
|
|
div(class = "abschnitt-karte",
|
|
div(class = "abschnitt-titel", "Whiteley-Index"),
|
|
|
|
div(class = "meta-block",
|
|
tags$strong("Chiffre: "), erg$chiffre,
|
|
tags$span(" | ", style = "color:#ccc;"),
|
|
tags$strong("Ausfülldatum: "), erg$datum_str
|
|
),
|
|
|
|
tags$hr(),
|
|
|
|
fluidRow(
|
|
column(3,
|
|
div(
|
|
div(class = "score-zahl", erg$summenscore),
|
|
div("Summenscore (0-14)", style = "color:#555;"),
|
|
div(class = "cutoff-info",
|
|
tags$span(style = paste0("color:", kl$farbe, "; font-weight:600;"),
|
|
paste0("Bereich ", kl$von, "-", kl$bis))
|
|
)
|
|
)
|
|
),
|
|
column(9, plotOutput("gauge_plot", height = "160px"))
|
|
),
|
|
|
|
tags$hr(),
|
|
|
|
tags$h5("Klassifikation"),
|
|
div(style = paste0(
|
|
"border-left: 5px solid ", kl$farbe, "; background: ", kl$farbe_bg, "; ",
|
|
"border-radius: 4px; padding: 14px 18px; margin: 12px 0; ",
|
|
"color: ", kl$farbe, "; font-size: 0.95em; line-height: 1.55;"),
|
|
kl$text
|
|
),
|
|
|
|
tags$hr(),
|
|
|
|
tags$h5("Whiteley-Index Einzelitems"),
|
|
div(items_ui)
|
|
)
|
|
})
|
|
|
|
output$gauge_plot = renderPlot({
|
|
req(input$btn_suchen)
|
|
erg = ergebnis_r()
|
|
req(identical(erg$typ, "erfolg"))
|
|
make_gauge_whiteley(erg$summenscore)
|
|
}, bg = "transparent")
|
|
|
|
output$download_word = downloadHandler(
|
|
filename = function() {
|
|
erg = tryCatch(ergebnis_r(), error = function(e) NULL)
|
|
erfolg = is.list(erg) && identical(erg$typ, "erfolg")
|
|
chiffre_esc = if (erfolg) gsub("[^A-Za-z0-9_-]", "_", erg$chiffre) else "export"
|
|
ausfuelldatum_fn = if (erfolg) {
|
|
tryCatch(format(as.Date(erg$datum_str, "%d.%m.%Y"), "%Y%m%d"),
|
|
error = function(e) format(Sys.Date(), "%Y%m%d"))
|
|
} else {
|
|
format(Sys.Date(), "%Y%m%d")
|
|
}
|
|
paste0("Whiteley_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
|
|
},
|
|
content = function(file) {
|
|
erg = tryCatch(ergebnis_r(), error = function(e) NULL)
|
|
erfolg = is.list(erg) && identical(erg$typ, "erfolg")
|
|
if (!erfolg) {
|
|
doc = read_docx()
|
|
doc = body_add_par(doc,
|
|
"Kein Datensatz geladen. Bitte zuerst Chiffre eingeben und 'Auswerten' klicken.",
|
|
style = "Normal")
|
|
print(doc, target = file)
|
|
return()
|
|
}
|
|
doc = tryCatch(
|
|
erstelle_whiteley_docx(erg),
|
|
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)
|