DiagnostikApps/FKG/app.R

# Präambel ####

FKG_DISCLAIMER = paste0(
  "Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ",
  "keine klinische Diagnose. Fuer den FKG liegt keine validierte Berechnungsvorschrift, ",
  "kein Cutoff und keine Normstichprobe vor. Die dargestellten Zahlen sind rein deskriptive ",
  "Zaehlungen, keine psychometrischen Kennwerte. Die Interpretation obliegt der ",
  "behandelnden Person."
)

library(shiny)
library(dplyr)
library(haven)
library(officer)


# Infrastruktur ####

PFAD_DOWNLOAD_SKRIPT  = "../API/get_data_fkg.R"    # liefert beim Sourcen: daten_fkg
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R"       # liefert beim Sourcen: pseudo
AKZENT_FARBE          = "#8B2635"

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 ####

# Nie hartkodiert 1/2 - choice1 = "Ja" ist bei fkg.xlsx (mc_button) umgekehrt zur
# sonstigen Konvention, daher immer ueber das labels-Attribut der Original-Spalte aufloesen.
fkg_get_antwort = function(original_col, wert) {
  if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_character_)
  lbl_attr = attr(original_col, "labels")
  if (!is.null(lbl_attr) && length(lbl_attr) > 0) {
    pos = which(as.vector(lbl_attr) == as.numeric(wert[1]))
    if (length(pos) > 0) return(names(lbl_attr)[pos[1]])
  }
  NA_character_
}

# Entfernt Markdown-Escapes ("1\. Text" -> "1. Text", so liegt das label-Attribut
# in der fkg.xlsx vor) und danach die fuehrende Itemnummer samt Trennzeichen.
fkg_clean_item_text = function(text) {
  if (is.null(text) || length(text) == 0 || is.na(text[1])) return(NA_character_)
  txt = gsub("\\.", ".", trimws(as.character(text[1])), fixed = TRUE)
  trimws(sub("^[0-9.): ]+", "", txt))
}

# Baut die Item-Tabelle einer einzelnen Auswertung: Text + Antwort je Item, gejoint
# mit der statischen Faktor-Zuordnung, sortiert Ja vor Nein (stabil je Faktor).
fkg_erstelle_item_tabelle = function(zeile, daten) {
  items = fkg_mapping$item

  antworten = vapply(items, function(it) {
    fkg_get_antwort(daten[[it]], zeile[[it]])
  }, character(1))

  texte = vapply(items, function(it) {
    fkg_clean_item_text(attr(daten[[it]], "label"))
  }, character(1))

  tab = data.frame(
    item      = items,
    item_nr   = as.integer(sub("^fkg_", "", items)),
    faktor    = fkg_mapping$faktor,
    item_text = texte,
    antwort   = antworten,
    ist_ja    = !is.na(antworten) & toupper(trimws(antworten)) == "JA",
    stringsAsFactors = FALSE
  )

  arrange(tab, faktor, desc(ist_ja))
}

# Teilt die sortierte Item-Tabelle in die Abschnitte 1-5 + "Nicht zugeordnet",
# je mit der rein deskriptiven "X von Y"-Zaehlung.
fkg_gruppiere = function(tab) {
  lapply(FKG_FAKTOR_REIHENFOLGE, function(fname) {
    sub_tab = tab[tab$faktor == fname, ]
    list(
      faktor    = fname,
      items     = sub_tab,
      anzahl_ja = sum(sub_tab$ist_ja),
      gesamt    = nrow(sub_tab)
    )
  })
}


# Datenaufbereitung ####

FKG_FAKTOR_REIHENFOLGE = c(
  "Faktor 1: Katastrophisierende Bewertung",
  "Faktor 2: Intoleranz von körperlichen Beschwerden",
  "Faktor 3: Körperliche Schwäche",
  "Faktor 4: Vegetative Missempfindungen",
  "Faktor 5: Gesundheitsverhalten",
  "Nicht zugeordnet"
)

