# Präambel #### AKZENT_FARBE = "#8B2635" PFAD_DOWNLOAD_SKRIPT = "../API/get_data_hasewursk.R" PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" WURSK_WARNUNG = paste0( "Diese Summe ist eine ungepolte Rohsumme aller 25 Items. Eine im Original ", "moeglicherweise vorgesehene Umpolung einzelner positiv formulierter Items ist ", "in dieser Quelle nicht dokumentiert und wurde daher nicht angewendet. Es liegt ", "zudem kein bestaetigter Cutoff-Wert vor. Die Summe hat ausschliesslich ", "orientierenden Charakter und ersetzt keine normierte Auswertung." ) WURSK_DISCLAIMER = paste0( "Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ", "keine klinische Diagnose. Die Rohsumme ist ungepolt und ohne bestaetigten Cutoff-Wert; ", "die Interpretation obliegt der behandelnden Person." ) # Fallback-Stufennamen, falls das labels-Attribut einer Item-Spalte einmal fehlen sollte. WURSK_STUFEN_NAMEN = c( "trifft nicht zu", "gering ausgepraegt", "maessig ausgepraegt", "deutlich ausgepraegt", "stark ausgepraegt" ) # Verlauf gruen -> dunkelrot entspricht den 5 Antwortstufen 0-4. WURSK_BADGE_FARBEN = c( "0" = "#4CAF50", "1" = "#F48FB1", "2" = "#EF5350", "3" = "#B71C1C", "4" = "#4A0000" ) WURSK_BADGE_TEXT_FARBEN = c( "0" = "white", "1" = "#333333", "2" = "white", "3" = "white", "4" = "white" ) # Zeitstempel-Spalte fuer Sortierung bei Mehrfachtreffern und fuer das Ausfuelldatum # im Word-Export. Name ist der formr-Standard "created", aber aus der vorliegenden # Quelle nicht verifiziert. Beim ersten Testlauf names(daten_wursk) bzw. str(daten_wursk) # pruefen und diese Konstante bei Bedarf anpassen. WURSK_ZEITSTEMPEL_SPALTE = "created" library(shiny) library(dplyr) library(ggplot2) library(haven) library(officer) library(DBI) library(RSQLite) # 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 #### # Stufenzuordnung (0-4) wird nie aus hartkodierten Zahlenwerten abgeleitet, sondern # immer aus dem labels-Attribut der ORIGINAL-Spalte (vor Subsetting), da die # formr-Kodierung nicht notwendig 0-basiert ist. wursk_get_stufe = function(original_col, wert) { if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_integer_) labels_vec = attr(original_col, "labels") if (is.null(labels_vec) || length(labels_vec) == 0) return(NA_integer_) sortiert = labels_vec[order(labels_vec)] pos = match(as.numeric(wert[1]), as.numeric(sortiert)) if (is.na(pos)) return(NA_integer_) as.integer(pos - 1L) } wursk_get_anker = function(original_col, wert) { if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_character_) labels_vec = attr(original_col, "labels") if (is.null(labels_vec) || length(labels_vec) == 0) return(NA_character_) sortiert = labels_vec[order(labels_vec)] pos = match(as.numeric(wert[1]), as.numeric(sortiert)) if (is.na(pos)) return(NA_character_) bereinige_text(names(sortiert)[pos]) } # Entfernt Markdown-Sternchen und loest die "\." Maskierung (Backslash+Punkt) aus dem # formr-Label-Text wieder in einen literalen Punkt auf. bereinige_text = function(x) { if (is.null(x) || length(x) == 0 || is.na(x[1])) return(NA_character_) x = as.character(x[1]) x = gsub("\\*\\*", "", x) x = gsub("\\.", ".", x, fixed = TRUE) x } # Entfernt die fuehrende Itemnummer plus Punkt aus dem bereits bereinigten Label-Text, # damit der .item-text-Block (neben der separaten .item-nr-Anzeige) nicht doppelt # nummeriert erscheint. entferne_itemnummer = function(x) { if (is.null(x) || length(x) == 0 || is.na(x[1])) return(NA_character_) gsub("^[0-9]+\\.\\s*", "", x[1]) } wursk_berechne_summe = function(stufen) { as.numeric(sum(as.numeric(stufen), na.rm = TRUE)) } # Item-Reihenfolge fuer die Anzeige: absteigend nach Stufe (hoechste Auspraegung # zuerst), damit die auffaelligsten Antworten oben stehen. NA-Stufen stehen zuletzt. wursk_sortierung_nach_wert = function(stufen) { order(stufen, decreasing = TRUE, na.last = TRUE) } make_balken_wursk = function(summe) { df = data.frame(kategorie = "Summe", wert = as.numeric(summe)) ggplot(df, aes(x = kategorie, y = wert)) + geom_col(fill = AKZENT_FARBE, width = 0.55) + geom_text(aes(label = paste0(round(wert), " / 100")), hjust = -0.15, color = AKZENT_FARBE, fontface = "bold", size = 5) + scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 20)) + coord_flip(clip = "off") + theme_minimal(base_size = 12) + theme( axis.title.x = element_blank(), axis.title.y = element_blank(), axis.text.y = element_blank(), axis.ticks.y = element_blank(), panel.grid.major.y = element_blank(), panel.grid.minor = element_blank(), plot.margin = margin(t = 5, r = 50, b = 5, l = 10) ) } # 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; } .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; } .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-0 { background: #4CAF50; color: white; } .stufe-badge-1 { background: #F48FB1; color: #333333; } .stufe-badge-2 { background: #EF5350; color: white; } .stufe-badge-3 { background: #B71C1C; color: white; } .stufe-badge-4 { background: #4A0000; color: white; } .score-zahl { font-size: 2.2rem; font-weight: 800; color: #8B2635; } " 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("HASE - Wender-Utah-Rating-Scale Kurzform (WURS-K)"), tags$p("Selbstauskunft zu retrospektiven ADHS-Symptomen in der Kindheit") ), 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_wursk_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_warnung = fp_text(font.size = 10, color = "#BF360C", shading.color = "#FFF3E0") fp_summe = fp_text(bold = TRUE, font.size = 12) fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777") doc = body_add_fpar(doc, fpar(ftext( "HASE - Wender-Utah-Rating-Scale Kurzform (WURS-K)", fp_titel))) doc = body_add_fpar(doc, fpar( ftext("Chiffre: ", fp_label), ftext(erg$chiffre, fp_normal), ftext(" Datum: ", fp_label), ftext(erg$datum_str, fp_normal) )) doc = body_add_par(doc, "", style = "Normal") doc = body_add_fpar(doc, fpar(ftext(WURSK_WARNUNG, fp_warnung))) doc = body_add_par(doc, "", style = "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("Rohsumme (ungepolt): ", fp_label), ftext(paste0(erg$summe, " / 100"), fp_summe) )) doc = body_add_par(doc, "", style = "Normal") doc = body_add_fpar(doc, fpar(ftext("WURS-K Einzelitems", fp_abschnitt))) for (i in wursk_sortierung_nach_wert(erg$stufen)) { stufe = erg$stufen[i] anker = erg$anker_texte[i] stufe_key = if (!is.na(stufe) && stufe >= 0L && stufe <= 4L) as.character(stufe) else "0" anker_txt = if (!is.na(anker)) anker else WURSK_STUFEN_NAMEN[as.integer(stufe_key) + 1L] item_txt = if (!is.na(erg$item_texte[i])) erg$item_texte[i] else paste0("Item ", i) fp_badge = fp_text( color = WURSK_BADGE_TEXT_FARBEN[[stufe_key]], bold = TRUE, shading.color = WURSK_BADGE_FARBEN[[stufe_key]], font.size = 10 ) doc = body_add_fpar(doc, fpar( ftext(paste0(i, ". ", item_txt, " "), fp_normal), ftext(paste0(" ", anker_txt, " "), fp_badge) )) } doc = body_add_par(doc, "", style = "Normal") doc = body_add_fpar(doc, fpar(ftext(WURSK_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))) } }) # Skripte werden NICHT beim App-Start gesourct, nur beim Klick auf "Auswerten". 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)) } if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) { return(list(typ = "pfad_fehler", meldung = paste0("Download-Skript nicht gefunden: ", PFAD_DOWNLOAD_SKRIPT))) } if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) { return(list(typ = "pfad_fehler", meldung = paste0("Pseudonym-Skript nicht gefunden: ", PFAD_PSEUDONYM_SKRIPT))) } ok_dl = tryCatch({ source(PFAD_DOWNLOAD_SKRIPT, local = FALSE) list(ok = TRUE) }, error = function(e) list(ok = FALSE, msg = e$message)) if (!ok_dl$ok) return(list(typ = "skript_fehler", meldung = ok_dl$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 = ok_ps$msg)) if (!exists("daten_wursk", envir = .GlobalEnv) || !exists("pseudo", envir = .GlobalEnv)) { return(list(typ = "daten_fehlen", meldung = paste0( "Die Objekte 'daten_wursk' und/oder 'pseudo' wurden nach dem Sourcen der ", "externen Skripte nicht gefunden."))) } daten_wursk = get("daten_wursk", envir = .GlobalEnv) pseudo = get("pseudo", envir = .GlobalEnv) if (nchar(trimws(input$pseudonym)) > 0) { pw_treffer = pseudo[pseudo$pseudonym == trimws(input$pseudonym), ] if (nrow(pw_treffer) > 0) chiffre = toupper(trimws(pw_treffer$chiffre[1])) } treffer_ps = pseudo[pseudo$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_wursk[daten_wursk$session %in% alle_session_ids, ] if (nrow(treffer_dat) == 0) { return(list(typ = "kein_treffer", meldung = paste0( "Kein WURS-K-Datensatz fuer Chiffre '", chiffre, "' gefunden. (", length(alle_session_ids), " Pseudonym(e) geprueft)"))) } info_mehrere = NULL if (nrow(treffer_dat) > 1) { n = nrow(treffer_dat) treffer_dat = treffer_dat[order(treffer_dat[[WURSK_ZEITSTEMPEL_SPALTE]], decreasing = TRUE), ] datum_neu = tryCatch( format(as.POSIXct(treffer_dat[[WURSK_ZEITSTEMPEL_SPALTE]][1]), "%d.%m.%Y %H:%M"), error = function(e) "unbekanntes Datum" ) info_mehrere = paste0( "Mehrere Ausfuellungen gefunden (", n, " Eintraege). ", "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[[WURSK_ZEITSTEMPEL_SPALTE]][1]), "%d.%m.%Y"), error = function(e) format(Sys.Date(), "%d.%m.%Y") ) item_texte = sapply(seq_len(25), function(i) { var = paste0("wursk_", sprintf("%02d", i)) entferne_itemnummer(bereinige_text(attr(daten_wursk[[var]], "label"))) }) stufen = sapply(seq_len(25), function(i) { var = paste0("wursk_", sprintf("%02d", i)) wursk_get_stufe(daten_wursk[[var]], zeile[[var]]) }) anker_texte = sapply(seq_len(25), function(i) { var = paste0("wursk_", sprintf("%02d", i)) wursk_get_anker(daten_wursk[[var]], zeile[[var]]) }) summe = wursk_berechne_summe(stufen) list( typ = "ok", chiffre = chiffre, datum_str = datum_str, info_mehrere = info_mehrere, stufen = stufen, anker_texte = anker_texte, item_texte = item_texte, summe = summe ) }) output$fehler_ui = renderUI({ req(input$btn_suchen) d = ergebnis_r() if (identical(d$typ, "ok")) return(NULL) txt = switch(d$typ, "leere_eingabe" = d$meldung, "format_fehler" = paste0( "Ungueltige Chiffre '", d$chiffre, "'. Erwartet: ein Grossbuchstabe + 6 Ziffern (z.B. P000123)."), "pfad_fehler" = d$meldung, "skript_fehler" = paste0("Fehler beim Ausfuehren eines externen Skripts: ", d$meldung), "daten_fehlen" = d$meldung, "kein_treffer" = d$meldung, "Unbekannter Fehler." ) div(class = "alert-fehler", txt) }) output$warnung_ui = renderUI({ req(input$btn_suchen) d = ergebnis_r() if (!identical(d$typ, "ok") || is.null(d$info_mehrere)) return(NULL) div(class = "alert-warnung", d$info_mehrere) }) output$ergebnis_ui = renderUI({ req(input$btn_suchen) d = ergebnis_r() if (!identical(d$typ, "ok")) return(NULL) items_ui = lapply(wursk_sortierung_nach_wert(d$stufen), function(i) { stufe = d$stufen[i] anker = d$anker_texte[i] sk = if (!is.na(stufe) && stufe >= 0L && stufe <= 4L) as.character(stufe) else "0" anker_txt = if (!is.na(anker)) anker else WURSK_STUFEN_NAMEN[as.integer(sk) + 1L] item_txt = if (!is.na(d$item_texte[i])) d$item_texte[i] else paste0("Item ", i) div(class = "item-zeile", div(class = "item-nr", paste0(i, ".")), div(class = "item-text", item_txt), span(class = paste0("stufe-badge stufe-badge-", sk), anker_txt) ) }) div(class = "abschnitt-karte", div(class = "abschnitt-titel", "WURS-K"), div(class = "meta-block", tags$strong("Chiffre: "), d$chiffre, tags$span(" | ", style = "color:#ccc;"), tags$strong("Ausfuelldatum: "), d$datum_str ), div(class = "alert-warnung", WURSK_WARNUNG), tags$hr(), fluidRow( column(3, div( div(class = "score-zahl", d$summe), div("Rohsumme (0-100, ungepolt)", style = "color:#555;") ) ), column(9, plotOutput("balken_plot", height = "120px")) ), tags$hr(), tags$h5("WURS-K Einzelitems"), div(items_ui) ) }) output$balken_plot = renderPlot({ req(input$btn_suchen) d = ergebnis_r() req(identical(d$typ, "ok")) make_balken_wursk(d$summe) }, bg = "transparent") output$download_word = downloadHandler( filename = function() { d = tryCatch(ergebnis_r(), error = function(e) NULL) chiffre = if (is.list(d) && identical(d$typ, "ok") && nchar(d$chiffre) > 0) d$chiffre else "export" datum = if (is.list(d) && identical(d$typ, "ok") && !is.null(d$datum_str)) tryCatch( format(as.Date(d$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("HASE_WURSK_", chiffre, "_", datum, ".docx") }, content = function(file) { d = tryCatch(ergebnis_r(), error = function(e) NULL) daten_ok = is.list(d) && identical(d$typ, "ok") if (!daten_ok) { doc = read_docx() doc = body_add_par(doc, "Kein Datensatz geladen. Bitte zuerst Chiffre oder Pseudonym eingeben und 'Auswerten' klicken.", style = "Normal") print(doc, target = file) return() } doc = tryCatch( erstelle_wursk_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)