# Praeambel #### PFAD_DOWNLOAD_SKRIPT = "../API/get_data_psqi.R" PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" AKZENT_FARBE = "#8B2635" PSQI_DISCLAIMER = paste0( "Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ", "keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ", "Fuer den PSQI existiert keine eigentliche Normierung; der hier verwendete ", "Cutoff-Wert stammt aus Buysse et al. (1989) und ist ein empirischer Schwellenwert, ", "kein diagnostisches Kriterium." ) PSQI_VERGLEICHSWERT_TEXT = paste0( "Vergleichswert einer deutschen Stichprobe (4-Wochen-Version, Zeitlhofer et al. ", "2000, N=1049): M=4.55, SD=0.76. Nicht direkt auf die hier verwendete ", "2-Wochen-Version uebertragbar." ) # Kurzbezeichnungen der 7 PSQI-Komponenten in fixer Reihenfolge. PSQI_KOMPONENTEN_LABELS = c( "Subjektive Schlafqualitaet", "Schlaflatenz", "Schlafdauer", "Schlafeffizienz", "Schlafstoerungen", "Schlafmittelkonsum", "Tagesschlaefrigkeit" ) # Kriterien fuer die Vergabe der 0-3 Punkte je Komponente, zur Anzeige neben # dem jeweiligen Punktwert (statischer Erklaerungstext, unabhaengig vom # konkreten Datensatz). PSQI_KOMPONENTEN_KRITERIEN = c( "Direkt aus Frage 6 (subjektive Schlafqualitaet): sehr gut = 0, ziemlich gut = 1, ziemlich schlecht = 2, sehr schlecht = 3.", "Summe aus Einschlaflatenz in Minuten (Frage 2: <=15 Min. = 0, 16-30 = 1, 31-60 = 2, >60 = 3) und Frage 5a (Stufe 0-3); Summe 0 = 0, 1-2 = 1, 3-4 = 2, 5-6 = 3.", "Aus der effektiven Schlafzeit (Frage 4): >=7 Std. = 0, 6-<7 Std. = 1, 5-<6 Std. = 2, <5 Std. = 3.", "Aus der Schlafeffizienz (effektive Schlafzeit / Bettliegezeit x 100): >=85% = 0, 75-84% = 1, 65-74% = 2, <65% = 3.", "Summe der Schlafstoerungsitems 5b-5j (je 0-3, Range 0-27): 0 = 0, 1-9 = 1, 10-18 = 2, 19-27 = 3.", "Direkt aus Frage 7 (Schlafmittelkonsum): nie = 0, seltener als 1x/Woche = 1, 1-2x/Woche = 2, >=3x/Woche = 3.", "Summe aus Frage 8 (Muehe wachzubleiben) und Frage 9 (Schwung/Elan); Summe 0 = 0, 1-2 = 1, 3-4 = 2, 5-6 = 3." ) 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 #### # Entfernt Markdown-Sternchen und umgebende Leerzeichen aus Fragetexten, # die aus dem label-Attribut der formr-Spalten stammen. bereinige_text = function(x) { if (is.null(x) || length(x) == 0 || is.na(x[1])) return(NA_character_) x = trimws(as.character(x[1])) x = gsub("\\*\\*", "", x) trimws(x) } # Entfernt ein fuehrendes Buchstaben-Praefix wie "a) " oder "j) " aus dem # label-Attribut, da die Buchstabennummerierung bereits separat als # item-nr (z.B. "5a.") angezeigt wird - sonst erscheint der Buchstabe doppelt. psqi_item_text = function(original_col, fallback) { txt = bereinige_text(attr(original_col, "label")) if (is.na(txt) || nchar(txt) == 0) return(fallback) sub("^[a-jA-J]\\)\\s*", "", txt) } # Loest den Rohwert ueber das labels-Attribut der ORIGINAL-Spalte zum # Antworttext auf (fuer Anzeige), nie hartkodiert. psqi_hole_label_text = function(original_col, wert) { if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_character_) labels_attr = attr(original_col, "labels") if (is.null(labels_attr) || length(labels_attr) == 0) return(NA_character_) pos = which(as.vector(labels_attr) == as.numeric(wert[1])) if (length(pos) == 0) return(NA_character_) bereinige_text(names(labels_attr)[pos[1]]) } # Recoding der 4-stufigen mc-Felder: Rohwert = Choice-Index - 1 (Range 0-3). # Diese Formel ist fuer das vorliegende formr-Setup verifiziert. Wo ein # labels-Attribut vorliegt, wird zusaetzlich geprueft, dass tatsaechlich eine # 4-stufige Skala vorliegt, bevor blind gerechnet wird - kein hartkodierter # Index ohne jede Absicherung. psqi_recode = function(wert, original_col = NULL, feldname = "Item") { if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_real_) wert_num = as.numeric(wert[1]) if (!is.null(original_col)) { labels_attr = attr(original_col, "labels") if (!is.null(labels_attr) && length(labels_attr) > 0 && length(labels_attr) != 4) { stop(paste0(feldname, ": erwartete 4-stufige Antwortskala, aber labels-Attribut ", "hat ", length(labels_attr), " Stufe(n).")) } } if (!(wert_num %in% 1:4)) { stop(paste0(feldname, ": Rohwert ", wert_num, " liegt ausserhalb des erwarteten Bereichs 1-4.")) } wert_num - 1 } # Parst "HH:MM" oder "HH:MM:SS" (Sekunden werden ignoriert) zu Minuten seit # Mitternacht, mit klarer Fehlermeldung bei fehlendem/unplausiblem Wert # statt stillschweigendem NA. psqi_zeit_zu_minuten = function(zeit_str, feldname = "Uhrzeit") { zeit_str = trimws(as.character(zeit_str[1])) if (is.na(zeit_str) || zeit_str == "" || zeit_str == "NA") { stop(paste0(feldname, " fehlt oder ist leer.")) } teile = strsplit(zeit_str, ":", fixed = TRUE)[[1]] if (!(length(teile) %in% c(2, 3))) { stop(paste0(feldname, " ('", zeit_str, "') hat kein gueltiges HH:MM- oder HH:MM:SS-Format.")) } stunde = suppressWarnings(as.numeric(teile[1])) minute = suppressWarnings(as.numeric(teile[2])) if (is.na(stunde) || is.na(minute) || stunde < 0 || stunde > 23 || minute < 0 || minute > 59) { stop(paste0(feldname, " ('", zeit_str, "') ist nicht plausibel (HH 0-23, MM 0-59 erwartet).")) } stunde * 60 + minute } # Bettliegezeit in Stunden, modular ueber Mitternacht: wenn die Aufstehzeit # vor der Zubettgehzeit liegt, wird von einem Tagesuebergang ausgegangen. psqi_bettliegezeit_stunden = function(zubettgehzeit_str, aufstehzeit_str) { min_zubett = psqi_zeit_zu_minuten(zubettgehzeit_str, "Uebliche Zubettgehzeit (psqi_01)") min_aufsteh = psqi_zeit_zu_minuten(aufstehzeit_str, "Uebliche Aufstehzeit (psqi_03)") if (min_aufsteh < min_zubett) min_aufsteh = min_aufsteh + 24 * 60 (min_aufsteh - min_zubett) / 60 } # Parst Minuten-/Stundenangaben mit Komma ODER Punkt als Dezimaltrenner. psqi_dezimal_parse = function(x, feldname = "Wert") { x_str = trimws(as.character(x[1])) if (is.na(x_str) || x_str == "" || x_str == "NA") { stop(paste0(feldname, " fehlt oder ist leer.")) } x_str = gsub(",", ".", x_str, fixed = TRUE) wert = suppressWarnings(as.numeric(x_str)) if (is.na(wert)) { stop(paste0(feldname, " ('", x[1], "') ist nicht als Zahl interpretierbar.")) } wert } psqi_schlafeffizienz = function(schlafzeit_stunden, bettliegezeit_stunden) { if (is.na(bettliegezeit_stunden) || bettliegezeit_stunden <= 0 || bettliegezeit_stunden > 24) { stop(paste0("Berechnete Bettliegezeit (", round(bettliegezeit_stunden, 2), " h) ist unplausibel (erwartet: > 0 und <= 24 Stunden). ", "Bitte Zubettgeh- und Aufstehzeit pruefen.")) } (schlafzeit_stunden / bettliegezeit_stunden) * 100 } # Komponente 2 (Wert A) - aus psqi_02 (Minuten Einschlaflatenz). psqi_latenz_wert_a = function(minuten) { if (is.na(minuten)) stop("Einschlaflatenz (psqi_02) fehlt fuer Komponente 2.") if (minuten <= 15) 0L else if (minuten <= 30) 1L else if (minuten <= 60) 2L else 3L } # Gemeinsame Summen-zu-Stufe-Zuordnung fuer Komponente 2 (Latenz) und # Komponente 7 (Tagesschlaefrigkeit): beide summieren zwei 0-3-Werte (Range 0-6). psqi_summe_zu_stufe_klein = function(summe) { if (is.na(summe)) stop("Summe fuer Stufenzuordnung fehlt.") if (summe == 0) 0L else if (summe <= 2) 1L else if (summe <= 4) 2L else 3L } # Komponente 3 (Schlafdauer) aus psqi_04 (Stunden). psqi_komponente_dauer = function(stunden) { if (is.na(stunden)) stop("Effektive Schlafzeit (psqi_04) fehlt fuer Komponente 3.") if (stunden >= 7) 0L else if (stunden >= 6) 1L else if (stunden >= 5) 2L else 3L } # Komponente 4 (Schlafeffizienz) aus Prozentwert. psqi_komponente_effizienz = function(prozent) { if (is.na(prozent)) stop("Schlafeffizienz fehlt fuer Komponente 4.") if (prozent >= 85) 0L else if (prozent >= 75) 1L else if (prozent >= 65) 2L else 3L } # Komponente 5 (Schlafstoerungen), Summe ueber 9 Items (b-j), Range 0-27. psqi_komponente_stoerungen = function(summe) { if (is.na(summe)) stop("Summe der Schlafstoerungsitems fehlt fuer Komponente 5.") if (summe == 0) 0L else if (summe <= 9) 1L else if (summe <= 18) 2L else 3L } psqi_klassifikation = function(gesamtwert) { if (is.na(gesamtwert)) stop("Gesamtwert fehlt fuer Klassifikation.") if (gesamtwert > 5) "schlechter Schlaefer" else "guter Schlaefer" } psqi_klassifikation_farbe = function(klassifikation) { if (identical(klassifikation, "schlechter Schlaefer")) "#B71C1C" else "#2E7D32" } # Baut die Anzeige-/Auswertungsliste fuer die 10 Schlafstoerungsitems # (psqi_05a bis psqi_05j) inkl. Rohwert, Stufe und Fragetext. psqi_build_stoerungsitems = function(daten, zeile) { buchstaben = c(letters[1:9], "j") lapply(buchstaben, function(b) { var = paste0("psqi_05", b) original_col = daten[[var]] wert = zeile[[var]] fehlt = is.null(wert) || length(wert) == 0 || is.na(wert[1]) stufe = if (fehlt) NA_real_ else psqi_recode(wert, original_col, var) list( var = var, buchst = b, text = psqi_item_text(original_col, paste0("Item ", b)), stufe = stufe, label = if (fehlt) NA_character_ else psqi_hole_label_text(original_col, wert) ) }) } # Baut die Anzeige-/Auswertungsliste fuer die Fremdbeurteilungsitems # psqi_10a-psqi_10d. Liefert zusaetzlich das Flag, ob der Partnerabschnitt # ueberhaupt ausgefuellt wurde (alle vier NA => nicht ausgefuellt). psqi_build_partneritems = function(daten, zeile) { buchstaben = letters[1:4] items = lapply(buchstaben, function(b) { var = paste0("psqi_10", b) original_col = daten[[var]] wert = zeile[[var]] fehlt = is.null(wert) || length(wert) == 0 || is.na(wert[1]) stufe = if (fehlt) NA_real_ else tryCatch( psqi_recode(wert, original_col, var), error = function(e) NA_real_ ) list( var = var, buchst = b, text = psqi_item_text(original_col, paste0("Item 10", b)), stufe = stufe, label = if (fehlt) NA_character_ else psqi_hole_label_text(original_col, wert) ) }) ausgefuellt = any(sapply(items, function(x) !is.na(x$stufe))) list(items = items, ausgefuellt = ausgefuellt) } # Fuehrt die vollstaendige PSQI-Berechnung fuer einen einzelnen Datensatz # (eine Zeile aus daten_psqi) durch. Wirft bei nicht auswertbaren Eingaben # einen R-Fehler mit klarer Meldung (kein stilles NA/NaN). psqi_berechne_score = function(daten, zeile) { bettliegezeit_stunden = psqi_bettliegezeit_stunden(zeile[["psqi_01"]][1], zeile[["psqi_03"]][1]) schlafzeit_stunden = psqi_dezimal_parse(zeile[["psqi_04"]][1], "Effektive Schlafzeit (psqi_04)") latenz_minuten = psqi_dezimal_parse(zeile[["psqi_02"]][1], "Einschlaflatenz (psqi_02)") effizienz_prozent = psqi_schlafeffizienz(schlafzeit_stunden, bettliegezeit_stunden) komponente1 = psqi_recode(zeile[["psqi_06"]], daten[["psqi_06"]], "psqi_06") wert_b_latenz = psqi_recode(zeile[["psqi_05a"]], daten[["psqi_05a"]], "psqi_05a") wert_a_latenz = psqi_latenz_wert_a(latenz_minuten) komponente2 = psqi_summe_zu_stufe_klein(wert_a_latenz + wert_b_latenz) komponente3 = psqi_komponente_dauer(schlafzeit_stunden) komponente4 = psqi_komponente_effizienz(effizienz_prozent) stoerungsitems = psqi_build_stoerungsitems(daten, zeile) # Komponente 5 nutzt b bis j (9 Items), OHNE a (bereits in Komponente 2). stoerungswerte_b_bis_j = sapply(stoerungsitems[2:10], function(x) x$stufe) # psqi_05j = NA (kein Zusatzgrund) liefert Rohwert 0 zur Summe, wird nicht # ausgeschlossen; alle anderen NA in b-i waeren ein echter Datenfehler. wert_j = stoerungswerte_b_bis_j[9] if (is.na(wert_j)) stoerungswerte_b_bis_j[9] = 0 if (any(is.na(stoerungswerte_b_bis_j[1:8]))) { stop("Mindestens eines der Schlafstoerungsitems psqi_05b-psqi_05i fehlt oder ist nicht auswertbar.") } summe_stoerungen = sum(stoerungswerte_b_bis_j) komponente5 = psqi_komponente_stoerungen(summe_stoerungen) komponente6 = psqi_recode(zeile[["psqi_07"]], daten[["psqi_07"]], "psqi_07") wert_a_schlaefrig = psqi_recode(zeile[["psqi_08"]], daten[["psqi_08"]], "psqi_08") wert_b_schlaefrig = psqi_recode(zeile[["psqi_09"]], daten[["psqi_09"]], "psqi_09") komponente7 = psqi_summe_zu_stufe_klein(wert_a_schlaefrig + wert_b_schlaefrig) komponenten = c(komponente1, komponente2, komponente3, komponente4, komponente5, komponente6, komponente7) gesamtwert = sum(komponenten) klassifikation = psqi_klassifikation(gesamtwert) # Konkrete Eingaben je Komponente, zur Anzeige neben dem Punktwert und dem # Kriterium (PSQI_KOMPONENTEN_KRITERIEN), damit die Punktvergabe fuer die # anzeigende Person nachvollziehbar ist. label_06 = psqi_hole_label_text(daten[["psqi_06"]], zeile[["psqi_06"]]) label_05a = psqi_hole_label_text(daten[["psqi_05a"]], zeile[["psqi_05a"]]) label_07 = psqi_hole_label_text(daten[["psqi_07"]], zeile[["psqi_07"]]) label_08 = psqi_hole_label_text(daten[["psqi_08"]], zeile[["psqi_08"]]) label_09 = psqi_hole_label_text(daten[["psqi_09"]], zeile[["psqi_09"]]) komponenten_eingaben = c( paste0("Frage 6: \"", ifelse(is.na(label_06), "k. A.", label_06), "\""), paste0("Einschlaflatenz: ", latenz_minuten, " Min. (Wert A = ", wert_a_latenz, ") + Frage 5a: \"", ifelse(is.na(label_05a), "k. A.", label_05a), "\" (Wert B = ", wert_b_latenz, ") -> Summe = ", wert_a_latenz + wert_b_latenz), paste0("Effektive Schlafzeit: ", round(schlafzeit_stunden, 2), " Std."), paste0("Bettliegezeit: ", round(bettliegezeit_stunden, 2), " Std., Schlafzeit: ", round(schlafzeit_stunden, 2), " Std. -> Effizienz: ", round(effizienz_prozent, 1), "%"), paste0("Summe Items 5b-5j: ", summe_stoerungen, " (von 27)"), paste0("Frage 7: \"", ifelse(is.na(label_07), "k. A.", label_07), "\""), paste0("Frage 8: \"", ifelse(is.na(label_08), "k. A.", label_08), "\" (A = ", wert_a_schlaefrig, ") + Frage 9: \"", ifelse(is.na(label_09), "k. A.", label_09), "\" (B = ", wert_b_schlaefrig, ") -> Summe = ", wert_a_schlaefrig + wert_b_schlaefrig) ) # Frage 10 (Schlafarrangement) - rein deskriptiv, nicht Teil des Scores. frage10_text = psqi_hole_label_text(daten[["psqi_10"]], zeile[["psqi_10"]]) partner = psqi_build_partneritems(daten, zeile) freitext_05j = trimws(as.character(zeile[["psqi_05j_text"]][1])) if (is.na(freitext_05j) || freitext_05j == "NA") freitext_05j = "" freitext_10e = trimws(as.character(zeile[["psqi_10e_text"]][1])) if (is.na(freitext_10e) || freitext_10e == "NA") freitext_10e = "" list( komponenten = komponenten, komponenten_eingaben = komponenten_eingaben, gesamtwert = gesamtwert, klassifikation = klassifikation, bettliegezeit_stunden = bettliegezeit_stunden, schlafzeit_stunden = schlafzeit_stunden, effizienz_prozent = effizienz_prozent, stoerungsitems = stoerungsitems, frage10_text = frage10_text, partner_items = partner$items, partner_ausgefuellt = partner$ausgefuellt, freitext_05j = freitext_05j, freitext_10e = freitext_10e ) } make_gauge_psqi = function(score) { ggplot() + geom_rect(aes(xmin = 0, xmax = 5, ymin = 0, ymax = 1), fill = "#E8F5E9", color = NA) + geom_rect(aes(xmin = 5, xmax = 21, ymin = 0, ymax = 1), fill = "#FFEBEE", color = NA) + geom_rect(aes(xmin = 0, xmax = 21, ymin = 0, ymax = 1), fill = NA, color = "#9E9E9E", linewidth = 0.6) + geom_vline(xintercept = 5, color = "#E65100", linetype = "dashed", linewidth = 1) + geom_segment(aes(x = score, xend = score, y = -0.25, yend = 1.25), color = AKZENT_FARBE, linewidth = 2.5) + geom_label(aes(x = score, y = 1.6, label = paste0("Score: ", score)), fill = AKZENT_FARBE, color = "white", fontface = "bold", linewidth = 0, size = 4) + annotate("text", x = 5, y = -0.55, label = "Cutoff: 5", color = "#E65100", size = 3.2, hjust = 0.5) + annotate("text", x = 2.5, y = 0.5, label = "<= 5", color = "#2E7D32", size = 3.5, fontface = "italic") + annotate("text", x = 13, y = 0.5, label = "> 5", color = "#B71C1C", size = 3.5, fontface = "italic") + scale_x_continuous(limits = c(-1, 22), breaks = c(0, 5, 10, 15, 21)) + scale_y_continuous(limits = c(-0.8, 2.0)) + theme_minimal(base_size = 12) + theme( axis.text.y = element_blank(), axis.ticks.y = element_blank(), panel.grid.major.y = element_blank(), panel.grid.minor = element_blank(), axis.title.y = element_blank(), plot.margin = margin(t = 5, r = 10, b = 5, l = 10) ) + labs(x = "PSQI Gesamtwert (0-21)", y = NULL) } # 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; } .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-unbeantwortet { color: #888; font-style: italic; font-size: 0.85em; flex-shrink: 0; } .score-zahl { font-size: 2.6rem; font-weight: 800; } .score-klassifikation { font-size: 1.05rem; font-weight: 700; margin-top: 2px; } .komponente-zeile { display: flex; flex-direction: column; gap: 4px; padding: 10px 0; border-bottom: 1px solid #F0F0F0; } .komponente-zeile:last-child { border-bottom: none; } .komponente-kopf { display: flex; align-items: center; gap: 10px; } .komponente-name { font-weight: 600; color: #333; flex: 1; font-size: 0.95em; } .komponente-kriterium { font-size: 0.83em; color: #777; } .komponente-eingabe { font-size: 0.85em; color: #444; } .hinweis-info { background: #F5F5F5; border-left: 5px solid #9E9E9E; padding: 10px 16px; border-radius: 4px; color: #555; margin-bottom: 12px; font-size: 0.9em; } .freitext-box { background: #FAFAFA; border-radius: 4px; padding: 8px 12px; margin-top: 6px; font-size: 0.88em; color: #444; font-style: italic; } .disclaimer-text { font-size: 0.82em; color: #777; font-style: italic; margin-top: 14px; border-top: 1px solid rgba(0,0,0,.1); padding-top: 8px; } " 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("PSQI - Pittsburgh Schlafqualitaetsindex (2-Wochen-Version)"), tags$p("Buysse et al. 1989 | Selbstauskunft ueber die letzten zwei Wochen") ), 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_psqi_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") fp_kontext = fp_text(font.size = 9, italic = TRUE, color = "#777777") klass_farbe = psqi_klassifikation_farbe(erg$klassifikation) fp_score = fp_text(bold = TRUE, font.size = 14, color = klass_farbe) doc = body_add_fpar(doc, fpar(ftext("PSQI - Einzelauswertung", 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_fpar(doc, fpar( ftext("Alter: ", fp_label), ftext(erg$alter_text, fp_normal), ftext(" Geschlecht: ", fp_label), ftext(erg$geschlecht_text, fp_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("Gesamtwert", fp_abschnitt))) doc = body_add_fpar(doc, fpar( ftext(paste0(erg$score$gesamtwert, " / 21 - ", erg$score$klassifikation), fp_score) )) doc = body_add_par(doc, "", style = "Normal") doc = body_add_fpar(doc, fpar(ftext("Komponenten", fp_abschnitt))) fp_kriterium = fp_text(italic = TRUE, font.size = 9, color = "#777777") fp_eingabe = fp_text(font.size = 9, color = "#444444") for (i in seq_along(PSQI_KOMPONENTEN_LABELS)) { doc = body_add_fpar(doc, fpar( ftext(paste0(PSQI_KOMPONENTEN_LABELS[i], ": "), fp_label), ftext(paste0(erg$score$komponenten[i], " / 3"), fp_normal) )) doc = body_add_fpar(doc, fpar(ftext(PSQI_KOMPONENTEN_KRITERIEN[i], fp_kriterium))) doc = body_add_fpar(doc, fpar(ftext(paste0("Eingabe: ", erg$score$komponenten_eingaben[i]), fp_eingabe))) } doc = body_add_par(doc, "", style = "Normal") doc = body_add_fpar(doc, fpar(ftext("Frage 10: Schlafarrangement / Fremdbeurteilung", fp_abschnitt))) doc = body_add_fpar(doc, fpar( ftext("Hinweis: ", fp_label), ftext("Diese Angaben fliessen nicht in den PSQI-Gesamtwert ein.", fp_kontext) )) doc = body_add_fpar(doc, fpar( ftext("Schlafarrangement: ", fp_label), ftext(if (is.na(erg$score$frage10_text)) "k. A." else erg$score$frage10_text, fp_normal) )) if (erg$score$partner_ausgefuellt) { for (item in erg$score$partner_items) { wert_txt = if (!is.na(item$label)) item$label else "k. A." doc = body_add_fpar(doc, fpar( ftext(paste0(item$text, ": "), fp_label), ftext(wert_txt, fp_normal) )) } } else { doc = body_add_fpar(doc, fpar( ftext("Partnerabschnitt nicht ausgefuellt (kein Partner/Mitbewohner angegeben).", fp_text(italic = TRUE, font.size = 10, color = "#777777")) )) } if (nchar(erg$score$freitext_10e) > 0) { doc = body_add_fpar(doc, fpar( ftext("Freitext (andere Unruhe): ", fp_label), ftext(erg$score$freitext_10e, fp_text(italic = TRUE, font.size = 10)) )) } doc = body_add_par(doc, "", style = "Normal") if (nchar(erg$score$freitext_05j) > 0) { doc = body_add_fpar(doc, fpar(ftext("Freitext (andere Gruende fuer Schlafstoerung)", fp_abschnitt))) doc = body_add_fpar(doc, fpar(ftext(erg$score$freitext_05j, fp_text(italic = TRUE, font.size = 10)))) doc = body_add_par(doc, "", style = "Normal") } doc = body_add_fpar(doc, fpar(ftext("Vergleichswert (Kontext, keine Normwerte)", fp_abschnitt))) doc = body_add_fpar(doc, fpar(ftext(PSQI_VERGLEICHSWERT_TEXT, fp_kontext))) doc = body_add_par(doc, "", style = "Normal") doc = body_add_fpar(doc, fpar(ftext(PSQI_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:\n", PFAD_DOWNLOAD_SKRIPT))) } if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) { return(list(typ = "pfad_fehler", meldung = paste0("Pseudonym-Skript nicht gefunden:\n", 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 }) 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 = tryCatch({ source(PFAD_PSEUDONYM_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)) if (!exists("daten_psqi", envir = .GlobalEnv)) { return(list(typ = "daten_fehlen", meldung = "Objekt 'daten_psqi' nach dem Sourcen nicht gefunden. Bitte Download-Skript pruefen.")) } if (!exists("pseudo", envir = .GlobalEnv)) { return(list(typ = "daten_fehlen", meldung = "Objekt 'pseudo' nach dem Sourcen nicht gefunden. Bitte Pseudonym-Skript pruefen.")) } daten_psqi = get("daten_psqi", envir = .GlobalEnv) pseudo = get("pseudo", envir = .GlobalEnv) # Manche Download-Skript-Varianten liefern daten_psqi als Liste mit dem # eigentlichen Dataframe darin (z.B. list(psqi = )) statt direkt # als Dataframe. Hier robust entpacken statt mit Dimensionsfehler # abzubrechen; bei unerwarteter Struktur klare Fehlermeldung. if (!is.data.frame(daten_psqi)) { if (is.list(daten_psqi) && length(daten_psqi) == 1 && is.data.frame(daten_psqi[[1]])) { daten_psqi = daten_psqi[[1]] } else { return(list(typ = "daten_fehlen", meldung = paste0( "Objekt 'daten_psqi' nach dem Sourcen ist kein Dataframe (Klasse: ", paste(class(daten_psqi), collapse = ", "), "). Bitte Download-Skript pruefen."))) } } alle_session_ids = character(0) if (nchar(chiffre) > 0) { treffer_ps = pseudo[pseudo$chiffre == chiffre, ] alle_session_ids = unique(treffer_ps$pseudonym) } if (nchar(trimws(input$pseudonym)) > 0) { alle_session_ids = trimws(input$pseudonym) if (nchar(chiffre) == 0) { pw_treffer = pseudo[pseudo$pseudonym == trimws(input$pseudonym), ] if (nrow(pw_treffer) > 0) chiffre = toupper(trimws(pw_treffer$chiffre[1])) } } if (length(alle_session_ids) == 0 || all(is.na(alle_session_ids)) || all(trimws(as.character(alle_session_ids)) == "")) { return(list(typ = "kein_treffer", meldung = "Chiffre/Pseudonym nicht gefunden.")) } treffer_dat = daten_psqi[daten_psqi$session %in% alle_session_ids, ] if (nrow(treffer_dat) == 0) { return(list(typ = "kein_treffer", meldung = paste0("Kein PSQI-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$created, decreasing = TRUE), ] datum_neu = tryCatch( format(as.POSIXct(treffer_dat$created[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] ausfuelldatum = tryCatch( format(as.POSIXct(zeile[["created"]][1]), "%d.%m.%Y"), error = function(e) format(Sys.Date(), "%d.%m.%Y") ) alter_wert = suppressWarnings(as.numeric(zeile[["psqi_alter"]][1])) alter_text = if (is.na(alter_wert)) "k. A." else as.character(alter_wert) geschlecht_text = psqi_hole_label_text(daten_psqi[["psqi_geschlecht"]], zeile[["psqi_geschlecht"]]) if (is.na(geschlecht_text)) { geschlecht_roh = suppressWarnings(as.numeric(zeile[["psqi_geschlecht"]][1])) geschlecht_text = if (is.na(geschlecht_roh)) "k. A." else c("1" = "weiblich", "2" = "maennlich")[as.character(round(geschlecht_roh))] if (is.na(geschlecht_text)) geschlecht_text = "k. A." } score_res = tryCatch( list(ok = TRUE, wert = psqi_berechne_score(daten_psqi, zeile)), error = function(e) list(ok = FALSE, msg = e$message) ) if (!score_res$ok) { return(list(typ = "berechnung_fehler", meldung = score_res$msg)) } list( typ = "erfolg", chiffre = chiffre, ausfuelldatum = ausfuelldatum, alter_text = alter_text, geschlecht_text = geschlecht_text, info_mehrere = info_mehrere, score = score_res$wert ) }) output$fehler_ui = renderUI({ req(input$btn_suchen) erg = ergebnis_r() if (erg$typ == "leere_eingabe") { div(class = "alert-fehler", erg$meldung) } else if (erg$typ == "format_fehler") { div(class = "alert-fehler", paste0("Ungueltige Chiffre '", erg$chiffre, "'. Erwartet: ein Grossbuchstabe + 6 Ziffern (z.B. P000123).")) } else if (erg$typ == "pfad_fehler") { div(class = "alert-fehler", erg$meldung) } else if (erg$typ == "skript_fehler") { div(class = "alert-fehler", paste0("Fehler beim Ausfuehren eines Skripts: ", erg$meldung)) } else if (erg$typ == "daten_fehlen") { div(class = "alert-fehler", erg$meldung) } else if (erg$typ == "kein_treffer") { div(class = "alert-fehler", erg$meldung) } else if (erg$typ == "berechnung_fehler") { div(class = "alert-fehler", paste0("Fehler bei der PSQI-Berechnung: ", erg$meldung)) } }) output$warnung_ui = renderUI({ req(input$btn_suchen) erg = ergebnis_r() if (erg$typ != "erfolg" || is.null(erg$info_mehrere)) return(NULL) div(class = "alert-warnung", erg$info_mehrere) }) output$ergebnis_ui = renderUI({ req(input$btn_suchen) erg = ergebnis_r() if (erg$typ != "erfolg") return(NULL) score = erg$score klass_farbe = psqi_klassifikation_farbe(score$klassifikation) baue_item_zeile = function(item, nr_prefix) { badge = if (is.na(item$stufe)) { span(class = "stufe-unbeantwortet", "nicht beantwortet") } else { sk = as.character(as.integer(item$stufe)) span(class = paste0("stufe-badge stufe-badge-", sk), if (!is.na(item$label)) item$label else paste0("Stufe ", sk)) } div(class = "item-zeile", div(class = "item-nr", paste0(nr_prefix, item$buchst, ".")), div(class = "item-text", item$text), badge ) } komponenten_zeilen = lapply(seq_along(PSQI_KOMPONENTEN_LABELS), function(i) { sk = as.character(as.integer(score$komponenten[i])) div(class = "komponente-zeile", div(class = "komponente-kopf", div(class = "komponente-name", PSQI_KOMPONENTEN_LABELS[i]), span(class = paste0("stufe-badge stufe-badge-", sk), paste0(sk, " / 3")) ), div(class = "komponente-kriterium", PSQI_KOMPONENTEN_KRITERIEN[i]), div(class = "komponente-eingabe", paste0("Eingabe: ", score$komponenten_eingaben[i])) ) }) partner_ui = if (score$partner_ausgefuellt) { tagList(lapply(score$partner_items, function(item) baue_item_zeile(item, "10"))) } else { div(class = "hinweis-info", "Partnerabschnitt nicht ausgefuellt (kein Partner/Mitbewohner angegeben).") } tagList( div(class = "abschnitt-karte", div(class = "abschnitt-titel", "PSQI - Kopfdaten"), div(class = "meta-block", tags$strong("Chiffre: "), erg$chiffre, tags$span(" | ", style = "color:#ccc;"), tags$strong("Ausfuelldatum: "), erg$ausfuelldatum, tags$span(" | ", style = "color:#ccc;"), tags$strong("Alter: "), erg$alter_text, tags$span(" | ", style = "color:#ccc;"), tags$strong("Geschlecht: "), erg$geschlecht_text ) ), div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Gesamtwert"), fluidRow( column(3, div(class = "score-zahl", style = paste0("color:", klass_farbe, ";"), score$gesamtwert), div("Gesamtwert (0-21)", style = "color:#555;"), div(class = "score-klassifikation", style = paste0("color:", klass_farbe, ";"), score$klassifikation) ), column(9, plotOutput("gauge_plot", height = "160px")) ), tags$hr(), div(class = "hinweis-info", PSQI_VERGLEICHSWERT_TEXT) ), div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Komponenten"), div(komponenten_zeilen) ), div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Schlafstoerungen (Frage 5)"), div(lapply(score$stoerungsitems, function(item) baue_item_zeile(item, "5"))), if (nchar(score$freitext_05j) > 0) div(class = "freitext-box", paste0("Freitext (andere Gruende): ", score$freitext_05j)) ), div(class = "abschnitt-karte", div(class = "abschnitt-titel", "Frage 10: Schlafarrangement / Fremdbeurteilung"), div(class = "hinweis-info", "Diese Angaben fliessen nicht in den PSQI-Gesamtwert ein."), div(class = "kontext-zeile", div(class = "kontext-label", "Schlafarrangement:"), div(if (is.na(score$frage10_text)) "k. A." else score$frage10_text) ), partner_ui, if (nchar(score$freitext_10e) > 0) div(class = "freitext-box", paste0("Freitext (andere Unruhe): ", score$freitext_10e)) ), div(class = "disclaimer-text", PSQI_DISCLAIMER) ) }) output$gauge_plot = renderPlot({ req(input$btn_suchen) erg = ergebnis_r() req(erg$typ == "erfolg") make_gauge_psqi(erg$score$gesamtwert) }, bg = "transparent") output$download_word = downloadHandler( filename = function() { erg = tryCatch(ergebnis_r(), error = function(e) NULL) chiffre_esc = if (is.list(erg) && identical(erg$typ, "erfolg") && nchar(erg$chiffre) > 0) erg$chiffre else "export" ausfuelldatum_fn = if (is.list(erg) && identical(erg$typ, "erfolg") && !is.null(erg$ausfuelldatum)) tryCatch( format(as.Date(erg$ausfuelldatum, "%d.%m.%Y"), "%Y%m%d"), error = function(e) format(Sys.Date(), "%Y%m%d") ) else format(Sys.Date(), "%Y%m%d") paste0("PSQI_", chiffre_esc, "_", ausfuelldatum_fn, ".docx") }, content = function(file) { erg = tryCatch(ergebnis_r(), error = function(e) NULL) daten_ok = is.list(erg) && identical(erg$typ, "erfolg") 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_psqi_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)