# Präambel #### library(shiny) library(dplyr) library(ggplot2) library(haven) library(officer) library(DBI) library(RSQLite) # Infrastruktur #### # Beide Formen teilen sich dasselbe Download-Skript (liefert vermutlich sowohl # daten_desci als auch daten_descii); analog zum Muster in bdi2/pg13r. PFAD_DOWNLOAD_SKRIPT_DESC1 = "../API/get_data_desci.R" PFAD_DOWNLOAD_SKRIPT_DESC2 = "../API/get_data_descii.R" PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" AKZENT_FARBE = "#8B2635" # Hinweis (verifiziert 2026-07-01): pseudo$instrument ist ein reines Freitext-Notizfeld # in der lokalen SQLite-Pseudonym-Datenbank, nicht zuverlaessig befuellt und daher NICHT # fuer die Form-Zuordnung nutzbar. Die Zuordnung zur richtigen Form ergibt sich stattdessen # implizit daraus, in welchem der beiden daten_desci/daten_descii-Datensaetze die per # Chiffre gefundene Session-ID tatsaechlich vorkommt (siehe Server-Logik). DESC_DISCLAIMER = paste0( "Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ", "keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person." ) APP_VERZEICHNIS = normalizePath(getwd()) absPath = function(pfad) { if (grepl("^([A-Za-z]:[/\\\\]|/)", pfad)) return(pfad) file.path(APP_VERZEICHNIS, pfad) } PFAD_DOWNLOAD_SKRIPT_DESC1 = normalizePath(absPath(PFAD_DOWNLOAD_SKRIPT_DESC1), mustWork = FALSE) PFAD_DOWNLOAD_SKRIPT_DESC2 = normalizePath(absPath(PFAD_DOWNLOAD_SKRIPT_DESC2), mustWork = FALSE) PFAD_PSEUDONYM_SKRIPT = normalizePath(absPath(PFAD_PSEUDONYM_SKRIPT), mustWork = FALSE) # Helper #### STUFE_FARBEN = c("0" = "#4CAF50", "1" = "#F9A825", "2" = "#EF6C00", "3" = "#C62828", "4" = "#6D0000") STUFE_TEXT_FARBEN = c("0" = "#FFFFFF", "1" = "#333333", "2" = "#FFFFFF", "3" = "#FFFFFF", "4" = "#FFFFFF") # Konfiguration je Form buendeln, damit Server-Logik und Rendering nicht ueberall # zwischen DESC-I/DESC-II verzweigen muessen. desc_konfiguration = function(form) { if (form == "desc1") { return(list( form = "desc1", label = "DESC-I", praefix = "desci_", item_texte = ITEM_TEXTE_DESC1, kritisch_index = KRITISCH_INDEX_DESC1, download_skript = PFAD_DOWNLOAD_SKRIPT_DESC1, normtabelle = NORMTABELLE_DESC1, grenzwert_max = 28, daten_objekt = "daten_desci" )) } list( form = "desc2", label = "DESC-II", praefix = "descii_", item_texte = ITEM_TEXTE_DESC2, kritisch_index = KRITISCH_INDEX_DESC2, download_skript = PFAD_DOWNLOAD_SKRIPT_DESC2, normtabelle = NORMTABELLE_DESC2, grenzwert_max = 31, daten_objekt = "daten_descii" ) } # Stufe (0-4) ausschliesslich ueber den Antworttext ableiten, niemals ueber den rohen # Zahlenwert - formr liefert dbl+lbl (haven/labelled), dessen Rohwert nicht verlaesslich # der inhaltlichen Stufe entspricht. Bei unbekanntem Antworttext klarer Fehler statt NA. lese_item_stufe = function(spalte_orig, wert, item_bezeichnung) { if (is.na(wert)) { stop(paste0("Item '", item_bezeichnung, "': Antwortwert fehlt (NA), ", "Stufe kann nicht ermittelt werden.")) } lbl = attr(spalte_orig, "labels") antwort_text = NA_character_ if (!is.null(lbl) && length(lbl) > 0) { idx = which(as.numeric(lbl) == as.numeric(wert)) if (length(idx) > 0) antwort_text = names(lbl)[idx[1]] } if (is.na(antwort_text)) { antwort_text = as.character(haven::as_factor(wert)) } antwort_text = trimws(antwort_text) if (!(antwort_text %in% names(DESC_STUFEN_TEXT))) { stop(paste0( "Item '", item_bezeichnung, "': Unbekannter Antworttext '", antwort_text, "' - erwartet wird einer von: ", paste(names(DESC_STUFEN_TEXT), collapse = ", ") )) } list(stufe = as.integer(DESC_STUFEN_TEXT[[antwort_text]]), text = antwort_text) } desc_klassifikation = function(summenwert) { if (summenwert >= 12) { return(list(text = "Hinweis auf wahrscheinliches Vorliegen einer depressiven Episode", farbe = "#C62828")) } list(text = "unauffaellig (kein Hinweis auf depressive Episode)", farbe = "#388E3C") } # Nur exakte Summenwert-Treffer nachschlagen; fehlt der Wert, den naechstniedrigeren # Tabelleneintrag verwenden (keine Interpolation/Extrapolation) und das kennzeichnen. # Werte am/oberhalb des Tabellenmaximums sind in der Quelle als ">= grenzwert_max" # gekennzeichnet und werden entsprechend als Grenzwert, nicht als exakter Treffer, markiert. normwert_lookup = function(tabelle, summenwert, grenzwert_max) { if (summenwert >= grenzwert_max) { zeile = tabelle[tabelle$summenwert == grenzwert_max, ] return(list( prozentrang = zeile$prozentrang[1], t = zeile$t[1], z = zeile$z[1], exakt = FALSE, verwendeter_summenwert = grenzwert_max, warnung = paste0("Wert >= ", grenzwert_max, ", siehe Tabellenmaximum.") )) } treffer = tabelle[tabelle$summenwert == summenwert, ] if (nrow(treffer) == 1) { return(list( prozentrang = treffer$prozentrang[1], t = treffer$t[1], z = treffer$z[1], exakt = TRUE, verwendeter_summenwert = summenwert, warnung = NULL )) } kandidaten = tabelle[tabelle$summenwert < summenwert, ] naechst = kandidaten[which.max(kandidaten$summenwert), ] list( prozentrang = naechst$prozentrang[1], t = naechst$t[1], z = naechst$z[1], exakt = FALSE, verwendeter_summenwert = naechst$summenwert[1], warnung = paste0("Kein exakter Normwert fuer Summenwert ", summenwert, " verfuegbar, Werte fuer naechstniedrigeren Tabelleneintrag (", naechst$summenwert[1], ") angezeigt.") ) } make_gauge_desc = function(summenwert) { zonen = data.frame( xmin = c(0, 12), xmax = c(12, 40), farbe = c("#C8E6C9", "#FFCDD2"), stringsAsFactors = FALSE ) ggplot() + geom_rect(data = zonen, aes(xmin = xmin, xmax = xmax, ymin = 0, ymax = 1, fill = farbe), color = "white", linewidth = 0.6) + scale_fill_identity() + geom_vline(xintercept = 12, linetype = "dashed", color = "#B71C1C", linewidth = 0.8) + annotate("text", x = 12, y = 1.32, label = "Cutoff: 12", color = "#B71C1C", size = 3.2, fontface = "bold") + geom_segment(aes(x = summenwert, xend = summenwert, y = 0, yend = 1.15), color = "#212121", linewidth = 1) + geom_point(aes(x = summenwert, y = 1.28), shape = 17, size = 4, color = "#212121") + scale_x_continuous(limits = c(0, 40), expand = c(0, 0), breaks = c(0, 12, 20, 30, 40)) + scale_y_continuous(limits = c(0, 1.5), expand = c(0, 0)) + theme_minimal(base_size = 10) + theme( axis.text.y = element_blank(), axis.ticks.y = element_blank(), panel.grid = element_blank(), axis.title = element_blank(), axis.text.x = element_text(color = "#555555"), plot.margin = margin(t = 8, r = 12, b = 0, l = 12), plot.background = element_rect(fill = "white", color = NA), panel.background = element_rect(fill = "white", color = NA) ) } # Datenaufbereitung #### DESC_STUFEN_TEXT = c("nie" = 0, "selten" = 1, "manchmal" = 2, "meistens" = 3, "immer" = 4) ITEM_TEXTE_DESC1 = c( "...waren Sie traurig?", "...sahen Sie Selbstmord als moeglichen Ausweg?", "...fuehlten Sie sich leer?", "...dachten Sie, Ihr Leben sei ein einziger Fehlschlag?", "...waren Sie hoffnungslos angesichts der Zukunft?", "...waren Sie verzweifelt?", "...fuehlten Sie sich einsam, selbst wenn Sie in Gesellschaft waren?", "...fuehlten Sie sich ueberfluessig?", "...hatten Sie die Freude am Leben verloren?", "...war das Leben eine Last fuer Sie?" ) KRITISCH_INDEX_DESC1 = 2 ITEM_TEXTE_DESC2 = c( "...hatten Sie das Gefuehl, nicht gebraucht zu werden?", "...hatten Sie das Gefuehl, Ihr Interesse an anderen Menschen verloren zu haben?", "...waren Sie niedergeschlagen?", "...hatten Sie wenig Freude daran, etwas zu tun?", "...hatten Sie das Gefuehl, dass Sie zu nichts taugen?", "...fuehlten Sie sich ideenlos?", "...sahen Sie alles \"schwarz\"?", "...waren Sie entmutigt?", "...zogen Sie sich zurueck?", "...dachten Sie daran, mit dem Leben Schluss zu machen?" ) KRITISCH_INDEX_DESC2 = 10 NORMTABELLE_DESC1 = data.frame( summenwert = c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,26,27,28), prozentrang = c(33.5,49.1,59.9,67.8,73.9,78.9,83.1,85.7,88.5,90.9,93.3,95.7,97.3,97.9,98.3,98.8,99.1,99.3,99.5,99.6,99.7,99.8,99.8,99.9,99.9,100.0,100.0), theta = c(-5.80,-4.52,-3.71,-3.19,-2.78,-2.42,-2.10,-1.81,-1.53,-1.26,-1.00,-0.75,-0.51,-0.28,-0.06,0.16,0.37,0.57,0.78,0.98,1.18,1.38,1.59,1.82,2.61,2.97,3.45), z = c(-1.09,-0.38,0.07,0.36,0.59,0.79,0.97,1.13,1.29,1.44,1.58,1.72,1.86,1.99,2.11,2.23,2.35,2.46,2.58,2.69,2.80,2.91,3.03,3.16,3.60,3.80,4.07), t = c(39,46,51,54,56,58,60,61,63,64,66,67,69,70,71,72,73,75,76,77,78,79,80,82,86,88,91) ) # Hinweis: Summenwert 28 in der Quelltabelle als "20/=28" (>=28) gekennzeichnet, # hier als oberer Grenzwert 28 codiert. In der App-Anzeige wird bei Summenwert >= 28 # explizit "Wert >= 28, siehe Tabellenmaximum" angezeigt, nicht als exakter Treffer. NORMTABELLE_DESC2 = data.frame( summenwert = c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,30,31), prozentrang = c(38.4,49.3,59.0,65.3,70.5,75.2,79.5,82.7,85.0,87.2,89.4,91.2,92.7,94.5,95.9,97.1,97.8,98.5,98.7,98.9,99.2,99.3,99.6,99.6,99.8,99.8,99.8,99.9,100.0,100.0), theta = c(-6.03,-4.74,-3.93,-3.41,-3.00,-2.66,-2.35,-2.08,-1.82,-1.58,-1.35,-1.13,-0.92,-0.71,-0.51,-0.31,-0.11,0.08,0.27,0.46,0.65,0.84,1.03,1.22,1.41,1.61,1.82,2.05,2.86,3.22), z = c(-1.02,-0.36,0.05,0.31,0.52,0.70,0.85,0.99,1.12,1.25,1.36,1.48,1.58,1.69,1.79,1.89,1.99,2.09,2.19,2.29,2.38,2.48,2.58,2.67,2.77,2.87,2.98,3.10,3.51,3.69), t = c(40,46,50,53,55,57,59,60,61,62,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,85,87) ) # Hinweis: Summenwert 31 in der Quelltabelle als "1/= 31" (>=31) gekennzeichnet, # gleiche Behandlung wie bei Form I (Tabellenmaximum, kein exakter Treffer ab 31). # Anmerkung: theta = geschaetzter latenter Trait-Score (Depressivitaet) aus der # Rasch-Analyse; Z: Mittelwert 0, SD 1; T: Mittelwert 50, SD 10. # UI #### app_css = " body { font-family: 'Segoe UI', Arial, sans-serif; background: #f4f4f4; color: #222; } .app-header { background: #8B2635; color: white; padding: 16px 22px 13px; margin-bottom: 18px; border-radius: 0 0 6px 6px; } .app-header h2 { margin: 0; font-size: 1.45rem; font-weight: 700; } .input-panel { display: flex; align-items: flex-end; gap: 12px; flex-wrap: wrap; background: white; border-radius: 6px; padding: 14px 20px; margin: 0 16px 16px 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12); } .input-panel .form-group { margin-bottom: 0; } .btn-laden { background: #8B2635 !important; border-color: #8B2635 !important; color: white !important; font-weight: 600 !important; padding: 8px 20px !important; border-radius: 4px !important; } .btn-laden:hover { background: #6d1e29 !important; border-color: #6d1e29 !important; } .alert-fehler { background: #FEECEB; border-left: 5px solid #C62828; color: #B71C1C; padding: 12px 16px; border-radius: 4px; margin: 0 16px 16px 16px; font-weight: 500; } .alert-warnung { background: #FFF8E1; border-left: 5px solid #F9A825; color: #7A5B00; padding: 10px 16px; border-radius: 4px; margin: 0 16px 16px 16px; font-size: 0.93em; } .abschnitt-karte { background: white; border-radius: 6px; padding: 18px 22px; margin: 0 16px 16px 16px; box-shadow: 0 1px 3px rgba(0,0,0,.12); } .abschnitt-titel { color: #8B2635; font-size: 1.1rem; font-weight: 700; border-bottom: 2px solid #8B2635; padding-bottom: 8px; margin-bottom: 14px; } .meta-zeile { color: #555; font-size: 0.95em; margin-bottom: 12px; } .meta-zeile b { color: #222; } .meta-zeile span.sep { color: #ccc; margin: 0 8px; } .klassifikation-badge { font-size: 1.2rem; font-weight: 800; margin: 6px 0 14px; } .item-zeile { display: flex; align-items: flex-start; gap: 10px; padding: 7px 0; border-bottom: 1px solid #f0f0f0; } .item-zeile-kritisch { border-left: 4px solid #8B2635; padding-left: 8px; background: #FFF9F8; } .item-nr { font-weight: 700; color: #8B2635; min-width: 30px; flex-shrink: 0; } .item-text { flex: 1; color: #333; font-size: 0.92em; } .stufe-badge { border-radius: 4px; padding: 2px 10px; font-weight: 700; font-size: 0.82em; white-space: nowrap; display: inline-block; flex-shrink: 0; } .stufe-badge-0 { background: #4CAF50; color: white; } .stufe-badge-1 { background: #F9A825; color: #333333; } .stufe-badge-2 { background: #EF6C00; color: white; } .stufe-badge-3 { background: #C62828; color: white; } .stufe-badge-4 { background: #6D0000; color: white; } .kritisch-block { background: #6D0000; color: white; border-radius: 5px; padding: 14px 18px; margin: 0 16px 16px 16px; border-left: 6px solid #FF6B6B; } .kritisch-block h4 { margin: 0 0 9px; font-size: 1.05em; font-weight: 700; } .kritisch-block .antwort-text { background: rgba(255,255,255,0.12); border-radius: 3px; padding: 7px 10px; margin: 6px 0; font-size: 0.92em; line-height: 1.5; } .kritisch-block .disclaimer { margin-top: 10px; font-size: 0.82em; opacity: 0.82; font-style: italic; } " 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("DESC – Depressionsscreening (Parallelform I & II)") ), div(class = "input-panel", div(style = "min-width: 200px;", radioButtons("form_wahl", label = "Verwendete Form", choices = c("DESC-I" = "desc1", "DESC-II" = "desc2"), selected = character(0)) ), 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_desc_docx = function(erg) { doc = read_docx() fp_titel = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18) fp_meta = fp_text(color = "#555555", font.size = 10) fp_abschnitt = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 13) fp_normal = fp_text(font.size = 10) fp_klasse = fp_text(color = erg$klasse_farbe, bold = TRUE, font.size = 13) fp_warnung = fp_text(color = "#B8860B", italic = TRUE, font.size = 9) fp_kritisch_h = fp_text(color = "#C62828", bold = TRUE, font.size = 11) fp_kritisch_t = fp_text(color = "#C62828", font.size = 10) fp_fussnote = fp_text(color = "#777777", italic = TRUE, font.size = 8) fp_disclaimer = fp_text(color = "#777777", italic = TRUE, font.size = 9) doc = body_add_fpar(doc, fpar(ftext(paste0(erg$form_label, " – Depressionsscreening"), fp_titel))) doc = body_add_fpar(doc, fpar(ftext( paste0("Chiffre: ", erg$chiffre, " | Ausfuelldatum: ", erg$ausfuelldatum), fp_meta ))) if (!is.null(erg$warnung_mehrfach)) { doc = body_add_fpar(doc, fpar(ftext(erg$warnung_mehrfach, fp_warnung))) } doc = body_add_par(doc, "", style = "Normal") if (erg$kritisch_flag) { doc = body_add_fpar(doc, fpar(ftext( paste0("HINWEIS: Kritisches Item auffaellig – ", erg$kritisch_item_text), fp_kritisch_h ))) doc = body_add_fpar(doc, fpar(ftext( paste0("Gewaehlte Antwort: ", erg$kritisch_antwort_text), fp_kritisch_t ))) doc = body_add_fpar(doc, fpar(ftext( "Dies ist kein automatisiertes klinisches Urteil.", fp_kritisch_t ))) doc = body_add_par(doc, "", style = "Normal") } doc = body_add_fpar(doc, fpar(ftext( paste0("Summenscore: ", erg$summenwert, " / 40"), fp_abschnitt ))) doc = body_add_fpar(doc, fpar(ftext(erg$klasse_text, fp_klasse))) doc = body_add_par(doc, "", style = "Normal") doc = body_add_fpar(doc, fpar(ftext("Normwerte (bevoelkerungsrepraesentativ)", fp_abschnitt))) if (!erg$norm$exakt) { doc = body_add_fpar(doc, fpar(ftext(erg$norm$warnung, fp_warnung))) } doc = body_add_fpar(doc, fpar(ftext( paste0("Prozentrang: ", erg$norm$prozentrang, " T-Wert: ", erg$norm$t, " Z-Wert: ", erg$norm$z), fp_normal ))) doc = body_add_fpar(doc, fpar(ftext( paste0("Theta: geschaetzter latenter Trait-Score (Depressivitaet) aus der Rasch-Analyse. ", "Z: Mittelwert 0, SD 1. T: Mittelwert 50, SD 10."), fp_fussnote ))) doc = body_add_par(doc, "", style = "Normal") doc = body_add_fpar(doc, fpar(ftext("Einzelitems (10 Items)", fp_abschnitt))) for (i in seq_along(erg$item_texte)) { stufe = erg$stufen[i] stufe_key = as.character(stufe) kritisch = (i == erg$kritisch_index) fp_badge = fp_text( color = STUFE_TEXT_FARBEN[[stufe_key]], bold = TRUE, shading.color = STUFE_FARBEN[[stufe_key]], font.size = 9 ) praefix_txt = if (kritisch) "[KRITISCH] " else "" doc = body_add_fpar(doc, fpar( ftext(paste0(sprintf("%02d", i), ". ", praefix_txt, erg$item_texte[i], " "), fp_normal), ftext(paste0(" ", erg$antworten[i], " "), fp_badge) )) } doc = body_add_par(doc, "", style = "Normal") doc = body_add_fpar(doc, fpar(ftext(DESC_DISCLAIMER, fp_disclaimer))) 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))) } }) erg_aktuell = eventReactive(input$btn_suchen, { if (is.null(input$form_wahl) || length(input$form_wahl) == 0) { return(list(typ = "form_fehler")) } cfg = desc_konfiguration(input$form_wahl) chiffre = toupper(trimws(input$chiffre)) if (!(nchar(trimws(input$pseudonym)) > 0 || grepl("^[A-Z][0-9]{6}$", chiffre))) { return(list(typ = "format_fehler", chiffre = chiffre)) } if (!file.exists(cfg$download_skript)) { return(list(typ = "pfad_fehler", pfad = cfg$download_skript)) } if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) { return(list(typ = "pfad_fehler", pfad = PFAD_PSEUDONYM_SKRIPT)) } # Nur das zur gewaehlten Form passende Download-Skript sourcen - fuer die nicht # gewaehlte Form findet keinerlei Download-/Netzwerkaktivitaet statt. ok_dl = tryCatch({ source(cfg$download_skript, local = FALSE) list(ok = TRUE) }, error = function(e) list( ok = FALSE, msg = e$message, aufruf = if (!is.null(e$call)) paste(deparse(e$call), collapse = " ") else NA_character_ )) if (!ok_dl$ok) { return(list(typ = "skript_fehler", skript = basename(cfg$download_skript), pfad = cfg$download_skript, meldung = ok_dl$msg, aufruf = ok_dl$aufruf)) } if (!exists(cfg$daten_objekt, envir = .GlobalEnv) || !is.data.frame(get(cfg$daten_objekt, envir = .GlobalEnv))) { return(list(typ = "daten_fehler", cfg = cfg)) } daten = get(cfg$daten_objekt, envir = .GlobalEnv) 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")) } alter_wd = getwd() on.exit(setwd(alter_wd), add = TRUE) setwd(db_ordner) ok_ps = tryCatch({ source(PFAD_PSEUDONYM_SKRIPT, local = FALSE) if (nchar(trimws(input$pseudonym)) > 0) { .pw_wert = trimws(input$pseudonym) .pw_tab = get("pseudo", envir = .GlobalEnv) .pw_treffer = .pw_tab[.pw_tab$pseudonym == .pw_wert, ] if (nrow(.pw_treffer) > 0) chiffre = toupper(trimws(.pw_treffer$chiffre[1])) } list(ok = TRUE) }, error = function(e) list( ok = FALSE, msg = e$message, aufruf = if (!is.null(e$call)) paste(deparse(e$call), collapse = " ") else NA_character_ )) if (!ok_ps$ok) { return(list(typ = "skript_fehler", skript = basename(PFAD_PSEUDONYM_SKRIPT), pfad = PFAD_PSEUDONYM_SKRIPT, meldung = ok_ps$msg, aufruf = ok_ps$aufruf)) } if (!exists("pseudo", envir = .GlobalEnv)) { return(list(typ = "skript_fehler", meldung = "Objekt 'pseudo' nach dem Sourcen nicht gefunden.")) } pseudo = get("pseudo", envir = .GlobalEnv) # pseudo$instrument ist nur ein unzuverlaessiges Freitext-Notizfeld (verifiziert # 2026-07-01) und wird daher NICHT zur Form-Zuordnung verwendet. Stattdessen alle # zur Chiffre gehoerenden Session-IDs holen und gegen den formspezifischen # Datensatz (daten_desci/daten_descii) matchen - die Form-Zugehoerigkeit ergibt # sich implizit daraus, in welchem Datensatz die Session tatsaechlich auftaucht. treffer = pseudo[toupper(pseudo$chiffre) == chiffre, ] if (nrow(treffer) == 0) { return(list(typ = "chiffre_nicht_gefunden", chiffre = chiffre, cfg = cfg)) } alle_session_ids = unique(treffer$pseudonym) if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym) zeilen = daten[daten$session %in% alle_session_ids, ] if (nrow(zeilen) == 0) { return(list(typ = "session_nicht_gefunden", chiffre = chiffre, cfg = cfg)) } warnung_mehrfach = NULL if (nrow(zeilen) > 1) { n_mehrfach = nrow(zeilen) zeilen = zeilen[order(zeilen$created, decreasing = TRUE), ] warnung_mehrfach = paste0( n_mehrfach, " Ausfuellungen gefunden. Es wird die neueste angezeigt." ) } zeile = zeilen[1, , drop = FALSE] item_cols = paste0(cfg$praefix, sprintf("%02d", 1:10)) ok_items = tryCatch({ erg_items = lapply(seq_along(item_cols), function(i) { col_name = item_cols[i] spalte_orig = daten[[col_name]] wert = zeile[[col_name]] lese_item_stufe(spalte_orig, wert, paste0(cfg$label, " Item ", i)) }) list(ok = TRUE, items = erg_items) }, error = function(e) list(ok = FALSE, msg = e$message)) if (!ok_items$ok) { return(list(typ = "item_fehler", meldung = ok_items$msg)) } stufen = sapply(ok_items$items, `[[`, "stufe") antworten = sapply(ok_items$items, `[[`, "text") summenwert = sum(stufen) klass = desc_klassifikation(summenwert) norm = normwert_lookup(cfg$normtabelle, summenwert, cfg$grenzwert_max) kritisch_index = cfg$kritisch_index kritisch_flag = stufen[kritisch_index] >= 1 ausfuelldatum = format(as.Date(zeile$created[1]), "%d.%m.%Y") list( typ = "ok", form = cfg$form, form_label = cfg$label, chiffre = chiffre, ausfuelldatum = ausfuelldatum, warnung_mehrfach = warnung_mehrfach, item_texte = cfg$item_texte, stufen = stufen, antworten = antworten, summenwert = summenwert, klasse_text = klass$text, klasse_farbe = klass$farbe, norm = norm, kritisch_index = kritisch_index, kritisch_flag = kritisch_flag, kritisch_item_text = cfg$item_texte[kritisch_index], kritisch_antwort_text = antworten[kritisch_index] ) }) baue_item_liste = function(erg) { lapply(seq_along(erg$item_texte), function(i) { stufe = erg$stufen[i] stufe_key = as.character(stufe) kritisch = (i == erg$kritisch_index) klasse_row = if (kritisch) "item-zeile item-zeile-kritisch" else "item-zeile" div(class = klasse_row, div(class = "item-nr", sprintf("%02d", i)), div(class = "item-text", erg$item_texte[i]), span(class = paste0("stufe-badge stufe-badge-", stufe_key), erg$antworten[i]) ) }) } baue_ergebnis_anzeige = function(erg) { tagList( if (!is.null(erg$warnung_mehrfach)) { div(class = "alert-warnung", erg$warnung_mehrfach) }, if (erg$kritisch_flag) { div(class = "kritisch-block", tags$h4("⚠ Kritisches Item auffaellig"), tags$p(erg$kritisch_item_text), div(class = "antwort-text", tags$b("Gewaehlte Antwort: "), erg$kritisch_antwort_text ), tags$p(class = "disclaimer", "Dies ist kein automatisiertes klinisches Urteil.") ) }, div(class = "abschnitt-karte", div(class = "meta-zeile", tags$b("Form: "), erg$form_label, tags$span(class = "sep", "|"), tags$b("Chiffre: "), erg$chiffre, tags$span(class = "sep", "|"), tags$b("Ausfuelldatum: "), erg$ausfuelldatum, tags$span(class = "sep", "|"), tags$b("Summenscore: "), paste0(erg$summenwert, " / 40") ), div(class = "klassifikation-badge", style = paste0("color:", erg$klasse_farbe, ";"), erg$klasse_text ), plotOutput("gauge_plot", height = "80px"), if (!erg$norm$exakt) { div(class = "alert-warnung", erg$norm$warnung) }, tags$p(style = "margin-top: 10px;", tags$b("Prozentrang: "), erg$norm$prozentrang, " ", tags$b("T-Wert: "), erg$norm$t, " ", tags$b("Z-Wert: "), erg$norm$z ) ), div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Einzelitems (10 Items)"), baue_item_liste(erg) ) ) } output$ergebnis_ui = renderUI({ erg = erg_aktuell() if (is.null(erg)) return(NULL) switch(erg$typ, "form_fehler" = div(class = "alert-fehler", "Bitte zuerst eine Form auswaehlen (DESC-I oder DESC-II)." ), "format_fehler" = div(class = "alert-fehler", "Ungueltiges Chiffre-Format (erwartet: P000123)" ), "pfad_fehler" = div(class = "alert-fehler", paste0("Skript-Pfad nicht gefunden: ", erg$pfad) ), "skript_fehler" = div(class = "alert-fehler", tags$p(tags$b(paste0("Fehler beim Ausfuehren von: ", erg$skript))), tags$p(tags$code(erg$pfad)), if (!is.null(erg$aufruf) && !is.na(erg$aufruf)) { tags$p(tags$b("Fehlgeschlagener Aufruf: "), tags$code(erg$aufruf)) }, tags$p(tags$b("Meldung: "), erg$meldung) ), "daten_fehler" = div(class = "alert-fehler", paste0(erg$cfg$daten_objekt, " nicht geladen") ), "db_fehler" = div(class = "alert-fehler", "pseudonyme.db nicht gefunden" ), "chiffre_nicht_gefunden" = div(class = "alert-fehler", paste0("Keine ", erg$cfg$label, "-Zuordnung fuer Chiffre ", erg$chiffre, " gefunden") ), "session_nicht_gefunden" = div(class = "alert-fehler", paste0("Fuer Chiffre ", erg$chiffre, " liegen keine ", erg$cfg$label, "-Antwortdaten vor") ), "item_fehler" = div(class = "alert-fehler", paste0("Fehler bei der Itemauswertung: ", erg$meldung) ), "ok" = baue_ergebnis_anzeige(erg) ) }) output$gauge_plot = renderPlot({ erg = erg_aktuell() req(erg$typ == "ok") make_gauge_desc(erg$summenwert) }, bg = "white") output$download_word = downloadHandler( filename = function() { erg = erg_aktuell() chiffre_esc = gsub("[^A-Za-z0-9]", "_", erg$chiffre) ausfuelldatum_fn = format(as.Date(erg$ausfuelldatum, "%d.%m.%Y"), "%Y%m%d") praefix_dateiname = if (erg$form == "desc1") "DESC-I" else "DESC-II" paste0(praefix_dateiname, "_", chiffre_esc, "_", ausfuelldatum_fn, ".docx") }, content = function(file) { erg = erg_aktuell() doc = erstelle_desc_docx(erg) print(doc, target = file) } ) } # Start #### shinyApp(ui, server)