# Präambel #### PFAD_DOWNLOAD_SKRIPT = "../API/get_data_vds19.R" # liefert: daten_vds19 PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo AKZENT_FARBE = "#8B2635" VDS19_DISCLAIMER = paste0( "Diese Auswertung ist ein Hilfsmittel fuer klinisches Fachpersonal und ersetzt ", "keine klinische Diagnose. Die Interpretation obliegt der behandelnden Person. ", "Das VDS19+ erfasst ausschliesslich positive Persoenlichkeitsmerkmale (Staerkenprofil); ", "dysfunktionale Aspekte der Persoenlichkeit werden hier nicht abgebildet." ) # Fallback-Ankertexte, falls die Textextraktion aus dem labels-Attribut # (siehe vds19_anker_aus_label) fehlschlaegt. Reihenfolge = Wert 0-3. VDS19_ANKER_TEXTE = c("nicht", "leicht", "mittel", "sehr") # Badge-Farben je Antwortstufe (0-3): auf Nutzerwunsch identisch zur # Gruen-Rot-Ampelskala aus PG13R_BADGE_FARBEN (PG-13-R), auf die 4 statt # 5 Antwortstufen von VDS19+ verkuerzt (die ersten 4 der dortigen 5 Farben). VDS19_BADGE_FARBEN = c( "0" = "#4CAF50", "1" = "#F48FB1", "2" = "#EF5350", "3" = "#B71C1C" ) VDS19_BADGE_TEXT_FARBEN = c( "0" = "white", "1" = "#333333", "2" = "white", "3" = "white" ) library(shiny) library(dplyr) library(ggplot2) library(haven) library(officer) # Infrastruktur #### APP_VERZEICHNIS = normalizePath(getwd()) absPath = function(pfad) { if (grepl("^([A-Za-z]:[/\\\\]|/)", pfad)) return(pfad) file.path(APP_VERZEICHNIS, pfad) } PFAD_DOWNLOAD_SKRIPT = normalizePath(absPath(PFAD_DOWNLOAD_SKRIPT), mustWork = FALSE) PFAD_PSEUDONYM_SKRIPT = normalizePath(absPath(PFAD_PSEUDONYM_SKRIPT), mustWork = FALSE) # Helper #### # Der formr-Exportwert dieses 'mc'-Feldtyps ist fuer VDS19+ beim Bau NICHT # live gegen echte Daten verifiziert worden (roher Wert 0-3 ODER ein # 1-basierter Choice-Index 1-4 sind beide moeglich). Um eine stille # Fehlkodierung auszuschliessen, wird der inhaltliche Skalenwert (0-3) daher # NICHT aus dem numerischen Rohwert der Spalte gelesen, sondern ausschliesslich # aus dem TEXT des zum Rohwert passenden labels-Eintrags (z.B. "0 = nicht" -> 0), # per Regex auf die fuehrende Ziffer vor dem Gleichheitszeichen. # spalte_voll ist die ungekuerzte Original-Spalte aus daten_vds19 (Quelle der # labels), wert_roh der Rohwert der konkreten Antwort aus der gefilterten Zeile. # Vor dem ersten produktiven Einsatz bitte stichprobenartig gegen die # Rohantwort im formr-Interface pruefen. vds19_wert_aus_label = function(spalte_voll, wert_roh) { if (is.null(wert_roh) || length(wert_roh) == 0 || is.na(wert_roh[1])) return(NA_real_) wert_roh = wert_roh[1] labels_attr = attr(spalte_voll, "labels") if (!is.null(labels_attr) && length(labels_attr) > 0) { treffer = which(as.numeric(labels_attr) == as.numeric(unclass(wert_roh))) if (length(treffer) > 0) { label_text = names(labels_attr)[treffer[1]] ziffer = suppressWarnings(as.numeric(sub("^\\s*(\\d+)\\s*=.*$", "\\1", trimws(label_text)))) if (!is.na(ziffer)) return(ziffer) } } # Fallback nur falls labels-Attribut fehlt: Rohwert direkt als Ziffer 0-3 # interpretieren (konservative Annahme, siehe Kommentar oben). wert_num = suppressWarnings(as.numeric(unclass(wert_roh))) if (!is.na(wert_num) && wert_num >= 0 && wert_num <= 3) return(wert_num) NA_real_ } # Ankertext (z.B. "nicht", "sehr") zur konkreten Antwort, fuer die Item-Badges. # Gleiche Vorsichtsmassnahme wie vds19_wert_aus_label: Text kommt aus dem # labels-Attribut, nicht aus einer hartkodierten Positionsannahme. Faellt bei # fehlendem labels-Attribut auf VDS19_ANKER_TEXTE[ziffer + 1] zurueck. vds19_anker_aus_label = function(spalte_voll, wert_roh, ziffer = NULL) { if (is.null(wert_roh) || length(wert_roh) == 0 || is.na(wert_roh[1])) return(NA_character_) wert_roh = wert_roh[1] labels_attr = attr(spalte_voll, "labels") if (!is.null(labels_attr) && length(labels_attr) > 0) { treffer = which(as.numeric(labels_attr) == as.numeric(unclass(wert_roh))) if (length(treffer) > 0) { label_text = names(labels_attr)[treffer[1]] anker = trimws(sub("^\\s*\\d+\\s*=\\s*", "", label_text)) if (nchar(anker) > 0) return(anker) } } if (!is.null(ziffer) && !is.na(ziffer) && ziffer >= 0 && ziffer <= 3) { return(VDS19_ANKER_TEXTE[ziffer + 1]) } NA_character_ } # Itemtext (Fragebogenwortlaut) aus dem label-Attribut der Spalte (nicht zu # verwechseln mit dem labels-Attribut der Antwortoptionen). Entfernt # formr-Nummerierungsartefakte am Anfang (z.B. "1. " oder "01) "). vds19_item_text = function(spalte_voll, feld) { txt = attr(spalte_voll, "label") if (is.null(txt) || length(txt) == 0 || is.na(txt[1]) || trimws(txt[1]) == "") { return(paste0("Item ", feld)) } sub("^\\d+[.)]\\s*", "", trimws(as.character(txt[1]))) } # Skalenmittelwert aus 10 Item-Werten. Bei einem fehlenden Item wird NA # zurueckgegeben (Skala gilt dann als "unvollstaendig"), statt mit # na.rm = TRUE einen aus weniger als 10 Items berechneten Mittelwert # stillschweigend anzuzeigen. vds19_skalenmittelwert = function(werte) { if (any(is.na(werte))) return(NA_real_) sum(werte) / length(werte) } # Bipolare Zusatzbeschriftung: unterer Pol bei Mittelwert < 1.5, sonst der # Skalenname selbst. Reine Lesehilfe, keine Bewertung. vds19_bipolar_label = function(mittelwert, name, pol_niedrig) { if (is.na(mittelwert)) return(NA_character_) if (mittelwert < 1.5) pol_niedrig else name } # Bipolares Profildiagramm: pro Skala eine horizontale Achse 0-3, mit dem # unteren Pol links, dem Skalennamen (oberer Pol) rechts und dem tatsaechlichen # Mittelwert als Punkt auf der Achse markiert. NA-Mittelwerte (unvollstaendige # Skalen) werden als "unvollstaendig" statt eines Punktes ausgegeben, kein Cutoff. vds19_profil_plot = function(profil_df) { profil_df$y = rev(seq_len(nrow(profil_df))) df_ok = profil_df[!is.na(profil_df$mittelwert), ] df_na = profil_df[is.na(profil_df$mittelwert), ] p = ggplot(profil_df, aes(y = y)) + geom_segment(aes(x = 0, xend = 3, yend = y), color = "#D9D9D9", linewidth = 0.7) + geom_text(aes(x = -0.15, label = pol_niedrig), hjust = 1, size = 3.3, color = "#555555") + geom_text(aes(x = 3.15, label = name), hjust = 0, size = 3.3, color = "#333333", fontface = "bold") if (nrow(df_ok) > 0) { p = p + geom_point(data = df_ok, aes(x = mittelwert), color = AKZENT_FARBE, size = 3.6) + geom_text(data = df_ok, aes(x = mittelwert, label = sprintf("%.1f", mittelwert)), vjust = -1.4, size = 3.1, color = AKZENT_FARBE, fontface = "bold") } if (nrow(df_na) > 0) { p = p + geom_text(data = df_na, aes(x = 1.5, label = "unvollständig"), vjust = -1.1, size = 3, color = "#999999", fontface = "italic") } p + scale_x_continuous(limits = c(-4.3, 7.3), breaks = 0:3) + scale_y_continuous(limits = c(0.3, nrow(profil_df) + 0.8), breaks = NULL) + labs(x = NULL, y = NULL) + theme_minimal(base_size = 12) + theme( panel.grid.major.y = element_blank(), panel.grid.minor = element_blank(), panel.grid.major.x = element_blank(), axis.text.x = element_text(color = "#999999", size = 9), axis.ticks.x = element_line(color = "#D9D9D9"), plot.margin = margin(t = 12, r = 10, b = 5, l = 10) ) } # Datenaufbereitung #### # Reihenfolge, Namen und bipolare Gegenpole entsprechen dem Original-Testbogen # (VDS19+, Prof. Dr. Dr. Serge Sulz). Feldnamen der 90 Items: vds19_101 bis # vds19_910 (Skala + 2-stellige Item-Nr innerhalb der Skala). VDS19_SKALEN = data.frame( skala_nr = 1:9, name = c( "selbstbewusst", "selbständig", "flexibel", "konfliktsicher", "ausgeglichen", "beziehungsbezogen", "gemeinschaftsorientiert", "emotional stabil", "unvoreingenommen" ), pol_niedrig = c( "unsicher", "anpassungsbereit", "pflicht-leistungsorientiert", "kritisch, passiv-aggressiv", "kontaktfreudig, expressiv", "rational, kontaktmeidend", "selbstbezogen", "emotional unausgeglichen", "misstrauisch" ), stringsAsFactors = FALSE ) vds19_item_felder = function(skala_nr) sprintf("vds19_%d%02d", skala_nr, 1: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; } .item-zeile { display: flex; align-items: center; gap: 10px; padding: 7px 0; border-bottom: 1px solid #F0F0F0; } .item-zeile:last-child { border-bottom: none; } .item-nr { font-weight: 600; color: #8B2635; min-width: 26px; flex-shrink: 0; } .item-text { flex: 1; color: #333; font-size: 0.95em; } .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; } " 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("VDS19+ – Plus-Persönlichkeit"), tags$p("Persönliche Stärken | 9 Skalen à 10 Items, ipsatives Stärkenprofil, kein Gesamtscore") ), 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_vds19_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_bipolar = fp_text(font.size = 10, italic = TRUE, color = "#777777") fp_hinweis = fp_text(font.size = 10, italic = TRUE, color = "#555555") fp_warnung = fp_text(font.size = 10, italic = TRUE, color = "#BF360C") fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777") doc = body_add_fpar(doc, fpar(ftext("VDS19+ (Plus-Persönlichkeit) — Auswertung", fp_titel))) doc = body_add_fpar(doc, fpar( ftext("Chiffre: ", fp_label), ftext(erg$chiffre, fp_normal), ftext(" Ausfülldatum: ", fp_label), ftext(erg$ausfuelldatum, fp_normal) )) doc = body_add_par(doc, "", style = "Normal") if (!is.null(erg$mehrfach_warnung)) { doc = body_add_fpar(doc, fpar(ftext(erg$mehrfach_warnung, fp_warnung))) doc = body_add_par(doc, "", style = "Normal") } doc = body_add_fpar(doc, fpar(ftext(paste0( "Dieses Profil ist ipsativ und ressourcenorientiert: die 9 Mittelwerte werden nur ", "relativ zueinander interpretiert (welche Staerken sind im Profil relativ staerker ", "oder schwaecher ausgepraegt), nicht gegen eine Referenzstichprobe. Es gibt keinen ", "Cutoff und keinen Gesamtscore. Dysfunktionale Aspekte der Persoenlichkeit werden ", "durch das VDS19+ nicht erfasst." ), fp_hinweis))) doc = body_add_par(doc, "", style = "Normal") doc = body_add_fpar(doc, fpar(ftext("Stärkenprofil", fp_abschnitt))) profil_img = tempfile(fileext = ".png") ggsave(profil_img, plot = vds19_profil_plot(erg$profil), width = 7.2, height = 4, dpi = 150, bg = "white") doc = body_add_img(doc, src = profil_img, width = 6.2, height = 3.45) if (file.exists(profil_img)) file.remove(profil_img) doc = body_add_par(doc, "", style = "Normal") for (r in seq_len(nrow(erg$profil))) { zeile = erg$profil[r, ] mw_text = if (isTRUE(zeile$vollstaendig)) sprintf("%.1f / 3", zeile$mittelwert) else "unvollständig" label_text = if (isTRUE(zeile$vollstaendig) && zeile$bipolar != zeile$name) paste0(" (", zeile$bipolar, ")") else "" doc = body_add_fpar(doc, fpar( ftext(paste0(zeile$skala_nr, ". ", zeile$name, ": "), fp_label), ftext(mw_text, fp_normal), ftext(label_text, fp_bipolar) )) } doc = body_add_par(doc, "", style = "Normal") for (r in seq_len(nrow(erg$profil))) { skala_name = erg$profil$name[r] items = erg$items_je_skala[[skala_name]] doc = body_add_fpar(doc, fpar( ftext(paste0(erg$profil$skala_nr[r], ". ", skala_name), fp_abschnitt) )) for (j in seq_len(nrow(items))) { zeile = items[j, ] sk = if (!is.na(zeile$wert) && zeile$wert >= 0 && zeile$wert <= 3) as.character(as.integer(zeile$wert)) else NA_character_ anker_txt = if (!is.na(zeile$anker)) zeile$anker else if (!is.na(sk)) VDS19_ANKER_TEXTE[as.integer(sk) + 1] else "k. A." fp_badge = if (!is.na(sk)) { fp_text(color = VDS19_BADGE_TEXT_FARBEN[[sk]], bold = TRUE, shading.color = VDS19_BADGE_FARBEN[[sk]], font.size = 10) } else { fp_text(color = "#888888", bold = TRUE, shading.color = "#EFEFEF", font.size = 10) } doc = body_add_fpar(doc, fpar( ftext(paste0(zeile$item_pos, ". ", zeile$text, " "), fp_normal), ftext(paste0(" ", anker_txt, " "), fp_badge) )) } doc = body_add_par(doc, "", style = "Normal") } doc = body_add_fpar(doc, fpar(ftext(VDS19_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 = 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:\n", PFAD_DOWNLOAD_SKRIPT))) } if (!file.exists(PFAD_PSEUDONYM_SKRIPT)) { return(list(typ = "skript_fehler", meldung = paste0("Pseudonym-Skript nicht gefunden:\n", PFAD_PSEUDONYM_SKRIPT))) } # Schritt 1: Download-Skript sourcen 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)) # Schritt 2: pseudonyme.db suchen (bis zu 5 Ebenen ueber dem Pseudonym-Skript) 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 = "db_nicht_gefunden")) # Schritt 3: Pseudonym-Skript sourcen (relativer DB-Zugriff, daher setwd + on.exit) 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_vds19", envir = .GlobalEnv) || !exists("pseudo", envir = .GlobalEnv)) { return(list(typ = "daten_fehlen")) } daten = get("daten_vds19", envir = .GlobalEnv) pseudo_df = get("pseudo", envir = .GlobalEnv) if (!("session" %in% names(daten))) { return(list(typ = "daten_fehlen", meldung = "Erwartete Spalte 'session' nicht in 'daten_vds19' gefunden.")) } # Schritt 4: Chiffre-Rueckaufloesung, falls Pseudonym eingegeben wurde if (nchar(trimws(input$pseudonym)) > 0) { pw_treffer = pseudo_df[pseudo_df$pseudonym == trimws(input$pseudonym), ] if (nrow(pw_treffer) > 0) chiffre = toupper(trimws(pw_treffer$chiffre[1])) } # Schritt 5: Chiffre -> moegliche Pseudonyme (Session-IDs) treffer_ps = pseudo_df[toupper(trimws(pseudo_df$chiffre)) == chiffre, ] if (nrow(treffer_ps) == 0) return(list(typ = "kein_datensatz", chiffre = chiffre)) alle_session_ids = unique(treffer_ps$pseudonym) if (nchar(trimws(input$pseudonym)) > 0) alle_session_ids = trimws(input$pseudonym) # Schritt 6: passende Datensaetze in daten_vds19 finden treffer_daten = daten[daten$session %in% alle_session_ids, ] if (nrow(treffer_daten) == 0) return(list(typ = "kein_datensatz", chiffre = chiffre)) mehrfach_warnung = NULL if (nrow(treffer_daten) > 1) { n = nrow(treffer_daten) if (nchar(trimws(input$pseudonym)) == 0 && "created" %in% names(treffer_daten)) { treffer_daten = treffer_daten[order(treffer_daten$created, decreasing = TRUE), ] mehrfach_warnung = paste0( "Mehrere Ausfuellungen gefunden (", n, " Eintraege) – es wird die neueste angezeigt." ) } treffer_daten = treffer_daten[1, , drop = FALSE] } zeile = treffer_daten[1, , drop = FALSE] ausfuelldatum = tryCatch( format(as.POSIXct(zeile[["created"]][1]), "%d.%m.%Y"), error = function(e) format(Sys.Date(), "%d.%m.%Y") ) # Schritt 7: die 9 Skalenmittelwerte aus je 10 Items berechnen, sowie # parallel die Einzelitems (Text, Wert, Ankertext) fuer die Item-Anzeige. skalen_ergebnis = lapply(seq_len(nrow(VDS19_SKALEN)), function(i) { skala_nr = VDS19_SKALEN$skala_nr[i] felder = vds19_item_felder(skala_nr) items_i = do.call(rbind, lapply(seq_along(felder), function(j) { feld = felder[j] spalte_voll = daten[[feld]] wert_roh = if (feld %in% names(zeile)) zeile[[feld]][1] else NA wert = if (is.null(spalte_voll)) NA_real_ else vds19_wert_aus_label(spalte_voll, wert_roh) anker = if (is.null(spalte_voll)) NA_character_ else vds19_anker_aus_label(spalte_voll, wert_roh, wert) text = if (is.null(spalte_voll)) paste0("Item ", feld) else vds19_item_text(spalte_voll, feld) data.frame( feld = feld, item_pos = j, text = text, wert = wert, anker = anker, stringsAsFactors = FALSE ) })) werte = items_i$wert mittelwert = vds19_skalenmittelwert(werte) vollstaendig = !is.na(mittelwert) bipolar = vds19_bipolar_label(mittelwert, VDS19_SKALEN$name[i], VDS19_SKALEN$pol_niedrig[i]) list( profil_zeile = data.frame( skala_nr = skala_nr, name = VDS19_SKALEN$name[i], pol_niedrig = VDS19_SKALEN$pol_niedrig[i], mittelwert = mittelwert, bipolar = bipolar, vollstaendig = vollstaendig, stringsAsFactors = FALSE ), items = items_i ) }) profil = do.call(rbind, lapply(skalen_ergebnis, function(x) x$profil_zeile)) items_je_skala = lapply(skalen_ergebnis, function(x) x$items) names(items_je_skala) = VDS19_SKALEN$name list( typ = "erfolg", chiffre = chiffre, ausfuelldatum = ausfuelldatum, mehrfach_warnung = mehrfach_warnung, profil = profil, items_je_skala = items_je_skala ) }) vds19_fehlermeldung = function(d) { switch(d$typ, "leere_eingabe" = d$meldung, "format_fehler" = paste0("Ungueltige Chiffre '", d$chiffre, "'. Erwartet: ein Grossbuchstabe + 6 Ziffern (z.B. P000123)."), "skript_fehler" = paste0("Fehler beim Sourcen eines externen Skripts: ", d$meldung), "db_nicht_gefunden" = "Die Datei 'pseudonyme.db' konnte in den uebergeordneten Verzeichnissen nicht gefunden werden.", "daten_fehlen" = if (!is.null(d$meldung)) d$meldung else "Nach dem Sourcen der Skripte fehlen die erwarteten Objekte 'daten_vds19' oder 'pseudo'.", "kein_datensatz" = paste0("Kein VDS19+-Datensatz fuer Chiffre '", d$chiffre, "' gefunden."), "Unbekannter Fehler." ) } output$fehler_ui = renderUI({ req(input$btn_suchen) d = ergebnis() if (d$typ != "erfolg") div(class = "alert-fehler", vds19_fehlermeldung(d)) }) output$warnung_ui = renderUI({ req(input$btn_suchen) d = ergebnis() if (d$typ != "erfolg") return(NULL) if (!is.null(d$mehrfach_warnung)) div(class = "alert-warnung", d$mehrfach_warnung) }) output$ergebnis_ui = renderUI({ req(input$btn_suchen) d = ergebnis() if (d$typ != "erfolg") return(NULL) profil_zeilen = lapply(seq_len(nrow(d$profil)), function(i) { zeile = d$profil[i, ] div(class = "item-zeile", div(class = "item-nr", paste0(zeile$skala_nr, ".")), div(class = "item-text", zeile$name), div(style = "min-width: 90px; text-align: right; font-weight: 700; color: #333;", if (isTRUE(zeile$vollstaendig)) sprintf("%.1f", zeile$mittelwert) else tags$span(style = "color: #999; font-style: italic; font-weight: 400;", "unvollständig") ), div(style = "min-width: 220px; text-align: right; font-size: 0.85em; font-style: italic; color: #777;", if (isTRUE(zeile$vollstaendig) && zeile$bipolar != zeile$name) zeile$bipolar else "" ) ) }) item_karten = lapply(seq_len(nrow(d$profil)), function(i) { skala_name = d$profil$name[i] items = d$items_je_skala[[skala_name]] item_zeilen = lapply(seq_len(nrow(items)), function(j) { zeile = items[j, ] sk = if (!is.na(zeile$wert) && zeile$wert >= 0 && zeile$wert <= 3) as.character(as.integer(zeile$wert)) else NA_character_ anker_txt = if (!is.na(zeile$anker)) zeile$anker else if (!is.na(sk)) VDS19_ANKER_TEXTE[as.integer(sk) + 1] else "k. A." div(class = "item-zeile", div(class = "item-nr", paste0(zeile$item_pos, ".")), div(class = "item-text", zeile$text), if (!is.na(sk)) tags$span(class = paste0("stufe-badge stufe-badge-", sk), anker_txt) else tags$span(style = "background: #EFEFEF; color: #888; border-radius: 4px; padding: 2px 9px; font-weight: 700; font-size: 0.82em; white-space: nowrap;", "k. A.") ) }) div(class = "abschnitt-karte", div(class = "abschnitt-titel", paste0(d$profil$skala_nr[i], ". ", skala_name)), div(item_zeilen) ) }) tagList( div(class = "abschnitt-karte", div(class = "abschnitt-titel", "VDS19+ – Profil der persönlichen Stärken"), div(style = "margin-bottom: 10px; color: #555; font-size: 0.95em;", tags$strong("Chiffre: "), d$chiffre, tags$span(" | ", style = "color: #ccc;"), tags$strong("Ausfülldatum: "), d$ausfuelldatum ), plotOutput("profil_plot", height = "420px"), div(profil_zeilen) ), item_karten, div(style = "font-size: 0.82em; color: #777; font-style: italic; margin: 4px 0 16px; padding: 0 4px;", VDS19_DISCLAIMER ) ) }) output$profil_plot = renderPlot({ req(input$btn_suchen) d = ergebnis() req(identical(d$typ, "erfolg")) vds19_profil_plot(d$profil) }, bg = "transparent") output$download_word = downloadHandler( filename = function() { d = tryCatch(ergebnis(), error = function(e) NULL) erfolgreich = is.list(d) && identical(d$typ, "erfolg") chiffre_esc = if (erfolgreich && nchar(d$chiffre) > 0) gsub("[^A-Za-z0-9_-]", "_", d$chiffre) else "export" ausfuelldatum_fn = if (erfolgreich) { 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("VDS19_", chiffre_esc, "_", ausfuelldatum_fn, ".docx") }, content = function(file) { d = tryCatch(ergebnis(), error = function(e) NULL) erfolgreich = is.list(d) && identical(d$typ, "erfolg") if (!erfolgreich) { 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_vds19_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)