fkg_faktor_items = list(
  "Faktor 1: Katastrophisierende Bewertung" = c(
    "fkg_05", "fkg_06", "fkg_08", "fkg_09", "fkg_10", "fkg_11", "fkg_15", "fkg_16", "fkg_20", "fkg_24",
    "fkg_27", "fkg_28", "fkg_33", "fkg_35", "fkg_38", "fkg_39", "fkg_45", "fkg_47", "fkg_49", "fkg_55"
  ),
  "Faktor 2: Intoleranz von körperlichen Beschwerden" = c(
    "fkg_01", "fkg_02", "fkg_14", "fkg_30", "fkg_32", "fkg_41", "fkg_61"
  ),
  "Faktor 3: Körperliche Schwäche" = c(
    "fkg_03", "fkg_07", "fkg_18", "fkg_23", "fkg_31", "fkg_43", "fkg_48", "fkg_65", "fkg_67"
  ),
  "Faktor 4: Vegetative Missempfindungen" = c(
    "fkg_25", "fkg_42", "fkg_44", "fkg_59", "fkg_60", "fkg_63"
  ),
  "Faktor 5: Gesundheitsverhalten" = c(
    "fkg_21", "fkg_34", "fkg_51", "fkg_52"
  ),
  "Nicht zugeordnet" = c(
    "fkg_04", "fkg_12", "fkg_13", "fkg_17", "fkg_19", "fkg_22", "fkg_26", "fkg_29", "fkg_36", "fkg_37", "fkg_40",
    "fkg_46", "fkg_50", "fkg_53", "fkg_54", "fkg_56", "fkg_57", "fkg_58", "fkg_62", "fkg_64", "fkg_66", "fkg_68"
  )
)

fkg_mapping = bind_rows(lapply(names(fkg_faktor_items), function(fname) {
  data.frame(item = fkg_faktor_items[[fname]], faktor = fname, stringsAsFactors = FALSE)
}))
fkg_mapping$faktor = factor(fkg_mapping$faktor, levels = FKG_FAKTOR_REIHENFOLGE)


