# Praembel #### PFAD_DOWNLOAD_SKRIPT = "../API/get_data_itq.R" PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" AKZENT_FARBE = "#8B2635" ITQ_DISCLAIMER = paste0( "Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt keine ", "klinische Diagnose. Der diagnostische Algorithmus folgt Cloitre et al. (2018) / deutsche ", "Version Lueger-Schuster, Knefel, Maercker. 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 = normalizePath(absPath(PFAD_DOWNLOAD_SKRIPT), mustWork = FALSE) PFAD_PSEUDONYM_SKRIPT = normalizePath(absPath(PFAD_PSEUDONYM_SKRIPT), mustWork = FALSE) # Infrastruktur #### library(shiny) library(dplyr) library(ggplot2) library(haven) library(officer) # Helper #### # Extrahiert die Stufe 0-4 ausschliesslich aus dem fuehrenden Zeichen im # Label-Text (z.B. "0) Gar nicht" -> 0L). Nie aus dem rohen Zahlenwert, # da 1-Indizierung nicht verifiziert (TODO VERIFIZIEREN: ob raw==1 wirklich # Stufe 0 bedeutet, analog BDI-II-Erfahrung in dieser Installation). hole_stufe = function(spalte, wert) { lab = attr(spalte, "labels") if (is.null(lab) || is.na(wert)) return(NA_integer_) treffer = names(lab)[lab == wert] if (length(treffer) == 0) return(NA_integer_) treffer = gsub("\\*\\*", "", treffer[1]) as.integer(gsub("^([0-9]+)\\).*", "\\1", treffer)) } hole_fragetext = function(spalte) { lab = attr(spalte, "label") if (is.null(lab)) return(NA_character_) gsub("\\*\\*", "", lab) } hole_zeit_text = function(spalte, wert) { lab = attr(spalte, "labels") if (is.null(lab) || is.na(wert)) return(NA_character_) treffer = names(lab)[lab == wert] if (length(treffer) == 0) return(NA_character_) gsub("\\*\\*", "", treffer[1]) } # Gibt farbige HTML-Badges fuer Stufen 0-4 zurueck. stufe_badge_html = function(stufe) { sk = if (!is.na(stufe) && stufe >= 0L && stufe <= 4L) as.character(stufe) else NA if (is.na(sk)) return(span(class = "stufe-badge stufe-badge-na", "?")) span(class = paste0("stufe-badge stufe-badge-", sk), sk) } # Prueft ob ein logischer Vektorwert (moeglicherweise NA) ein Kriterium erfuellt. kriterium_status = function(val) { if (is.na(val)) "unbekannt" else if (isTRUE(val)) "erfuellt" else "nicht erfuellt" } kriterium_farbe = function(val) { if (is.na(val)) "#888888" else if (isTRUE(val)) "#2E7D32" else "#9E9E9E" } # 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; } .kontext-zeile { display: flex; gap: 8px; align-items: baseline; padding: 4px 0; color: #444; font-size: 0.93em; } .kontext-label { font-weight: 600; color: #333; min-width: 220px; } .diagnose-box { border-radius: 6px; padding: 14px 18px; margin: 12px 0; border-left: 6px solid; } .diagnose-box-keine { background: #F5F5F5; border-color: #9E9E9E; color: #424242; } .diagnose-box-ptbs { background: #FFF3E0; border-color: #E65100; color: #BF360C; } .diagnose-box-kptbs { background: #FFEBEE; border-color: #B71C1C; color: #7f0000; } .diagnose-box-unvoll { background: #EDE7F6; border-color: #7E57C2; color: #4527A0; } .diagnose-titel { font-weight: 700; font-size: 1.25rem; margin-bottom: 4px; } .diagnose-quelle { font-size: 0.82em; color: #888; font-style: italic; margin-top: 6px; } .diagnose-disclaimer { font-size: 0.82em; color: #777; font-style: italic; margin-top: 10px; border-top: 1px solid rgba(0,0,0,.1); padding-top: 8px; } .kriterien-tabelle { width: 100%; border-collapse: collapse; margin-bottom: 8px; } .kriterien-tabelle th { text-align: left; padding: 6px 10px; font-size: 0.88em; background: #f9f9f9; border-bottom: 2px solid #eee; color: #555; } .kriterien-tabelle td { padding: 6px 10px; border-bottom: 1px solid #f0f0f0; font-size: 0.9em; } .kriterium-erfuellt { color: #2E7D32; font-weight: 700; } .kriterium-nicht { color: #9E9E9E; font-weight: 400; } .kriterium-unbekannt { color: #888888; font-weight: 400; } .dim-wert-zeile { display: flex; align-items: center; gap: 12px; padding: 5px 0; border-bottom: 1px solid #f0f0f0; font-size: 0.92em; } .dim-wert-label { min-width: 160px; font-weight: 600; color: #444; } .dim-wert-zahl { font-size: 1.1rem; font-weight: 700; color: #8B2635; min-width: 28px; } .dim-wert-bar-wrap { flex: 1; background: #f0f0f0; border-radius: 4px; height: 10px; max-width: 200px; } .dim-wert-bar { background: #8B2635; border-radius: 4px; height: 10px; } .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: 36px; flex-shrink: 0; } .item-text { flex: 1; color: #333; font-size: 0.92em; } .stufe-badge { border-radius: 4px; padding: 2px 9px; font-weight: 700; font-size: 0.82em; white-space: nowrap; display: inline-block; flex-shrink: 0; } .stufe-badge-na { background: #BDBDBD; color: #333; } .stufe-badge-0 { background: #4CAF50; color: white; } .stufe-badge-1 { background: #C8E6C9; color: #333333; } .stufe-badge-2 { background: #FFCDD2; color: #B71C1C; } .stufe-badge-3 { background: #EF5350; color: white; } .stufe-badge-4 { background: #4A0000; color: white; } " 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("ITQ - Internationales Trauma Questionnaire"), tags$p("Cloitre et al. 2018 | dt. Version Lueger-Schuster, Knefel, Maercker") ), 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_itq_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") # Diagnose-Farben fuer Word dx_farben = list( "KPTBS" = list(bg = "#FFEBEE", text = "#7f0000"), "PTBS" = list(bg = "#FFF3E0", text = "#BF360C"), "Keine Diagnose erfuellt" = list(bg = "#F5F5F5", text = "#424242"), "Unvollstaendig" = list(bg = "#EDE7F6", text = "#4527A0") ) dx_key = erg$diagnose dx_col = if (!is.null(dx_farben[[dx_key]])) dx_farben[[dx_key]] else dx_farben[["Keine Diagnose erfuellt"]] fp_dx = fp_text(bold = TRUE, font.size = 14, color = dx_col$text, shading.color = dx_col$bg) # Badge-Farben (Hintergrund, Schrift) fuer Stufen 0-4 badge_bg = c("0" = "#4CAF50", "1" = "#C8E6C9", "2" = "#FFCDD2", "3" = "#EF5350", "4" = "#4A0000") badge_text = c("0" = "white", "1" = "#333333", "2" = "#B71C1C", "3" = "white", "4" = "white") # Titel + Metadaten doc = body_add_fpar(doc, fpar(ftext("ITQ - Internationales Trauma Questionnaire", fp_titel))) doc = body_add_fpar(doc, fpar( ftext("Chiffre: ", fp_label), ftext(erg$chiffre, fp_normal), ftext(" Datum: ", fp_label), ftext(erg$ausfuelldatum, fp_normal) )) doc = body_add_par(doc, "", style = "Normal") # Kontext doc = body_add_fpar(doc, fpar(ftext("Belastende Lebenserfahrung", fp_abschnitt))) doc = body_add_fpar(doc, fpar( ftext("Erfahrung: ", fp_label), ftext(if (is.na(erg$lebenserfahrung_text) || erg$lebenserfahrung_text == "") "k. A." else erg$lebenserfahrung_text, fp_normal) )) doc = body_add_fpar(doc, fpar( ftext("Zeitangabe: ", fp_label), ftext(if (is.na(erg$lebenserfahrung_zeit_text)) "k. A." else erg$lebenserfahrung_zeit_text, fp_normal) )) doc = body_add_par(doc, "", style = "Normal") # Diagnose doc = body_add_fpar(doc, fpar(ftext("Diagnostisches Ergebnis", fp_abschnitt))) doc = body_add_fpar(doc, fpar(ftext(erg$diagnose, fp_dx))) doc = body_add_fpar(doc, fpar( ftext("Algorithmus nach Cloitre et al., 2018", fp_text(font.size = 9, italic = TRUE, color = "#888888")) )) doc = body_add_par(doc, "", style = "Normal") # Kriterien PTBS doc = body_add_fpar(doc, fpar(ftext("PTBS-Kriterien", fp_abschnitt))) kriterien_ptbs = list( list(name = "Re-Erleben (Re_dx)", val = erg$re_dx, items = "P1, P2"), list(name = "Vermeidung (Av_dx)", val = erg$av_dx, items = "P3, P4"), list(name = "Bedrohungswahrn. (Th_dx)", val = erg$th_dx, items = "P5, P6"), list(name = "Funktionsbeeintracht. (PTBSFI)", val = erg$ptbsfi, items = "P7, P8, P9") ) for (kr in kriterien_ptbs) { status_txt = if (is.na(kr$val)) "unbekannt" else if (isTRUE(kr$val)) "erfuellt" else "nicht erfuellt" status_col = if (is.na(kr$val)) "#888888" else if (isTRUE(kr$val)) "#2E7D32" else "#9E9E9E" doc = body_add_fpar(doc, fpar( ftext(paste0(kr$name, " (", kr$items, "): "), fp_normal), ftext(status_txt, fp_text(font.size = 11, bold = TRUE, color = status_col)) )) } doc = body_add_par(doc, "", style = "Normal") # Kriterien DSO doc = body_add_fpar(doc, fpar(ftext("DSO-Kriterien", fp_abschnitt))) kriterien_dso = list( list(name = "Affektdysreg. (AD_dx)", val = erg$ad_dx, items = "C1, C2"), list(name = "Neg. Selbstkonzept (NSC_dx)", val = erg$nsc_dx, items = "C3, C4"), list(name = "Beziehungsst. (DR_dx)", val = erg$dr_dx, items = "C5, C6"), list(name = "Funktionsbeeintracht. (DSOFI)", val = erg$dsofi, items = "C7, C8, C9") ) for (kr in kriterien_dso) { status_txt = if (is.na(kr$val)) "unbekannt" else if (isTRUE(kr$val)) "erfuellt" else "nicht erfuellt" status_col = if (is.na(kr$val)) "#888888" else if (isTRUE(kr$val)) "#2E7D32" else "#9E9E9E" doc = body_add_fpar(doc, fpar( ftext(paste0(kr$name, " (", kr$items, "): "), fp_normal), ftext(status_txt, fp_text(font.size = 11, bold = TRUE, color = status_col)) )) } doc = body_add_par(doc, "", style = "Normal") # Dimensionale Werte doc = body_add_fpar(doc, fpar(ftext("Dimensionale Werte (Rohwerte)", fp_abschnitt))) dim_zeilen = list( list(label = "Re-Erleben (Re)", val = erg$re, max = 8), list(label = "Vermeidung (Av)", val = erg$av, max = 8), list(label = "Bedrohungswahrnehmung (Th)", val = erg$th, max = 8), list(label = "PTBS-Summenwert", val = erg$ptbs_wert, max = 24), list(label = "Affektdysregulation (AD)", val = erg$ad, max = 8), list(label = "Neg. Selbstkonzept (NSC)", val = erg$nsc, max = 8), list(label = "Beziehungsstorungen (DR)", val = erg$dr, max = 8), list(label = "DSO-Summenwert", val = erg$dso_wert, max = 24) ) for (dz in dim_zeilen) { val_txt = if (is.na(dz$val)) "k. A." else paste0(dz$val, " / ", dz$max) doc = body_add_fpar(doc, fpar( ftext(paste0(dz$label, ": "), fp_label), ftext(val_txt, fp_normal) )) } doc = body_add_par(doc, "", style = "Normal") # Itemliste PTBS doc = body_add_fpar(doc, fpar(ftext("PTBS-Items (P1-P9)", fp_abschnitt))) for (i in seq_along(erg$p_stufen)) { stufe = erg$p_stufen[i] sk = if (!is.na(stufe) && stufe >= 0L && stufe <= 4L) as.character(stufe) else NA item_txt = if (!is.na(erg$p_texte[i])) erg$p_texte[i] else paste0("P", i) badge_txt = if (is.na(sk)) "?" else sk fp_badge = fp_text( bold = TRUE, font.size = 10, color = if (is.na(sk)) "#333" else badge_text[[sk]], shading.color = if (is.na(sk)) "#BDBDBD" else badge_bg[[sk]] ) doc = body_add_fpar(doc, fpar( ftext(paste0("P", i, ". ", item_txt, " "), fp_normal), ftext(paste0(" ", badge_txt, " "), fp_badge) )) } doc = body_add_par(doc, "", style = "Normal") # Itemliste DSO doc = body_add_fpar(doc, fpar(ftext("DSO-Items (C1-C9)", fp_abschnitt))) for (i in seq_along(erg$c_stufen)) { stufe = erg$c_stufen[i] sk = if (!is.na(stufe) && stufe >= 0L && stufe <= 4L) as.character(stufe) else NA item_txt = if (!is.na(erg$c_texte[i])) erg$c_texte[i] else paste0("C", i) badge_txt = if (is.na(sk)) "?" else sk fp_badge = fp_text( bold = TRUE, font.size = 10, color = if (is.na(sk)) "#333" else badge_text[[sk]], shading.color = if (is.na(sk)) "#BDBDBD" else badge_bg[[sk]] ) doc = body_add_fpar(doc, fpar( ftext(paste0("C", i, ". ", item_txt, " "), fp_normal), ftext(paste0(" ", badge_txt, " "), fp_badge) )) } doc = body_add_par(doc, "", style = "Normal") doc = body_add_fpar(doc, fpar(ftext(ITQ_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))) } }) ergebnis_r = eventReactive(input$btn_suchen, { # 1. Chiffre einlesen und validieren chiffre = toupper(trimws(input$chiffre)) if ((nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0)) return(list(error = "Bitte eine Patientenchiffre eingeben.")) if (!(nchar(trimws(input$pseudonym)) > 0 || grepl("^[A-Z][0-9]{6}$", chiffre))) return(list(error = paste0( "Ungueltige Chiffre '", chiffre, "'. Erwartet: ein Grossbuchstabe + 6 Ziffern (z.B. P000123)."))) # 2. Skriptpfade pruefen if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) return(list(error = paste0("Download-Skript nicht gefunden:\n", PFAD_DOWNLOAD_SKRIPT))) if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) return(list(error = paste0("Pseudonym-Skript nicht gefunden:\n", PFAD_PSEUDONYM_SKRIPT))) # 3. Download-Skript sourcen res_dl = tryCatch( { source(PFAD_DOWNLOAD_SKRIPT, local = FALSE); list(ok = TRUE) }, error = function(e) list(ok = FALSE, msg = e$message) ) if (!res_dl$ok) return(list(error = paste0("Fehler im Download-Skript: ", res_dl$msg))) # 4. pseudonyme.db suchen (bis 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 }) # 5. setwd + Pseudonym-Skript sourcen alter_wd = getwd() on.exit(setwd(alter_wd), add = TRUE) wd_ziel = if (!is.null(db_ordner)) db_ordner else dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE)) setwd(wd_ziel) res_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) ) if (!res_ps$ok) return(list(error = paste0("Fehler im Pseudonym-Skript: ", res_ps$msg))) # 6. Existenzpruefung if (!exists("daten_itq", envir = .GlobalEnv)) return(list(error = paste0( "Objekt 'daten_itq' nach dem Sourcen nicht gefunden. Bitte Download-Skript pruefen."))) if (!exists("pseudo", envir = .GlobalEnv)) return(list(error = paste0( "Objekt 'pseudo' nach dem Sourcen nicht gefunden. Bitte Pseudonym-Skript pruefen."))) daten = get("daten_itq", envir = .GlobalEnv) pseudo_df = get("pseudo", envir = .GlobalEnv) # 7. Chiffre-Lookup in pseudo treffer_ps = pseudo_df[toupper(trimws(pseudo_df$chiffre)) == chiffre, ] if (nrow(treffer_ps) == 0) return(list(error = paste0( "Chiffre '", chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden."))) warnung_mehrfach_pseudo = nrow(treffer_ps) > 1 zeile_ps = treffer_ps[1, , drop = FALSE] pseudonym = zeile_ps$pseudonym[1] if (nchar(trimws(input$pseudonym)) > 0) pseudonym = trimws(input$pseudonym) # Daten-Lookup # TODO VERIFIZIEREN: Spaltenname 'session' aus frueheren Apps dieser Installation # uebernommen, noch nicht am echten ITQ-Export geprueft. treffer_dat = daten[daten$session == pseudonym, ] if (nrow(treffer_dat) == 0) return(list(error = paste0( "Kein ITQ-Datensatz fuer Chiffre '", chiffre, "' gefunden."))) warnung_mehrfach_ausgefuellt = nrow(treffer_dat) > 1 if (nrow(treffer_dat) > 1) { treffer_dat = treffer_dat[order(treffer_dat$created, decreasing = TRUE), ] treffer_dat = treffer_dat[1, , drop = FALSE] } zeile = treffer_dat[1, , drop = FALSE] # Ausfuelldatum parsen # TODO VERIFIZIEREN: Typ von 'created' kann POSIXct oder character sein. ausfuelldatum = tryCatch( format(as.Date(as.POSIXct(zeile[["created"]][1])), "%d.%m.%Y"), error = function(e) tryCatch( format(as.Date(zeile[["created"]][1]), "%d.%m.%Y"), error = function(e2) format(Sys.Date(), "%d.%m.%Y") ) ) # Kontext lebenserfahrung_text = tryCatch(as.character(zeile[["lebenserfahrung_text"]][1]), error = function(e) NA_character_) lebenserfahrung_zeit_text = hole_zeit_text( daten[["lebenserfahrung_zeit"]], zeile[["lebenserfahrung_zeit"]][1] ) # Stufen und Fragetexte P1-P9 (immer aus Original-Spaltenobjekt lesen) p_stufen = sapply(paste0("p", 1:9), function(v) hole_stufe(daten[[v]], zeile[[v]][1])) p_texte = sapply(paste0("p", 1:9), function(v) hole_fragetext(daten[[v]])) # Stufen und Fragetexte C1-C9 c_stufen = sapply(paste0("c", 1:9), function(v) hole_stufe(daten[[v]], zeile[[v]][1])) c_texte = sapply(paste0("c", 1:9), function(v) hole_fragetext(daten[[v]])) # Diagnostik-Algorithmus (ITQ Manual, Seite 4, Cloitre et al. 2018). # NA-Werte propagieren zu NA, nicht stillschweigend FALSE. re_dx = (p_stufen[1] >= 2) | (p_stufen[2] >= 2) av_dx = (p_stufen[3] >= 2) | (p_stufen[4] >= 2) th_dx = (p_stufen[5] >= 2) | (p_stufen[6] >= 2) ptbsfi = (p_stufen[7] >= 2) | (p_stufen[8] >= 2) | (p_stufen[9] >= 2) ad_dx = (c_stufen[1] >= 2) | (c_stufen[2] >= 2) nsc_dx = (c_stufen[3] >= 2) | (c_stufen[4] >= 2) dr_dx = (c_stufen[5] >= 2) | (c_stufen[6] >= 2) dsofi = (c_stufen[7] >= 2) | (c_stufen[8] >= 2) | (c_stufen[9] >= 2) ptbs_kriterien = re_dx & av_dx & th_dx & ptbsfi dso_kriterien = ad_dx & nsc_dx & dr_dx & dsofi # Unvollstaendigkeit: Kriterium kann nicht bewertet werden irgendein_na = anyNA(c(re_dx, av_dx, th_dx, ptbsfi, ad_dx, nsc_dx, dr_dx, dsofi)) diagnose = if (is.na(ptbs_kriterien) || is.na(dso_kriterien)) { # Partial: wenn eindeutig positiv oder negativ, trotzdem verwenden ptbs_pos = isTRUE(ptbs_kriterien) dso_pos = isTRUE(dso_kriterien) ptbs_nein = isFALSE(ptbs_kriterien) if (ptbs_pos && dso_pos) "KPTBS" else if (ptbs_pos) "Unvollstaendig" else if (ptbs_nein) "Keine Diagnose erfuellt" else "Unvollstaendig" } else { if (isTRUE(ptbs_kriterien) && isTRUE(dso_kriterien)) "KPTBS" else if (isTRUE(ptbs_kriterien)) "PTBS" else "Keine Diagnose erfuellt" # Manual-Hinweis: nur DSO erfuellt ohne PTBS -> keine Diagnose (s.o.) } # Dimensionale Werte (Rohwerte 0-8 je Subskala, 0-24 Gesamt) re = if (anyNA(p_stufen[1:2])) NA_integer_ else sum(p_stufen[1:2]) av = if (anyNA(p_stufen[3:4])) NA_integer_ else sum(p_stufen[3:4]) th = if (anyNA(p_stufen[5:6])) NA_integer_ else sum(p_stufen[5:6]) ptbs_wert = if (anyNA(c(re, av, th))) NA_integer_ else re + av + th ad = if (anyNA(c_stufen[1:2])) NA_integer_ else sum(c_stufen[1:2]) nsc = if (anyNA(c_stufen[3:4])) NA_integer_ else sum(c_stufen[3:4]) dr = if (anyNA(c_stufen[5:6])) NA_integer_ else sum(c_stufen[5:6]) dso_wert = if (anyNA(c(ad, nsc, dr))) NA_integer_ else ad + nsc + dr list( error = NULL, chiffre = chiffre, ausfuelldatum = ausfuelldatum, lebenserfahrung_text = lebenserfahrung_text, lebenserfahrung_zeit_text = lebenserfahrung_zeit_text, warnung_mehrfach_pseudo = warnung_mehrfach_pseudo, warnung_mehrfach_ausgefuellt = warnung_mehrfach_ausgefuellt, p_stufen = p_stufen, p_texte = p_texte, c_stufen = c_stufen, c_texte = c_texte, re_dx = re_dx, av_dx = av_dx, th_dx = th_dx, ptbsfi = ptbsfi, ad_dx = ad_dx, nsc_dx = nsc_dx, dr_dx = dr_dx, dsofi = dsofi, ptbs_kriterien = ptbs_kriterien, dso_kriterien = dso_kriterien, diagnose = diagnose, re = re, av = av, th = th, ptbs_wert = ptbs_wert, ad = ad, nsc = nsc, dr = dr, dso_wert = dso_wert ) }) output$fehler_ui = renderUI({ req(input$btn_suchen) d = ergebnis_r() if (!is.null(d$error)) div(class = "alert-fehler", d$error) else NULL }) output$warnung_ui = renderUI({ req(input$btn_suchen) d = ergebnis_r() if (!is.null(d$error)) return(NULL) warnungen = list() if (isTRUE(d$warnung_mehrfach_pseudo)) warnungen = c(warnungen, list(div(class = "alert-warnung", tags$strong("Datenintegritaet: "), "Diese Chiffre ist in der Pseudonym-Datenbank mehrfach eingetragen. ", "Es wird der erste Treffer verwendet. Bitte Datenbank pruefen." ))) if (isTRUE(d$warnung_mehrfach_ausgefuellt)) warnungen = c(warnungen, list(div(class = "alert-warnung", tags$strong("Mehrfach ausgefuellt: "), "Fuer diese Person liegen mehrere ITQ-Ausfuellungen vor. ", "Angezeigt wird die neueste." ))) if (length(warnungen) == 0) return(NULL) tagList(warnungen) }) output$ergebnis_ui = renderUI({ req(input$btn_suchen) d = ergebnis_r() if (!is.null(d$error)) return(NULL) # Diagnose-Box-CSS-Klasse dx_klasse = switch(d$diagnose, "KPTBS" = "diagnose-box-kptbs", "PTBS" = "diagnose-box-ptbs", "Keine Diagnose erfuellt" = "diagnose-box-keine", "diagnose-box-unvoll" ) # Kriterien-Tabelle bauen (shared helper) kr_zeile = function(name, items, val) { status = kriterium_status(val) klasse = switch(status, "erfuellt" = "kriterium-erfuellt", "nicht erfuellt" = "kriterium-nicht", "kriterium-unbekannt" ) tags$tr( tags$td(name), tags$td(items), tags$td(class = klasse, status) ) } kriterien_ptbs_tbl = tags$table(class = "kriterien-tabelle", tags$thead(tags$tr( tags$th("Kriterium"), tags$th("Items"), tags$th("Status") )), tags$tbody( kr_zeile("Re-Erleben (Re_dx)", "P1, P2", d$re_dx), kr_zeile("Vermeidung (Av_dx)", "P3, P4", d$av_dx), kr_zeile("Bedrohungswahrn. (Th_dx)", "P5, P6", d$th_dx), kr_zeile("Funkt.-beeintr. (PTBSFI)", "P7, P8, P9", d$ptbsfi) ) ) kriterien_dso_tbl = tags$table(class = "kriterien-tabelle", tags$thead(tags$tr( tags$th("Kriterium"), tags$th("Items"), tags$th("Status") )), tags$tbody( kr_zeile("Affektdysreg. (AD_dx)", "C1, C2", d$ad_dx), kr_zeile("Neg. Selbstkonz. (NSC_dx)", "C3, C4", d$nsc_dx), kr_zeile("Beziehungsst. (DR_dx)", "C5, C6", d$dr_dx), kr_zeile("Funkt.-beeintr. (DSOFI)", "C7, C8, C9", d$dsofi) ) ) # Dimensionale Werte dim_balken = function(label, val, max_val) { pct = if (!is.na(val)) paste0(round(val / max_val * 100), "%") else "0%" val_txt = if (is.na(val)) "k. A." else as.character(val) div(class = "dim-wert-zeile", div(class = "dim-wert-label", label), div(class = "dim-wert-zahl", val_txt), div(class = "dim-wert-bar-wrap", div(class = "dim-wert-bar", style = paste0("width:", pct, ";")) ), div(style = "font-size:0.8em; color:#999;", paste0("/ ", max_val)) ) } dim_ui = tagList( dim_balken("Re-Erleben (Re)", d$re, 8), dim_balken("Vermeidung (Av)", d$av, 8), dim_balken("Bedrohungswahrn. (Th)", d$th, 8), tags$div(style = "border-top: 2px solid #eee; margin: 4px 0;"), div(class = "dim-wert-zeile", div(class = "dim-wert-label", tags$strong("PTBS-Summenwert")), div(class = "dim-wert-zahl", style = "font-size:1.3rem;", if (is.na(d$ptbs_wert)) "k. A." else d$ptbs_wert), div(style = "font-size:0.8em; color:#999;", "/ 24") ), tags$div(style = "border-top: 2px solid #eee; margin: 6px 0 2px;"), dim_balken("Affektdysreg. (AD)", d$ad, 8), dim_balken("Neg. Selbstkonz. (NSC)", d$nsc, 8), dim_balken("Beziehungsst. (DR)", d$dr, 8), tags$div(style = "border-top: 2px solid #eee; margin: 4px 0;"), div(class = "dim-wert-zeile", div(class = "dim-wert-label", tags$strong("DSO-Summenwert")), div(class = "dim-wert-zahl", style = "font-size:1.3rem;", if (is.na(d$dso_wert)) "k. A." else d$dso_wert), div(style = "font-size:0.8em; color:#999;", "/ 24") ) ) # Itemlisten items_ui_ptbs = lapply(seq_along(d$p_stufen), function(i) { div(class = "item-zeile", div(class = "item-nr", paste0("P", i, ".")), div(class = "item-text", if (!is.na(d$p_texte[i])) d$p_texte[i] else paste0("P", i)), stufe_badge_html(d$p_stufen[i]) ) }) items_ui_c = lapply(seq_along(d$c_stufen), function(i) { div(class = "item-zeile", div(class = "item-nr", paste0("C", i, ".")), div(class = "item-text", if (!is.na(d$c_texte[i])) d$c_texte[i] else paste0("C", i)), stufe_badge_html(d$c_stufen[i]) ) }) tagList( # 1. Kontext-Block div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Belastende Lebenserfahrung"), div(class = "kontext-zeile", div(class = "kontext-label", "Erfahrung:"), div(if (is.na(d$lebenserfahrung_text) || d$lebenserfahrung_text == "") tags$em("k. A.") else d$lebenserfahrung_text) ), div(class = "kontext-zeile", div(class = "kontext-label", "Zeitangabe:"), div(if (is.na(d$lebenserfahrung_zeit_text)) tags$em("k. A.") else d$lebenserfahrung_zeit_text) ) ), # 2. Diagnose-Block div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Diagnostisches Ergebnis"), div(class = paste0("diagnose-box ", dx_klasse), div(class = "diagnose-titel", d$diagnose), div(class = "diagnose-quelle", "Algorithmus nach Cloitre et al., 2018"), div(class = "diagnose-disclaimer", ITQ_DISCLAIMER) ) ), # 3. Kriterien-Tabellen div(class = "abschnitt-karte", div(class = "abschnitt-titel", "PTBS-Kriterien"), kriterien_ptbs_tbl, tags$p(style = "margin-top:10px;", tags$strong("Gesamt: "), tags$span( style = paste0("color:", kriterium_farbe(d$ptbs_kriterien), "; font-weight:700;"), paste0("PTBS-Kriterien ", kriterium_status(d$ptbs_kriterien)) ) ) ), div(class = "abschnitt-karte", div(class = "abschnitt-titel", "DSO-Kriterien"), kriterien_dso_tbl, tags$p(style = "margin-top:10px;", tags$strong("Gesamt: "), tags$span( style = paste0("color:", kriterium_farbe(d$dso_kriterien), "; font-weight:700;"), paste0("DSO-Kriterien ", kriterium_status(d$dso_kriterien)) ) ), tags$p(style = "font-size:0.82em; color:#888; font-style:italic;", "Hinweis: Alleinige Erfuellung der DSO-Kriterien ohne PTBS ergibt keine Diagnose (Manual Cloitre et al., 2018).") ), # 4. Dimensionale Werte div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Dimensionale Werte (Rohwerte, keine Normierung)"), dim_ui ), # 5. Itemliste div(class = "abschnitt-karte", div(class = "abschnitt-titel", "PTBS-Items (P1-P9)"), div(items_ui_ptbs) ), div(class = "abschnitt-karte", div(class = "abschnitt-titel", "DSO-Items (C1-C9)"), div(items_ui_c) ) ) }) output$download_word = downloadHandler( filename = function() { d = tryCatch(ergebnis_r(), error = function(e) NULL) chiffre_esc = if (is.list(d) && is.null(d$error) && nchar(d$chiffre) > 0) d$chiffre else "export" ausfuelldatum_fn = if (is.list(d) && is.null(d$error)) tryCatch( format(as.Date(d$ausfuelldatum, "%d.%m.%Y"), "%Y%m%d"), error = function(e) format(Sys.Date(), "%Y%m%d") ) else format(Sys.Date(), "%Y%m%d") paste0("ITQ_", chiffre_esc, "_", ausfuelldatum_fn, ".docx") }, content = function(file) { d = tryCatch(ergebnis_r(), error = function(e) NULL) daten_ok = is.list(d) && is.null(d$error) if (!daten_ok) { 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_itq_docx(d), error = function(e) { err_doc = read_docx() body_add_par(err_doc, paste0("Fehler beim Erstellen des Word-Dokuments: ", e$message), style = "Normal") } ) print(doc, target = file) } ) } # Start #### shinyApp(ui, server)