# Präambel #### PFAD_DOWNLOAD_SKRIPT = "../API/get_data_edeq.R" # liefert beim Sourcen: daten_edeq PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert beim Sourcen: pseudo AKZENT_FARBE = "#8B2635" EDEQ_DISCLAIMER = paste0( "Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ", "keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ", "Die Einordnung gegen Referenzgruppen ist ein deskriptiver Vergleich, kein validierter Cutoff." ) 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 #### # Ob formr bei mc-Items den Choice-TEXT oder eine haven-labelled (dbl+lbl) Spalte mit # Zahlenwert+Label exportiert, ist fuer diese formr-Installation nicht gegen echte # Exportdaten verifiziert. Beide Faelle werden hier robust abgedeckt. hole_choice_text = function(spalte) { if (haven::is.labelled(spalte)) { return(as.character(haven::as_factor(spalte))) } return(as.character(spalte)) } # Vereinheitlicht Gedankenstrich-Varianten und Umlaute fuer robuste Lookup-Vergleiche, # da die xlsx-Choice-Texte lange Gedankenstriche ("–") verwenden. normalisiere_text = function(text) { text = gsub("[‐-―]", "-", text) text = gsub("ä", "ae", text); text = gsub("ö", "oe", text); text = gsub("ü", "ue", text) text = gsub("Ä", "Ae", text); text = gsub("Ö", "Oe", text); text = gsub("Ü", "Ue", text) text = gsub("ß", "ss", text) trimws(text) } recode_lookup = function(spalte, lookup_tabelle) { text = normalisiere_text(hole_choice_text(spalte)) namen = normalisiere_text(names(lookup_tabelle)) werte = unname(lookup_tabelle)[match(text, namen)] if (all(is.na(werte)) && !all(is.na(text))) { warning("Keine der Choice-Texte konnte der Lookup-Tabelle zugeordnet werden - Item-Kodierung pruefen.") } as.numeric(werte) } recode_digit_prefix = function(spalte) { text = trimws(hole_choice_text(spalte)) ziffer = regmatches(text, regexpr("^[0-6]", text)) fehlt = lengths(regmatches(text, gregexpr("^[0-6]", text))) == 0 ziffer[fehlt] = NA as.numeric(ziffer) } lookup_tage = c( "kein Tag" = 0, "1-5 Tage" = 1, "6-12 Tage" = 2, "13-15 Tage" = 3, "16-22 Tage" = 4, "23-27 Tage" = 5, "jeden Tag" = 6 ) lookup_item20 = c( "niemals" = 0, "in seltenen Faellen" = 1, "in weniger als der Haelfte der Faelle" = 2, "in der Haelfte der Faelle" = 3, "in mehr als der Haelfte der Faelle" = 4, "in den meisten Faellen" = 5, "jedes Mal" = 6 ) # Rekodiert ein Item mit der angegebenen Methode ("tage", "item20", "digit_prefix"). # Liefert bei durchgaengig nicht auswertbarem Rohwert NA plus einen Warnhinweis, statt # stillschweigend weiterzurechnen. edeq_recode_item = function(spalte, methode) { roh_leer = all(is.na(hole_choice_text(spalte)) | trimws(hole_choice_text(spalte)) == "") wert = switch(methode, "tage" = recode_lookup(spalte, lookup_tage), "item20" = recode_lookup(spalte, lookup_item20), "digit_prefix" = recode_digit_prefix(spalte), stop("Unbekannte Recoding-Methode: ", methode) ) list(wert = wert, unerwartet = is.na(wert) && !roh_leer) } edeq_finde_datumsspalte = function(daten, zeile) { kandidaten = c("created", "modified", "expired") for (k in kandidaten) { if (k %in% names(daten)) { wert = zeile[[k]][1] if (!is.null(wert) && !is.na(wert)) return(k) } } NA_character_ } edeq_parse_datum = function(roh_wert) { tryCatch({ d = as.POSIXct(roh_wert) if (is.na(d)) return(NULL) d }, error = function(e) NULL) } # Dezimaltrennzeichen robust behandeln: Nutzereingaben koennen Komma oder Punkt sein. parse_dezimal = function(x) { if (is.null(x) || length(x) == 0 || is.na(x[1])) return(NA_real_) as.numeric(gsub(",", ".", trimws(as.character(x[1])))) } # Die Rohdaten der Studienteilnehmenden koennen nachtraeglich nicht korrigiert werden. # Ein Wert ausserhalb 1.0-2.5 m wird deshalb nicht nur als unplausibel markiert, sondern # zusaetzlich geprueft, ob er als Zentimeterangabe (100-250) plausibel ist - dann # automatisch durch 100 geteilt und sichtbar als Umrechnung gekennzeichnet, statt den # BMI ersatzlos wegzulassen. normalisiere_groesse = function(roh_wert) { if (is.na(roh_wert)) { return(list(meter = NA_real_, konvertiert = FALSE, unplausibel = FALSE)) } if (roh_wert >= 1.0 && roh_wert <= 2.5) { return(list(meter = roh_wert, konvertiert = FALSE, unplausibel = FALSE)) } if (roh_wert >= 100 && roh_wert <= 250) { return(list(meter = roh_wert / 100, konvertiert = TRUE, unplausibel = FALSE)) } list(meter = NA_real_, konvertiert = FALSE, unplausibel = TRUE) } # Bleibt die Groesse auch nach normalisiere_groesse() unplausibel, kann eine manuelle # Eingabe im UI nachgetragen werden (siehe bmi_block_ui im Server-Abschnitt). Diese # Funktion kombiniert Rohdaten-BMI und manuelle Eingabe an einer zentralen Stelle, # damit Bildschirmanzeige und Word-Export exakt denselben Wert verwenden. edeq_bmi_effektiv = function(erg, groesse_manuell) { if (!is.na(erg$bmi)) { return(list(bmi = erg$bmi, groesse_m = erg$groesse_m, manuell = FALSE, gueltig = TRUE)) } if (!isTRUE(erg$groesse_unplausibel)) { return(list(bmi = NA_real_, groesse_m = NA_real_, manuell = FALSE, gueltig = FALSE)) } if (is.null(groesse_manuell) || is.na(groesse_manuell) || groesse_manuell < 1.0 || groesse_manuell > 2.5) { return(list(bmi = NA_real_, groesse_m = NA_real_, manuell = FALSE, gueltig = FALSE)) } if (is.na(erg$gewicht_kg)) { return(list(bmi = NA_real_, groesse_m = groesse_manuell, manuell = TRUE, gueltig = FALSE)) } list(bmi = erg$gewicht_kg / (groesse_manuell ^ 2), groesse_m = groesse_manuell, manuell = TRUE, gueltig = TRUE) } # Datenaufbereitung #### # Statische Referenztabelle aus dem EDE-Q-Manual (Hilbert & Tuschen-Caffier, 2006), # Tabelle 2, S. 6. Keine eigene Berechnung, keine Interpolation. referenzgruppen = data.frame( gruppe = c("Anorexia Nervosa", "Bulimia Nervosa", "Atypische Essstoerungen", "Nicht-essgestoert"), n = c(105, 55, 54, 409), restraint_m = c(4.07, 2.90, 3.02, 1.27), restraint_sd = c(1.74, 1.69, 1.83, 1.33), ec_m = c(3.39, 2.89, 2.60, 0.76), ec_sd = c(1.43, 1.40, 1.51, 1.08), wc_m = c(3.69, 3.19, 3.73, 1.66), wc_sd = c(1.66, 1.87, 1.54, 1.42), sc_m = c(4.07, 3.73, 4.19, 2.08), sc_sd = c(1.51, 1.86, 1.54, 1.61), gesamt_m = c(3.81, 3.18, 3.39, 1.44), gesamt_sd = c(1.43, 1.57, 1.38, 1.22), stringsAsFactors = FALSE ) # Kennzahl-Key -> Spaltenpraefix in referenzgruppen, fuer die z-Wert-Tabelle und die # Positionsdarstellungen gemeinsam genutzt. EDEQ_KENNZAHLEN = data.frame( key = c("restraint", "ec", "wc", "sc", "gesamt"), label = c("Restraint", "Eating Concern", "Weight Concern", "Shape Concern", "EDE-Q Gesamt"), stringsAsFactors = FALSE ) # Gruppenlabels stehen als Legende (nicht als Inline-Text auf dem Zahlenstrahl), da bei # eng beieinanderliegenden Gruppenmittelwerten (z.B. Bulimia Nervosa/Atypische # Essstoerungen) Inline-Text unabhaengig von der konkreten Kennzahl kollidieren kann. erstelle_gauge_edeq = function(kennzahl_key, kennzahl_label, individueller_wert) { ref = referenzgruppen ref$m = ref[[paste0(kennzahl_key, "_m")]] ref$farbe = c("#B71C1C", "#E65100", "#F9A825", "#2E7D32") ref$gruppe = factor(ref$gruppe, levels = ref$gruppe) p = ggplot() + geom_vline(data = ref, aes(xintercept = m, color = gruppe), linetype = "dashed", linewidth = 0.8) + scale_color_manual(values = setNames(ref$farbe, ref$gruppe), name = NULL) + scale_x_continuous(limits = c(0, 6), expand = c(0, 0), breaks = 0:6) + scale_y_continuous(limits = c(-0.3, 1.0), expand = c(0, 0)) + labs(x = paste0(kennzahl_label, " (0-6)"), y = NULL) + theme_minimal(base_size = 11) + theme( axis.text.y = element_blank(), axis.ticks.y = element_blank(), panel.grid = element_blank(), legend.position = "bottom", legend.text = element_text(size = 7.5), legend.key.width = unit(0.8, "line"), legend.margin = margin(t = -6), 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) ) + guides(color = guide_legend(nrow = 2, byrow = TRUE)) if (!is.na(individueller_wert)) { p = p + geom_segment(aes(x = individueller_wert, xend = individueller_wert, y = -0.1, yend = 1.0), colour = AKZENT_FARBE, linewidth = 2.2, lineend = "round") + annotate("text", x = individueller_wert, y = -0.22, label = sprintf("%.2f", individueller_wert), colour = AKZENT_FARBE, fontface = "bold", size = 3.6) } p } # UI #### app_css = " body { font-family: 'Segoe UI', Helvetica, Arial, sans-serif; background-color: #f4f4f4; color: #222; font-size: 14px; } .app-header { background-color: #8B2635; color: white; padding: 15px 22px 13px; margin-bottom: 18px; border-radius: 5px; } .app-header h2 { margin: 0; font-size: 1.4em; font-weight: 700; } .app-header p { margin: 4px 0 0; font-size: 0.87em; opacity: 0.88; } .input-panel { display: flex; align-items: flex-end; gap: 10px; background: white; border-radius: 6px; padding: 14px 18px; margin-bottom: 16px; box-shadow: 0 1px 4px rgba(0,0,0,0.09); flex-wrap: wrap; } .input-panel .form-group { margin-bottom: 0; } .btn-laden { background-color: #8B2635 !important; border-color: #7A2030 !important; color: white !important; font-weight: 600; padding: 6px 18px; border-radius: 4px; letter-spacing: 0.02em; white-space: nowrap; } .btn-laden:hover, .btn-laden:focus { background-color: #6E1E29 !important; border-color: #6E1E29 !important; outline: none; box-shadow: 0 0 0 2px rgba(139,38,53,0.3) !important; } .abschnitt-karte { background: white; border-radius: 6px; padding: 16px 20px; margin-bottom: 14px; box-shadow: 0 1px 4px rgba(0,0,0,0.09); } .abschnitt-titel { color: #8B2635; margin-top: 0; margin-bottom: 12px; font-size: 1em; font-weight: 700; letter-spacing: 0.01em; } .kopf-info { color: #555; font-size: 0.92em; padding-bottom: 10px; border-bottom: 1px solid #eee; margin-bottom: 8px; } .kopf-info b { color: #333; } .alert-warnung { background-color: #FFFDE7; border-left: 4px solid #F9A825; border-radius: 3px; padding: 9px 12px; margin-bottom: 10px; font-size: 0.88em; color: #555; line-height: 1.45; } .alert-fehler { background-color: #FEECEB; border-left: 4px solid #C62828; border-radius: 4px; padding: 13px 16px; margin-bottom: 12px; } .alert-fehler h4 { color: #C62828; margin-top: 0; margin-bottom: 8px; } .alert-fehler p, .alert-fehler li { color: #444; font-size: 0.92em; } table.tabelle-kennzahlen { width: 100%; border-collapse: collapse; font-size: 0.92em; } table.tabelle-kennzahlen th, table.tabelle-kennzahlen td { padding: 6px 10px; text-align: right; border-bottom: 1px solid #eee; } table.tabelle-kennzahlen th:first-child, table.tabelle-kennzahlen td:first-child { text-align: left; } table.tabelle-kennzahlen th { color: #8B2635; font-weight: 700; border-bottom: 2px solid #8B2635; } .item-zeile { display: flex; align-items: baseline; gap: 10px; padding: 7px 0; border-bottom: 1px solid #f0f0f0; } .item-zeile:last-child { border-bottom: none; } .item-nr { font-weight: 700; color: #8B2635; min-width: 26px; flex-shrink: 0; } .item-text { flex: 1; color: #333; font-size: 0.92em; } .disclaimer-text { font-size: 0.82em; color: #777; font-style: italic; margin-top: 10px; border-top: 1px solid rgba(0,0,0,.1); padding-top: 8px; } .desk-zeile { display: flex; gap: 8px; align-items: baseline; padding: 4px 0; color: #444; font-size: 0.93em; } .desk-label { font-weight: 600; color: #333; min-width: 200px; } .start-hinweis { text-align: center; color: #bbb; padding: 40px 0; font-size: 0.95em; } " 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("EDE-Q Auswertung"), tags$p("Eating Disorder Examination-Questionnaire • dt. Version (Hilbert & Tuschen-Caffier, 2006) • Einzelfall-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_edeq_docx = function(erg) { fmt_titel = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 18) fmt_meta = fp_text(color = "#555555", bold = FALSE, font.size = 10) fmt_warn = fp_text(color = "#B8860B", italic = TRUE, font.size = 9) fmt_abschn = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 12, underlined = TRUE) fmt_label = fp_text(bold = TRUE, font.size = 10) fmt_normal = fp_text(font.size = 10) fmt_disclaimer = fp_text(color = "#888888", italic = TRUE, font.size = 9) doc = read_docx() doc = body_add_fpar(doc, fpar(ftext("EDE-Q Auswertung", fmt_titel))) doc = body_add_fpar(doc, fpar(ftext( paste0("Chiffre: ", erg$chiffre, " Ausfuelldatum: ", erg$ausfuelldatum, " Erstellt: ", format(Sys.Date(), "%d.%m.%Y")), fmt_meta ))) if (!is.null(erg$warnung_mehrfach)) { doc = body_add_fpar(doc, fpar(ftext(paste0("Hinweis: ", erg$warnung_mehrfach), fmt_warn))) } if (isTRUE(erg$ausfuelldatum_fallback)) { doc = body_add_fpar(doc, fpar(ftext( "Hinweis: Ausfuelldatum nicht in Rohdaten gefunden, Anzeigedatum verwendet.", fmt_warn ))) } doc = body_add_par(doc, "") doc = body_add_fpar(doc, fpar(ftext("Subskalen- und Gesamtmittelwerte", fmt_abschn))) tab_kennzahlen = data.frame( Kennzahl = EDEQ_KENNZAHLEN$label, Wert = sapply(EDEQ_KENNZAHLEN$key, function(k) { v = erg$kennzahlen[[k]] if (is.na(v)) "nicht berechenbar" else sprintf("%.2f", v) }), stringsAsFactors = FALSE ) doc = body_add_table(doc, tab_kennzahlen, style = "table_template") doc = body_add_par(doc, "") doc = body_add_fpar(doc, fpar(ftext("Referenzgruppen-Vergleich (z-Werte)", fmt_abschn))) doc = body_add_fpar(doc, fpar(ftext( "Deskriptiver Vergleich, kein validierter Cutoff.", fmt_warn ))) tab_z = data.frame(Kennzahl = EDEQ_KENNZAHLEN$label, stringsAsFactors = FALSE) for (g in referenzgruppen$gruppe) { tab_z[[g]] = sapply(erg$z_werte[[g]], function(z) { if (is.na(z)) "-" else sprintf("%.2f", z) }) } doc = body_add_table(doc, tab_z, style = "table_template") doc = body_add_par(doc, "") doc = body_add_fpar(doc, fpar(ftext( "Kernverhaltensitems 13-18 (Einzelitem-Auswertung, keine Subskala)", fmt_abschn ))) for (it in erg$kernitems) { doc = body_add_fpar(doc, fpar( ftext(paste0(it$label, ": "), fmt_label), ftext(it$anzeige, fmt_normal) )) } doc = body_add_par(doc, "") if (!is.na(erg$bmi)) { doc = body_add_fpar(doc, fpar(ftext("BMI", fmt_abschn))) if (isTRUE(erg$groesse_konvertiert)) { doc = body_add_fpar(doc, fpar(ftext(sprintf( "Hinweis: Groesse als Zentimeterangabe erkannt und automatisch umgerechnet (verwendet: %.2f m).", erg$groesse_m ), fmt_warn))) } if (isTRUE(erg$groesse_manuell_verwendet)) { doc = body_add_fpar(doc, fpar(ftext(sprintf( "Hinweis: Groesse manuell nachgetragen (verwendet: %.2f m), da der Rohwert unplausibel war.", erg$groesse_m ), fmt_warn))) } doc = body_add_fpar(doc, fpar(ftext(sprintf("%.1f kg/m²", erg$bmi), fmt_normal))) doc = body_add_par(doc, "") } doc = body_add_fpar(doc, fpar(ftext(EDEQ_DISCLAIMER, fmt_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))) } }) # Die beiden externen Skripte werden bewusst NICHT beim App-Start gesourct, sondern # erst hier, beim Klick auf "Auswerten" (Source-bei-Klick-Muster). 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")) } if (!(nchar(trimws(input$pseudonym)) > 0 || grepl("^[A-Z][0-9]{6}$", chiffre))) { return(list(typ = "format_fehler", chiffre = chiffre)) } pfadfehler = character(0) if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) { pfadfehler = c(pfadfehler, paste0("Download-Skript nicht gefunden: >>", PFAD_DOWNLOAD_SKRIPT, "<<")) } if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) { pfadfehler = c(pfadfehler, paste0("Pseudonym-Skript nicht gefunden: >>", PFAD_PSEUDONYM_SKRIPT, "<<")) } if (length(pfadfehler) > 0) { return(list(typ = "skript_fehler", meldung = paste("Bitte Pfade am Kopf der app.R anpassen:", paste(pfadfehler, collapse = "\n"), sep = "\n"))) } ok_download = tryCatch({ source(PFAD_DOWNLOAD_SKRIPT, local = FALSE) list(ok = TRUE) }, error = function(e) list(ok = FALSE, msg = conditionMessage(e))) if (!ok_download$ok) { return(list(typ = "skript_fehler", meldung = paste0("Fehler im Download-Skript (", basename(PFAD_DOWNLOAD_SKRIPT), "):\n", ok_download$msg))) } # Ordner mit pseudonyme.db suchen, ausgehend vom Pseudonym-Skript-Ordner, bis zu # 5 Ebenen nach oben. 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 = "skript_fehler", meldung = paste0( "pseudonyme.db nicht gefunden.\n", "Gesucht ausgehend vom Pseudonym-Skript-Ordner bis zu 5 Ebenen nach oben.\n", "Bitte sicherstellen, dass pseudonyme.db im selben oder einem ", "uebergeordneten Ordner liegt." ))) } # add = TRUE ist Pflicht, sonst wuerden ggf. bereits registrierte on.exit()-Handler # ueberschrieben statt ergaenzt. ok_pseudonym = tryCatch({ alter_wd = getwd() on.exit(setwd(alter_wd), add = TRUE) setwd(db_ordner) 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 = conditionMessage(e))) if (!ok_pseudonym$ok) { return(list(typ = "skript_fehler", meldung = paste0("Fehler im Pseudonym-Skript (", basename(PFAD_PSEUDONYM_SKRIPT), "):\n", ok_pseudonym$msg))) } if (!exists("daten_edeq", envir = .GlobalEnv)) { return(list(typ = "skript_fehler", meldung = paste0("Objekt 'daten_edeq' fehlt nach dem Sourcen von:\n", PFAD_DOWNLOAD_SKRIPT))) } if (!exists("pseudo", envir = .GlobalEnv)) { return(list(typ = "skript_fehler", meldung = paste0("Objekt 'pseudo' fehlt nach dem Sourcen von:\n", PFAD_PSEUDONYM_SKRIPT))) } dat_edeq = get("daten_edeq", envir = .GlobalEnv) dat_ps = get("pseudo", envir = .GlobalEnv) ps_treffer = dat_ps[dat_ps$chiffre == chiffre, , drop = FALSE] if (nrow(ps_treffer) == 0) { return(list(typ = "chiffre_nicht_gefunden", chiffre = chiffre)) } alle_session_ids = unique(as.character(ps_treffer$pseudonym)) if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym) if (!("session" %in% names(dat_edeq))) { return(list(typ = "skript_fehler", meldung = paste0( "Spalte 'session' in 'daten_edeq' nicht gefunden. Der erwartete Spaltenname ", "fuer die formr-Session-ID ist am echten Export noch nicht verifiziert - ", "bitte tatsaechlichen Spaltennamen in get_data_edeq.R bzw. hier pruefen." ))) } edeq_treffer = dat_edeq[dat_edeq$session %in% alle_session_ids, , drop = FALSE] if (nrow(edeq_treffer) == 0) { return(list(typ = "keine_daten", chiffre = chiffre)) } # Mehrfachtreffer (Bogen mehrfach ausgefuellt): nicht stillschweigend den ersten # nehmen, sondern den neuesten (nach Ausfuelldatum) waehlen und sichtbar warnen. warnung_mehrfach = NULL spalte_datum = edeq_finde_datumsspalte(dat_edeq, edeq_treffer[1, , drop = FALSE]) if (nrow(edeq_treffer) > 1) { n_ausfuell = nrow(edeq_treffer) if (!is.na(spalte_datum)) { reihenfolge = order( vapply(seq_len(n_ausfuell), function(i) { d = edeq_parse_datum(edeq_treffer[[spalte_datum]][i]) if (is.null(d)) -Inf else as.numeric(d) }, numeric(1)), decreasing = TRUE ) edeq_treffer = edeq_treffer[reihenfolge, , drop = FALSE] } datum_neuestes = if (!is.na(spalte_datum)) { d = edeq_parse_datum(edeq_treffer[[spalte_datum]][1]) if (!is.null(d)) format(d, "%d.%m.%Y %H:%M") else "unbekanntes Datum" } else "unbekanntes Datum" warnung_mehrfach = paste0( "Es wurden ", n_ausfuell, " Ausfuellungen gefunden, es wird die neueste vom ", datum_neuestes, " angezeigt." ) edeq_treffer = edeq_treffer[1, , drop = FALSE] } zeile = edeq_treffer[1, , drop = FALSE] spalte_datum = edeq_finde_datumsspalte(dat_edeq, zeile) datum_geparst = if (!is.na(spalte_datum)) edeq_parse_datum(zeile[[spalte_datum]][1]) else NULL ausfuelldatum_fallback = is.null(datum_geparst) ausfuelldatum = if (!ausfuelldatum_fallback) format(datum_geparst, "%d.%m.%Y") else format(Sys.Date(), "%d.%m.%Y") ausfuelldatum_dateikennung = if (!ausfuelldatum_fallback) format(datum_geparst, "%Y%m%d") else format(Sys.Date(), "%Y%m%d") # Recoding aller benoetigten Items. Methode pro Item gemaess Scoring-Spezifikation. item_methoden = list( edeq_01_r = "tage", edeq_02_r = "tage", edeq_03_r = "tage", edeq_04_r = "tage", edeq_05_r = "tage", edeq_06_sc = "tage", edeq_07_ec = "tage", edeq_08_wcsc = "tage", edeq_09_ec = "tage", edeq_10_sc = "tage", edeq_11_sc = "tage", edeq_12_wc = "tage", edeq_19_ec = "tage", edeq_20_ec = "item20", edeq_21_ec = "digit_prefix", edeq_22_wc = "digit_prefix", edeq_23_sc = "digit_prefix", edeq_24_wc = "digit_prefix", edeq_25_wc = "digit_prefix", edeq_26_sc = "digit_prefix", edeq_27_sc = "digit_prefix", edeq_28_sc = "digit_prefix" ) fehlende_item_spalten = names(item_methoden)[!(names(item_methoden) %in% names(dat_edeq))] if (length(fehlende_item_spalten) > 0) { return(list(typ = "skript_fehler", meldung = paste0( "Folgende erwartete Item-Spalten fehlen in 'daten_edeq': ", paste(fehlende_item_spalten, collapse = ", "), "." ))) } item_werte = list() item_unerwartet = character(0) for (var in names(item_methoden)) { res = edeq_recode_item(zeile[[var]], item_methoden[[var]]) item_werte[[var]] = res$wert if (isTRUE(res$unerwartet)) item_unerwartet = c(item_unerwartet, var) } # Subskalen als Mittelwerte (kein Summenscore). Ein Item mit unerwarteter # Kodierung fuehrt dazu, dass die betroffene(n) Subskala(en) als "nicht # berechenbar" ausgegeben werden, statt einen falschen Wert stillzuschweigend # zu berechnen. subskalen_items = list( restraint = c("edeq_01_r", "edeq_02_r", "edeq_03_r", "edeq_04_r", "edeq_05_r"), ec = c("edeq_07_ec", "edeq_09_ec", "edeq_19_ec", "edeq_20_ec", "edeq_21_ec"), wc = c("edeq_08_wcsc", "edeq_12_wc", "edeq_22_wc", "edeq_24_wc", "edeq_25_wc"), sc = c("edeq_06_sc", "edeq_08_wcsc", "edeq_10_sc", "edeq_11_sc", "edeq_23_sc", "edeq_26_sc", "edeq_27_sc", "edeq_28_sc") ) berechne_mittelwert = function(vars) { werte = unlist(item_werte[vars]) if (any(vars %in% item_unerwartet)) return(NA_real_) if (any(is.na(werte))) return(NA_real_) mean(werte) } kennzahlen = list( restraint = berechne_mittelwert(subskalen_items$restraint), ec = berechne_mittelwert(subskalen_items$ec), wc = berechne_mittelwert(subskalen_items$wc), sc = berechne_mittelwert(subskalen_items$sc) ) subskalen_ok = !any(sapply(kennzahlen, is.na)) kennzahlen$gesamt = if (subskalen_ok) { mean(c(kennzahlen$restraint, kennzahlen$ec, kennzahlen$wc, kennzahlen$sc)) } else NA_real_ # z-Werte je Kennzahl und Referenzgruppe. z_werte = list() for (g in seq_len(nrow(referenzgruppen))) { gname = referenzgruppen$gruppe[g] z_werte[[gname]] = sapply(EDEQ_KENNZAHLEN$key, function(k) { v = kennzahlen[[k]] if (is.na(v)) return(NA_real_) (v - referenzgruppen[[paste0(k, "_m")]][g]) / referenzgruppen[[paste0(k, "_sd")]][g] }) names(z_werte[[gname]]) = EDEQ_KENNZAHLEN$key } # Kernverhaltensitems 13-18: direkte Einzelitem-Uebernahme, keine Aggregation. kernitem_labels = c( edeq_13 = "Subjektive Essanfaelle (Item 13)", edeq_14 = "Situationen mit Kontrollverlust (Item 14)", edeq_15 = "Objektive Essanfaelle (Item 15)", edeq_16 = "Selbstinduziertes Erbrechen (Item 16)", edeq_17 = "Abfuehrmitteleinnahme (Item 17)", edeq_18 = "Zwanghaftes/getriebenes Sporttreiben (Item 18)" ) kernitems = lapply(names(kernitem_labels), function(var) { roh = if (var %in% names(dat_edeq)) zeile[[var]][1] else NA wert = suppressWarnings(as.numeric(roh)) list( var = var, label = kernitem_labels[[var]], wert = wert, anzeige = if (is.na(wert)) "k. A." else as.character(wert) ) }) # Zusatzangaben, deskriptiv. geschlecht = if ("edeq_geschlecht" %in% names(dat_edeq)) hole_choice_text(zeile[["edeq_geschlecht"]])[1] else NA_character_ amenorrhoe = if ("edeq_amenorrhoe" %in% names(dat_edeq)) hole_choice_text(zeile[["edeq_amenorrhoe"]])[1] else NA_character_ amenorrhoe_anzahl = if ("edeq_amenorrhoe_anzahl" %in% names(dat_edeq)) suppressWarnings(as.numeric(zeile[["edeq_amenorrhoe_anzahl"]][1])) else NA_real_ pille = if ("edeq_pille" %in% names(dat_edeq)) hole_choice_text(zeile[["edeq_pille"]])[1] else NA_character_ # BMI, nur wenn beide Werte vorhanden und Groesse plausibel (1.0-2.5 m, oder als # Zentimeterangabe 100-250 automatisch umgerechnet, siehe normalisiere_groesse()). gewicht_kg = if ("edeq_gewicht" %in% names(dat_edeq)) parse_dezimal(zeile[["edeq_gewicht"]][1]) else NA_real_ groesse_roh = if ("edeq_groesse" %in% names(dat_edeq)) parse_dezimal(zeile[["edeq_groesse"]][1]) else NA_real_ groesse_info = normalisiere_groesse(groesse_roh) groesse_m = groesse_info$meter groesse_konvertiert = groesse_info$konvertiert groesse_unplausibel = groesse_info$unplausibel bmi = if (!is.na(gewicht_kg) && !is.na(groesse_m)) { gewicht_kg / (groesse_m ^ 2) } else NA_real_ list( typ = "ergebnis", chiffre = chiffre, ausfuelldatum = ausfuelldatum, ausfuelldatum_fallback = ausfuelldatum_fallback, ausfuelldatum_dateikennung = ausfuelldatum_dateikennung, warnung_mehrfach = warnung_mehrfach, item_unerwartet = item_unerwartet, kennzahlen = kennzahlen, z_werte = z_werte, kernitems = kernitems, geschlecht = geschlecht, amenorrhoe = amenorrhoe, amenorrhoe_anzahl = amenorrhoe_anzahl, pille = pille, gewicht_kg = gewicht_kg, groesse_roh = groesse_roh, groesse_m = groesse_m, groesse_konvertiert = groesse_konvertiert, groesse_unplausibel = groesse_unplausibel, groesse_manuell_verwendet = FALSE, bmi = bmi ) }) output$ergebnis_ui = renderUI({ if (input$btn_suchen == 0) { return(div(class = "start-hinweis", "Patientenchiffre eingeben und auf \"Auswerten\" klicken." )) } erg = ergebnis_r() if (erg$typ == "skript_fehler") { return(div(class = "alert-fehler", tags$h4("Konfigurationsfehler"), tags$pre(style = "font-size:0.88em; white-space:pre-wrap;", erg$meldung) )) } if (erg$typ == "leere_eingabe") { return(div(class = "alert-warnung", "Bitte eine Patientenchiffre eingeben.")) } if (erg$typ == "format_fehler") { return(div(class = "alert-warnung", "Ungueltige Chiffre. Erwartet wird ein Grossbuchstabe gefolgt von 6 Ziffern, ", "z.B. P000123." )) } if (erg$typ == "chiffre_nicht_gefunden") { return(div(class = "alert-fehler", tags$h4("Chiffre nicht gefunden"), tags$p("Die Chiffre ", tags$b(paste0("«", erg$chiffre, "»")), " ist in der Pseudonymtabelle nicht vorhanden."), tags$p("Bitte Schreibweise pruefen oder Pseudonymtabelle aktualisieren.") )) } if (erg$typ == "keine_daten") { return(div(class = "alert-fehler", tags$h4("Kein EDE-Q-Datensatz gefunden"), tags$p("Zur Chiffre ", tags$b(paste0("«", erg$chiffre, "»")), " existiert ein Pseudonymeintrag, aber kein Datensatz in ", tags$code("daten_edeq"), "."), tags$p("Moegliche Ursachen: Bogen noch nicht ausgefuellt, ", "oder Daten noch nicht heruntergeladen.") )) } # typ == "ergebnis" kopf_block = div(class = "abschnitt-karte", div(class = "kopf-info", tags$b("Chiffre: "), erg$chiffre, " ", tags$b("Ausfuelldatum: "), erg$ausfuelldatum ), if (!is.null(erg$warnung_mehrfach)) div(class = "alert-warnung", "⚠ Hinweis: ", erg$warnung_mehrfach), if (isTRUE(erg$ausfuelldatum_fallback)) div(class = "alert-warnung", "⚠ Ausfuelldatum nicht in Rohdaten gefunden, Anzeigedatum verwendet."), if (length(erg$item_unerwartet) > 0) div(class = "alert-warnung", "⚠ Item-Kodierung unerwartet, Wert nicht auswertbar bei: ", paste(erg$item_unerwartet, collapse = ", "), ". Betroffene Subskala(en) als \"nicht berechenbar\" ausgewiesen.") ) tab_kennzahlen_zeilen = lapply(EDEQ_KENNZAHLEN$key, function(k) { idx = match(k, EDEQ_KENNZAHLEN$key) v = erg$kennzahlen[[k]] tags$tr( tags$td(EDEQ_KENNZAHLEN$label[idx]), tags$td(if (is.na(v)) "nicht berechenbar" else sprintf("%.2f", v)) ) }) kennzahlen_block = div(class = "abschnitt-karte", tags$h4(class = "abschnitt-titel", "Subskalen- und Gesamtmittelwerte"), tags$table(class = "tabelle-kennzahlen", tags$thead(tags$tr(tags$th("Kennzahl"), tags$th("Mittelwert (0-6)"))), tags$tbody(tab_kennzahlen_zeilen) ) ) tab_z_kopf = tags$tr( tags$th("Kennzahl"), tags$th("Ihr Wert"), lapply(referenzgruppen$gruppe, function(g) tags$th(g)) ) tab_z_zeilen = lapply(EDEQ_KENNZAHLEN$key, function(k) { idx = match(k, EDEQ_KENNZAHLEN$key) v = erg$kennzahlen[[k]] tags$tr( tags$td(EDEQ_KENNZAHLEN$label[idx]), tags$td(if (is.na(v)) "-" else sprintf("%.2f", v)), lapply(referenzgruppen$gruppe, function(g) { z = erg$z_werte[[g]][[k]] tags$td(if (is.na(z)) "-" else sprintf("%.2f", z)) }) ) }) gauge_plots = lapply(EDEQ_KENNZAHLEN$key, function(k) { idx = match(k, EDEQ_KENNZAHLEN$key) plotname = paste0("gauge_", k) column(6, plotOutput(plotname, height = "150px")) }) referenz_block = div(class = "abschnitt-karte", tags$h4(class = "abschnitt-titel", "Referenzgruppen-Vergleich (z-Werte)"), tags$p(style = "font-size:0.85em; color:#888; font-style:italic;", "Deskriptiver Vergleich, kein validierter Cutoff."), div(style = "overflow-x:auto;", tags$table(class = "tabelle-kennzahlen", tags$thead(tab_z_kopf), tags$tbody(tab_z_zeilen) ) ), tags$hr(), fluidRow(gauge_plots) ) kernitem_zeilen = lapply(erg$kernitems, function(it) { div(class = "item-zeile", div(class = "item-text", it$label), tags$b(it$anzeige) ) }) kernitem_block = div(class = "abschnitt-karte", tags$h4(class = "abschnitt-titel", "Kernverhaltensitems 13-18 (Einzelitem-Auswertung, keine Subskala)"), div(kernitem_zeilen) ) # BMI-Anzeige ist ein eigener uiOutput (statt hier inline), damit bei unplausibler # Groesse ein manuelles Eingabefeld angeboten werden kann, dessen Ergebnis separat # (reaktiv auf die manuelle Eingabe) nachberechnet wird, ohne das gesamte # Ergebnis-Panel bei jedem Tastendruck neu zu erzeugen. bmi_block = uiOutput("bmi_block_ui") zusatz_block = div(class = "abschnitt-karte", tags$h4(class = "abschnitt-titel", "Zusatzangaben"), div(class = "desk-zeile", div(class = "desk-label", "Geschlecht:"), div(if (is.na(erg$geschlecht)) "k. A." else erg$geschlecht) ), if (!is.na(erg$geschlecht) && erg$geschlecht == "weiblich") tagList( div(class = "desk-zeile", div(class = "desk-label", "Amenorrhoe:"), div(if (is.na(erg$amenorrhoe)) "k. A." else erg$amenorrhoe) ), if (!is.na(erg$amenorrhoe) && erg$amenorrhoe == "JA") div(class = "desk-zeile", div(class = "desk-label", "Anzahl Monate Amenorrhoe:"), div(if (is.na(erg$amenorrhoe_anzahl)) "k. A." else as.character(erg$amenorrhoe_anzahl)) ), div(class = "desk-zeile", div(class = "desk-label", "Hormonelle Verhuetung (Pille):"), div(if (is.na(erg$pille)) "k. A." else erg$pille) ) ) ) disclaimer_block = div(class = "abschnitt-karte", div(class = "disclaimer-text", EDEQ_DISCLAIMER) ) tagList(kopf_block, kennzahlen_block, referenz_block, kernitem_block, bmi_block, zusatz_block, disclaimer_block) }) # Ein renderPlot je Kennzahl (Restraint/EC/WC/SC/Gesamt), da plotOutput-IDs statisch # in der UI-Funktion angelegt werden. lapply(EDEQ_KENNZAHLEN$key, function(k) { idx = match(k, EDEQ_KENNZAHLEN$key) local({ kk = k ll = EDEQ_KENNZAHLEN$label[idx] output[[paste0("gauge_", kk)]] = renderPlot({ req(input$btn_suchen > 0) erg = ergebnis_r() req(erg$typ == "ergebnis") erstelle_gauge_edeq(kk, ll, erg$kennzahlen[[kk]]) }, bg = "white") }) }) # bmi_block_ui haengt NUR an ergebnis_r() (nicht an input$groesse_manuell), damit das # numericInput bei unplausibler Groesse nur einmal pro Klick auf "Auswerten" erzeugt # wird und beim Tippen nicht staendig neu aufgebaut/zurueckgesetzt wird. Die eigentliche # BMI-Nachberechnung aus der manuellen Eingabe passiert separat in bmi_manuell_ui. output$bmi_block_ui = renderUI({ req(input$btn_suchen > 0) erg = ergebnis_r() req(erg$typ == "ergebnis") if (!is.na(erg$bmi)) { return(div(class = "abschnitt-karte", tags$h4(class = "abschnitt-titel", "BMI"), if (isTRUE(erg$groesse_konvertiert)) div(class = "alert-warnung", sprintf("Groesse als Zentimeterangabe erkannt und automatisch umgerechnet (verwendet: %.2f m).", erg$groesse_m)), tags$span(sprintf("%.1f kg/m²", erg$bmi)) )) } if (isTRUE(erg$groesse_unplausibel)) { return(div(class = "abschnitt-karte", tags$h4(class = "abschnitt-titel", "BMI"), div(class = "alert-warnung", sprintf("Groesse unplausibel (Rohwert: %s), automatische BMI-Berechnung nicht moeglich.", if (is.na(erg$groesse_roh)) "k. A." else as.character(erg$groesse_roh))), div(style = "margin-top:10px;", numericInput("groesse_manuell", "Groesse manuell eingeben (Meter, z.B. 1.75)", value = NA, min = 1.0, max = 2.5, step = 0.01, width = "260px") ), uiOutput("bmi_manuell_ui") )) } NULL }) output$bmi_manuell_ui = renderUI({ erg = ergebnis_r() req(erg$typ == "ergebnis", isTRUE(erg$groesse_unplausibel)) if (is.null(input$groesse_manuell) || is.na(input$groesse_manuell)) return(NULL) res = edeq_bmi_effektiv(erg, input$groesse_manuell) if (!res$gueltig) { msg = if (is.na(erg$gewicht_kg)) "Kein Gewicht in den Rohdaten vorhanden - BMI kann auch mit manueller Groesse nicht berechnet werden." else "Bitte Groesse in Metern zwischen 1.0 und 2.5 eingeben (z.B. 1.75)." return(div(class = "alert-warnung", msg)) } div(style = "margin-top:8px;", tags$span(sprintf("%.1f kg/m²", res$bmi)), div(class = "alert-warnung", "Manuell eingegebene Groesse verwendet (nicht aus den Rohdaten).") ) }) output$download_word = downloadHandler( filename = function() { erg = ergebnis_r() if (is.null(erg) || erg$typ != "ergebnis") return("EDEQ_Auswertung.docx") chiffre_esc = gsub("[^A-Za-z0-9_-]", "_", erg$chiffre) paste0("EDEQ_", chiffre_esc, "_", erg$ausfuelldatum_dateikennung, ".docx") }, content = function(file) { req(ergebnis_r()$typ == "ergebnis") erg = ergebnis_r() # Falls die Rohdaten-Groesse unplausibel war und eine manuelle Eingabe vorliegt, # denselben effektiven BMI wie auf dem Bildschirm auch im Word-Export verwenden. if (is.na(erg$bmi) && isTRUE(erg$groesse_unplausibel)) { res = edeq_bmi_effektiv(erg, input$groesse_manuell) if (isTRUE(res$gueltig)) { erg$bmi = res$bmi erg$groesse_m = res$groesse_m erg$groesse_manuell_verwendet = TRUE } } doc = erstelle_edeq_docx(erg) print(doc, target = file) } ) } # Start #### shinyApp(ui = ui, server = server)