# 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; }
.faktor-zaehlung { color: #555; font-size: 0.9em; margin-bottom: 8px; }
.item-zeile {
  display: flex; align-items: flex-start; gap: 10px;
  padding: 7px 0; border-bottom: 1px solid #F0F0F0;
}
.item-zeile.ist-ja {
  background: #FFF3E0; border-left: 4px solid #8B2635; padding-left: 8px;
}
.item-zeile.gruppen-trenner { margin-top: 10px; border-top: 2px solid #ddd; padding-top: 10px; }
.item-nr   { font-weight: 600; color: #8B2635; min-width: 34px; flex-shrink: 0; }
.item-text { flex: 1; color: #333; font-size: 0.92em; }
.antwort   { font-weight: 700; min-width: 50px; text-align: right; flex-shrink: 0; font-size: 0.9em; color: #555; }
.item-zeile.ist-ja .antwort { color: #8B2635; }
.start-hinweis { text-align: center; color: #bbb; padding: 30px 0; 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("FKG – Fragebogen zu Körper und Gesundheit"),
    tags$p("Hiller, Rief, Fichter u. a. 1997 | Deskriptive Itemauswertung, kein Score")
  ),

  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("ergebnis_ui")
  )
)


# Word-Export ####

erstelle_fkg_docx = function(erg) {
  doc = read_docx()

  fp_titel      = fp_text(color = AKZENT_FARBE, bold = TRUE,  font.size = 18)
  fp_label      = fp_text(bold = TRUE,  font.size = 11)
  fp_normal     = fp_text(font.size = 11)
  fp_warnung    = fp_text(font.size = 9.5, italic = TRUE, color = "#8a6d00")
  fp_faktor     = fp_text(color = AKZENT_FARBE, bold = TRUE, font.size = 13)
  fp_zaehlung   = fp_text(font.size = 10, italic = TRUE, color = "#555555")
  fp_item_nr    = fp_text(bold = TRUE, font.size = 10, color = "#555555")
  fp_item_text  = fp_text(font.size = 10)
  fp_item_ja    = fp_text(font.size = 10, bold = TRUE, shading.color = "#FFE9CC")
  fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")

  doc = body_add_fpar(doc, fpar(ftext("FKG - Einzelauswertung", fp_titel)))
  doc = body_add_fpar(doc, fpar(
    ftext("Chiffre: ",       fp_label),
    ftext(erg$chiffre,       fp_normal),
    ftext("     Ausfülldatum: ", fp_label),
    ftext(erg$datum_str,     fp_normal)
  ))
  if (!is.null(erg$warnung_daten)) {
    doc = body_add_fpar(doc, fpar(ftext(erg$warnung_daten, fp_warnung)))
  }
  doc = body_add_par(doc, "", style = "Normal")

  for (g in erg$gruppen) {
    doc = body_add_fpar(doc, fpar(ftext(g$faktor, fp_faktor)))
    doc = body_add_fpar(doc, fpar(ftext(
      paste0(g$anzahl_ja, " von ", g$gesamt, " Aussagen zutreffend"), fp_zaehlung)))

    if (nrow(g$items) > 0) {
      for (i in seq_len(nrow(g$items))) {
        row          = g$items[i, ]
        item_text    = if (!is.na(row$item_text)) row$item_text else row$item
        antwort_text = if (!is.na(row$antwort)) row$antwort else "k. A."
        fp_zeile     = if (isTRUE(row$ist_ja)) fp_item_ja else fp_item_text

        doc = body_add_fpar(doc, fpar(
          ftext(paste0(sprintf("%02d", row$item_nr), ".  "), fp_item_nr),
          ftext(paste0(item_text, "  –  "), fp_zeile),
          ftext(antwort_text, fp_zeile)
        ))
      }
    }
    doc = body_add_par(doc, "", style = "Normal")
  }

  doc = body_add_fpar(doc, fpar(ftext(FKG_DISCLAIMER, fp_disclaimer)))

  doc
}


# Server ####

server = function(input, output, session) {

  observe({
    query = parseQueryString(session$clientData$url_search)
    if (!is.null(query$pseudonym) && nchar(trimws(query$pseudonym)) > 0) {
      updateTextInput(session, "pseudonym", value = trimws(query$pseudonym))
    }
  })

  observe({
    query = parseQueryString(session$clientData$url_search)
    if (!is.null(query$chiffre) && nchar(trimws(query$chiffre)) > 0) {
      updateTextInput(session, "chiffre", value = toupper(trimws(query$chiffre)))
    }
  })

  ergebnis_r = eventReactive(input$btn_suchen, {

    chiffre = toupper(trimws(input$chiffre))

    if (nchar(trimws(input$pseudonym)) == 0 && nchar(chiffre) == 0) {
      return(list(typ = "leere_eingabe", meldung = "Bitte Chiffre oder Pseudonym eingeben."))
    }
    if (nchar(trimws(input$pseudonym)) == 0 && !grepl("^[A-Z][0-9]{6}$", chiffre)) {
      return(list(typ = "format_fehler", chiffre = chiffre))
    }

    if (!file.exists(PFAD_DOWNLOAD_SKRIPT)) {
      return(list(typ = "skript_fehler",
        meldung = paste0("Download-Skript nicht gefunden: ", PFAD_DOWNLOAD_SKRIPT)))
    }
    if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) {
      return(list(typ = "skript_fehler",
        meldung = paste0("Pseudonym-Skript nicht gefunden: ", PFAD_PSEUDONYM_SKRIPT)))
    }

    ok = tryCatch({
      source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
      list(ok = TRUE)
    }, error = function(e) list(ok = FALSE, msg = e$message))
    if (!ok$ok) return(list(typ = "skript_fehler", meldung = ok$msg))

    db_ordner = local({
      ordner   = dirname(normalizePath(PFAD_PSEUDONYM_SKRIPT, mustWork = FALSE))
      gefunden = NULL
      for (i in 1:5) {
        if (file.exists(file.path(ordner, "pseudonyme.db"))) {
          gefunden = ordner
          break
        }
        elternteil = dirname(ordner)
        if (elternteil == ordner) break
        ordner = elternteil
      }
      gefunden
    })
    if (is.null(db_ordner)) {
      return(list(typ = "skript_fehler",
        meldung = "pseudonyme.db wurde ausgehend vom Pseudonym-Skript-Ordner bis zu 5 Ebenen nach oben nicht gefunden."))
    }

    alter_wd = getwd()
    on.exit(setwd(alter_wd), add = TRUE)
    setwd(db_ordner)

    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_fkg", envir = .GlobalEnv)) {
      return(list(typ = "skript_fehler",
        meldung = "Objekt 'daten_fkg' wurde nach dem Sourcen des Download-Skripts nicht gefunden."))
    }
    if (!exists("pseudo", envir = .GlobalEnv)) {
      return(list(typ = "skript_fehler",
        meldung = "Objekt 'pseudo' wurde nach dem Sourcen des Pseudonym-Skripts nicht gefunden."))
    }

    daten_fkg = get("daten_fkg", 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 = "chiffre_nicht_gefunden", chiffre = chiffre))
    }

    alle_session_ids = unique(treffer_ps$pseudonym)
    if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym)

    treffer_dat = daten_fkg[daten_fkg$session %in% alle_session_ids, ]
    if (nrow(treffer_dat) == 0) {
      return(list(typ = "session_nicht_gefunden", chiffre = chiffre))
    }

    warnung_daten = NULL
    if (nrow(treffer_dat) > 1) {
      n           = nrow(treffer_dat)
      treffer_dat = treffer_dat[order(treffer_dat$created, decreasing = TRUE), ]
      datum_neu   = tryCatch(
        format(as.POSIXct(treffer_dat$created[1]), "%d.%m.%Y %H:%M"),
        error = function(e) "unbekanntes Datum"
      )
      warnung_daten = paste0(
        "Mehrere Ausfüllungen gefunden (", n, " Einträge). ",
        "Angezeigt wird die neueste vom ", datum_neu, "."
      )
      treffer_dat = treffer_dat[1, , drop = FALSE]
    }

    zeile     = treffer_dat[1, , drop = FALSE]
    datum_str = tryCatch(
      format(as.POSIXct(zeile[["created"]][1]), "%d.%m.%Y"),
      error = function(e) format(Sys.Date(), "%d.%m.%Y")
    )

    tab     = fkg_erstelle_item_tabelle(zeile, daten_fkg)
    gruppen = fkg_gruppiere(tab)

    list(
      typ           = "ergebnis",
      chiffre       = chiffre,
      datum_str     = datum_str,
      warnung_daten = warnung_daten,
      tab           = tab,
      gruppen       = gruppen
    )
  })

  output$ergebnis_ui = renderUI({

    if (input$btn_suchen == 0) {
      return(div(class = "abschnitt-karte start-hinweis",
        "Bitte Chiffre oder Pseudonym eingeben und auf „Auswerten“ klicken."
      ))
    }

    erg = ergebnis_r()

    if (erg$typ == "leere_eingabe") {
      return(div(class = "alert-warnung", erg$meldung))
    }
    if (erg$typ == "format_fehler") {
      return(div(class = "alert-warnung",
        paste0("Ungültige Chiffre „", erg$chiffre, "“. Erwartet: ein Großbuchstabe gefolgt von 6 Ziffern (z. B. P000123).")))
    }
    if (erg$typ == "skript_fehler") {
      return(div(class = "alert-fehler", tags$pre(style = "white-space:pre-wrap; margin:0;", erg$meldung)))
    }
    if (erg$typ == "chiffre_nicht_gefunden") {
      return(div(class = "alert-fehler",
        paste0("Chiffre „", erg$chiffre, "“ wurde in der Pseudonym-Datenbank nicht gefunden.")))
    }
    if (erg$typ == "session_nicht_gefunden") {
      return(div(class = "alert-fehler",
        paste0("Kein FKG-Datensatz für Chiffre „", erg$chiffre, "“ gefunden.")))
    }

    meta_block = div(class = "meta-block",
      tags$strong("Chiffre: "), erg$chiffre, "   ",
      tags$strong("Ausfülldatum: "), erg$datum_str
    )

    kopf_karte = div(class = "abschnitt-karte",
      meta_block,
      if (!is.null(erg$warnung_daten)) div(class = "alert-warnung", erg$warnung_daten) else NULL
    )

    faktor_karten = lapply(erg$gruppen, function(g) {

      items_ui = lapply(seq_len(nrow(g$items)), function(i) {
        row       = g$items[i, ]
        uebergang = i > 1 && isTRUE(g$items$ist_ja[i - 1]) && !isTRUE(row$ist_ja)
        klasse    = paste0(
          "item-zeile",
          if (isTRUE(row$ist_ja)) " ist-ja" else "",
          if (uebergang) " gruppen-trenner" else ""
        )
        div(class = klasse,
          div(class = "item-nr",   paste0(sprintf("%02d", row$item_nr), ".")),
          div(class = "item-text", if (!is.na(row$item_text)) row$item_text else row$item),
          span(class = "antwort",  if (!is.na(row$antwort)) row$antwort else "k. A.")
        )
      })

      div(class = "abschnitt-karte",
        div(class = "abschnitt-titel", g$faktor),
        div(class = "faktor-zaehlung",
            paste0(g$anzahl_ja, " von ", g$gesamt, " Aussagen zutreffend")),
        div(items_ui)
      )
    })

    tagList(kopf_karte, faktor_karten)
  })

  output$download_word = downloadHandler(
    filename = function() {
      erg = tryCatch(ergebnis_r(), error = function(e) NULL)
      if (is.null(erg) || erg$typ != "ergebnis") return("FKG_Export.docx")
      chiffre_esc      = gsub("[^A-Za-z0-9_-]", "_", erg$chiffre)
      ausfuelldatum_fn = tryCatch(
        format(as.Date(erg$datum_str, "%d.%m.%Y"), "%Y%m%d"),
        error = function(e) format(Sys.Date(), "%Y%m%d")
      )
      paste0("FKG_", chiffre_esc, "_", ausfuelldatum_fn, ".docx")
    },
    content = function(file) {
      erg = tryCatch(ergebnis_r(), error = function(e) NULL)
      if (is.null(erg) || erg$typ != "ergebnis") {
        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_fkg_docx(erg),
        error = function(e) {
          err_doc = read_docx()
          body_add_par(err_doc,
            paste0("Fehler beim Erstellen des Word-Dokuments: ", e$message),
            style = "Normal")
        }
      )
      print(doc, target = file)
    }
  )
}


# Start ####

shinyApp(ui, server)