Initial commit
This commit is contained in:
commit
3cba772836
1341 changed files with 532924 additions and 0 deletions
BIN
VDS51/.RData
Normal file
BIN
VDS51/.RData
Normal file
Binary file not shown.
1
VDS51/.Rprofile
Normal file
1
VDS51/.Rprofile
Normal file
|
|
@ -0,0 +1 @@
|
|||
source("renv/activate.R")
|
||||
13
VDS51/VDS51.Rproj
Normal file
13
VDS51/VDS51.Rproj
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
Version: 1.0
|
||||
|
||||
RestoreWorkspace: Default
|
||||
SaveWorkspace: Default
|
||||
AlwaysSaveHistory: Default
|
||||
|
||||
EnableCodeIndexing: Yes
|
||||
UseSpacesForTab: Yes
|
||||
NumSpacesForTab: 2
|
||||
Encoding: UTF-8
|
||||
|
||||
RnwWeave: Sweave
|
||||
LaTeX: pdfLaTeX
|
||||
869
VDS51/app.R
Normal file
869
VDS51/app.R
Normal file
|
|
@ -0,0 +1,869 @@
|
|||
# Präambel ####
|
||||
|
||||
PFAD_DOWNLOAD_SKRIPT = "../API/get_data_vds51.R" # liefert: daten_vds51
|
||||
PFAD_PSEUDONYM_SKRIPT = "../get_pseudo.R" # liefert: pseudo
|
||||
AKZENT_FARBE = "#8B2635"
|
||||
|
||||
VDS51_DISCLAIMER = paste0(
|
||||
"Diese Zusammenstellung ist eine Aufbereitung der vom Patienten angekreuzten Ziele und ",
|
||||
"stellt keine testtheoretische Auswertung dar. VDS51 kennt keine Summenscores, Subskalen ",
|
||||
"oder Cutoffs. Die Interpretation und Priorisierung der Ziele obliegt der behandelnden Person."
|
||||
)
|
||||
|
||||
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 ####
|
||||
|
||||
# Robuste Konvertierung eines rohen Item-Werts (formr-Itemtyp "check") auf 0/1.
|
||||
# Das tatsaechliche Exportformat von "check"-Items ist in dieser formr-Installation NICHT
|
||||
# verifiziert - laut Spezifikation kann es als TRUE/FALSE, als 1/0/NA oder als
|
||||
# haven_labelled-Vektor vorliegen. Deshalb werden hier alle plausiblen Kodierungen
|
||||
# abgedeckt. Bei unbekanntem/nicht interpretierbarem Wert wird NA zurueckgegeben, nie ein
|
||||
# geratener Wert. VOR DEM ERSTEN ECHTEN TESTLAUF GEGEN ECHTE DATEN VERIFIZIEREN.
|
||||
vds51_zu_binaer = function(x) {
|
||||
if (is.null(x) || length(x) == 0) return(NA_integer_)
|
||||
if (is.na(x[1])) return(NA_integer_)
|
||||
|
||||
if (inherits(x, "haven_labelled")) {
|
||||
zahl = suppressWarnings(as.numeric(haven::zap_labels(x))[1])
|
||||
if (!is.na(zahl) && zahl %in% c(0, 1)) return(as.integer(zahl))
|
||||
lbl = attr(x, "labels")
|
||||
if (!is.null(lbl) && length(lbl) > 0 && !is.na(zahl)) {
|
||||
pos = which(as.vector(lbl) == zahl)
|
||||
if (length(pos) > 0) {
|
||||
text = tolower(trimws(names(lbl)[pos[1]]))
|
||||
if (grepl("check|wahr|richtig|zutreffend|^ja$|^x$|^1$", text)) return(1L)
|
||||
if (grepl("uncheck|falsch|nicht zutreffend|^nein$|^0$", text)) return(0L)
|
||||
}
|
||||
}
|
||||
return(NA_integer_)
|
||||
}
|
||||
|
||||
wert = x[1]
|
||||
|
||||
if (is.logical(wert)) return(as.integer(wert))
|
||||
|
||||
if (is.numeric(wert)) {
|
||||
if (wert %in% c(0, 1)) return(as.integer(wert))
|
||||
return(NA_integer_)
|
||||
}
|
||||
|
||||
if (is.character(wert)) {
|
||||
txt = tolower(trimws(wert))
|
||||
if (txt %in% c("checked", "true", "wahr", "1", "ja", "x")) return(1L)
|
||||
if (txt %in% c("", "unchecked", "false", "falsch", "0", "nein")) return(0L)
|
||||
return(NA_integer_)
|
||||
}
|
||||
|
||||
NA_integer_
|
||||
}
|
||||
|
||||
# Entfernt die woertlichen Markdown-Artefakte aus den Item-Labels (** und escapte
|
||||
# Punkte \. ), die formr im label-Attribut mitliefert.
|
||||
vds51_bereinige_markdown = function(txt) {
|
||||
if (is.null(txt) || length(txt) == 0 || is.na(txt[1])) return(NA_character_)
|
||||
s = as.character(txt[1])
|
||||
s = gsub("\\.", ".", s, fixed = TRUE)
|
||||
s = gsub("**", "", s, fixed = TRUE)
|
||||
s
|
||||
}
|
||||
|
||||
# Zerlegt das label-Attribut eines Modul-1-Items
|
||||
# ("**{Nr}\. {Problem}**\n**Ziel:** {Ziel}") in Nummer, Problem- und Zielsatz. Falls
|
||||
# statt eines echten Zeilenumbruchs nur die Zeichenkette "\n" im Rohtext steht, wird das
|
||||
# vorab normalisiert (Exportformat nicht verifiziert, siehe vds51_zu_binaer).
|
||||
vds51_parse_item_label = function(label_roh) {
|
||||
if (is.null(label_roh) || length(label_roh) == 0 || is.na(label_roh[1])) {
|
||||
return(list(nr = NA_integer_, problem = NA_character_, ziel = NA_character_))
|
||||
}
|
||||
roh = as.character(label_roh[1])
|
||||
roh = gsub("\\\\n", "\n", roh, perl = TRUE)
|
||||
txt = vds51_bereinige_markdown(roh)
|
||||
zeilen = strsplit(txt, "\r?\n")[[1]]
|
||||
zeile_problem = if (length(zeilen) >= 1) trimws(zeilen[1]) else ""
|
||||
zeile_ziel = if (length(zeilen) >= 2) trimws(zeilen[2]) else ""
|
||||
|
||||
nr = NA_integer_
|
||||
problem = zeile_problem
|
||||
treffer = regmatches(zeile_problem, regexec("^(\\d+)\\.\\s*(.*)$", zeile_problem))[[1]]
|
||||
if (length(treffer) == 3) {
|
||||
nr = as.integer(treffer[2])
|
||||
problem = trimws(treffer[3])
|
||||
}
|
||||
|
||||
ziel = sub("^Ziel:\\s*", "", zeile_ziel)
|
||||
|
||||
list(nr = nr, problem = problem, ziel = trimws(ziel))
|
||||
}
|
||||
|
||||
# Zerlegt den Choice-Labeltext eines Modul-2-Dropdowns ("{Nr}\. {Problem}") in Nummer
|
||||
# und Problemsatz.
|
||||
vds51_parse_zsf_text = function(text_roh) {
|
||||
if (is.null(text_roh) || length(text_roh) == 0 || is.na(text_roh[1])) {
|
||||
return(list(nr = NA_integer_, problem = NA_character_))
|
||||
}
|
||||
txt = vds51_bereinige_markdown(as.character(text_roh[1]))
|
||||
zeile = trimws(strsplit(txt, "\r?\n")[[1]][1])
|
||||
treffer = regmatches(zeile, regexec("^(\\d+)\\.\\s*(.*)$", zeile))[[1]]
|
||||
if (length(treffer) == 3) {
|
||||
return(list(nr = as.integer(treffer[2]), problem = trimws(treffer[3])))
|
||||
}
|
||||
list(nr = NA_integer_, problem = zeile)
|
||||
}
|
||||
|
||||
# Loest den vollen Itemtext eines Modul-2-Dropdowns ueber das labels-Attribut der Spalte
|
||||
# auf. Verifiziert anhand eines echten Exports (str()-Ausgabe): die Spalte ist
|
||||
# haven_labelled (chr+lbl), der Rohwert ist der gewaehlte Choice-Name (z. B.
|
||||
# "b11_item1"), und im labels-Attribut stehen die Choice-Namen als NAMEN, der volle
|
||||
# Itemtext als WERT (also umgekehrt zur ueblichen haven::labelled()-Konvention). Liefert
|
||||
# NA, wenn der Rohwert keinem Eintrag im labels-Attribut zugeordnet werden kann (kein
|
||||
# geratener Text).
|
||||
vds51_zsf_text = function(spalte, wert) {
|
||||
if (is.null(wert) || length(wert) == 0 || is.na(wert[1])) return(NA_character_)
|
||||
w = trimws(as.character(wert[1]))
|
||||
if (nchar(w) == 0) return(NA_character_)
|
||||
|
||||
lbl_attr = attr(spalte, "labels")
|
||||
if (!is.null(lbl_attr) && length(lbl_attr) > 0) {
|
||||
pos = which(names(lbl_attr) == w)
|
||||
if (length(pos) > 0) return(as.character(lbl_attr)[pos[1]])
|
||||
}
|
||||
|
||||
if (is.factor(spalte) && w %in% levels(spalte)) return(w)
|
||||
|
||||
NA_character_
|
||||
}
|
||||
|
||||
# Leitet die Item-Spaltennamen eines Themenblocks programmatisch her, keine 156
|
||||
# Feldnamen manuell auflisten.
|
||||
vds51_item_spalten = function(feldpraefix, n_items) {
|
||||
paste0("vds51_", feldpraefix, "_", sprintf("%02d", 1:n_items))
|
||||
}
|
||||
|
||||
# Extrahiert die Item-Nummer aus einem Spaltennamen (z. B. "vds51_b11_03" -> 3).
|
||||
vds51_item_nr = function(spalte) {
|
||||
as.integer(sub(".*_([0-9]+)$", "\\1", spalte))
|
||||
}
|
||||
|
||||
# Ermittelt fuer einen Themenblock die angekreuzten Items (Modul 1). Block 3.1 nutzt die
|
||||
# statische Referenztabelle b31_texte (Datenaufbereitung), da dessen label-Attribut im
|
||||
# Export nur einen Kurztitel enthaelt, nicht den vollen Problem-/Zieltext.
|
||||
vds51_verarbeite_block = function(daten, zeile, block) {
|
||||
spalten = vds51_item_spalten(block$feldpraefix, block$n_items)
|
||||
ist_b31 = identical(block$code, "3.1")
|
||||
|
||||
items = list()
|
||||
n_angekreuzt = 0L
|
||||
n_unklar = 0L
|
||||
|
||||
for (spalte in spalten) {
|
||||
bin = vds51_zu_binaer(zeile[[spalte]][1])
|
||||
if (is.na(bin)) {
|
||||
n_unklar = n_unklar + 1L
|
||||
next
|
||||
}
|
||||
if (bin != 1L) next
|
||||
|
||||
n_angekreuzt = n_angekreuzt + 1L
|
||||
nr = vds51_item_nr(spalte)
|
||||
|
||||
if (ist_b31) {
|
||||
treffer = b31_texte[b31_texte$nr == nr, ]
|
||||
if (nrow(treffer) > 0) {
|
||||
items[[length(items) + 1]] = list(
|
||||
nr = nr, kurztitel = treffer$kurztitel[1],
|
||||
problem = treffer$problem[1], ziel = treffer$ziel[1]
|
||||
)
|
||||
} else {
|
||||
items[[length(items) + 1]] = list(
|
||||
nr = nr, kurztitel = NA_character_,
|
||||
problem = "(Text nicht auffindbar)", ziel = ""
|
||||
)
|
||||
}
|
||||
} else {
|
||||
geparst = vds51_parse_item_label(attr(daten[[spalte]], "label"))
|
||||
if (is.na(geparst$nr)) geparst$nr = nr
|
||||
items[[length(items) + 1]] = list(
|
||||
nr = geparst$nr, kurztitel = NA_character_,
|
||||
problem = geparst$problem, ziel = geparst$ziel
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
list(
|
||||
code = block$code, titel = block$titel, hauptgruppe = block$hauptgruppe,
|
||||
n_items = block$n_items, n_angekreuzt = n_angekreuzt,
|
||||
n_unklar = n_unklar, items = items
|
||||
)
|
||||
}
|
||||
|
||||
# Ermittelt fuer einen Themenblock das vom Patienten priorisierte Ziel aus Modul 2
|
||||
# (Dropdown vds51_zsf_{Code}_wahl).
|
||||
vds51_verarbeite_zsf = function(daten, zeile, block) {
|
||||
code_kurz = gsub(".", "", block$code, fixed = TRUE)
|
||||
feld = paste0("vds51_zsf_", code_kurz, "_wahl")
|
||||
|
||||
if (!(feld %in% names(daten))) {
|
||||
return(list(code = block$code, titel = block$titel, text = NA_character_, feld_fehlt = TRUE))
|
||||
}
|
||||
|
||||
text_roh = vds51_zsf_text(daten[[feld]], zeile[[feld]][1])
|
||||
geparst = if (!is.na(text_roh)) vds51_parse_zsf_text(text_roh) else NULL
|
||||
|
||||
list(
|
||||
code = block$code, titel = block$titel,
|
||||
text = if (!is.null(geparst)) geparst$problem else NA_character_,
|
||||
feld_fehlt = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
# Datenaufbereitung ####
|
||||
|
||||
VDS51_BLOECKE = data.frame(
|
||||
code = c("1.1", "1.2", "1.3", "2.1", "2.2", "2.3", "2.4", "2.5",
|
||||
"2.6", "2.7", "2.8", "3.1", "3.2", "3.3"),
|
||||
feldpraefix = c("b11", "b12", "b13", "b21", "b22", "b23", "b24", "b25",
|
||||
"b26", "b27", "b28", "b31", "b32", "b33"),
|
||||
titel = c(
|
||||
"Symptomverständnis",
|
||||
"Umgang mit dem SYMPTOM",
|
||||
"PERSÖNLICHKEIT",
|
||||
"EMOTIONALE KOMPETENZ",
|
||||
"SOZIALE KOMPETENZ",
|
||||
"KOMMUNIKATIONSKOMPETENZ",
|
||||
"KOGNITIVE KOMPETENZ",
|
||||
"BEZIEHUNGSKOMPETENZ",
|
||||
"PARTNERSCHAFT",
|
||||
"SELBSTÄNDIGKEIT",
|
||||
"GENUSSFÄHIGKEIT",
|
||||
"„Ein gesunder Mensch hat die Fähigkeit …“",
|
||||
"„Ein gesunder Mensch braucht“",
|
||||
"„Ein gesunder Mensch ist / macht“"
|
||||
),
|
||||
hauptgruppe = c(
|
||||
rep("SYMPTOMENTSTEHUNG", 3),
|
||||
rep("KOMPETENZEN/Fertigkeiten", 8),
|
||||
rep("Übergeordnete Ziele", 3)
|
||||
),
|
||||
n_items = c(5, 6, 9, 25, 14, 14, 6, 20, 14, 6, 8, 12, 4, 13),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
b31_texte = data.frame(
|
||||
nr = 1:12,
|
||||
kurztitel = c(
|
||||
"zur Emotionsregulation",
|
||||
"zur Selbstwahrnehmung",
|
||||
"zur Selbststeuerung",
|
||||
"zur sozialen Wahrnehmung",
|
||||
"zur Kommunikation",
|
||||
"zur Abgrenzung",
|
||||
"zur Bindung",
|
||||
"zum Umgang mit Beziehungen",
|
||||
"sich aus einer zu Ende gegangenen Bindung lösen zu können",
|
||||
"zur Utilisierung von Ressourcen (Begabungen, Kenntnisse, Kreativität, soziales Umfeld)",
|
||||
"zur Bewältigung krisenhafter Situationen",
|
||||
"Leidenskapazität"
|
||||
),
|
||||
problem = c(
|
||||
"ENTWEDER Meine Handlungen werden von den Gefühlen geleitet, ich kann nicht dagegen handeln oder Gefühle aushalten. Ich habe Impulsdurchbrüche, v. a. durch negative Gefühle, die ich nicht aushalte. Ich leide darunter, wünsche mir, meine Gefühle besser im Griff zu haben. ODER Ich nehme mich selbst als vernünftig wahr, spüre keine Gefühle, was mir aber bewusst ist und worunter ich leide.",
|
||||
"Ich nehme innere Prozesse nur sehr unpräzise wahr, meine Selbstreflexion ist mäßig, ich zeige kaum Verstehen, wie es zu einer bestimmten Reaktion kam. Ich sehe mich nur partiell als ein Wesen mit kontinuierlicher Identität. Es gibt viele verschiedene Bilder von mir, kein konstantes und überdauerndes Bild. Das Bild, das ich von mir habe, ist entweder stark überzeichnet oder entwertend.",
|
||||
"Eine Kränkung bringt mich schnell aus dem Gleichgewicht, aber es ist mir möglich zu sagen, dass der andere nicht höchst aggressiv war, sondern dass ich selbst einfach sehr empfindlich bin. Ich reagiere meist mit impulsivem Verhalten darauf, würde aber gerne gelassener reagieren können. Lob kann ich nicht annehmen, auch wenn es insgeheim gut tut.",
|
||||
"Die Bedürfnisse und Gefühle anderer beachte ich. Ich bewerte sie jedoch aus meiner eigenen Perspektive – manchmal ist es mir nicht vorstellbar, dass es auch andere Sichtweisen desselben Sachverhalts gibt. Grenzen kann ich teilweise beachten.",
|
||||
"ENTWEDER: Ich fühle mich meinen eigenen Gefühlen ausgeliefert und kann diese kaum regulieren, was dazu führt, dass das Gegenüber die Emotionen sehr stark mitbekommt. Ich biete keine Möglichkeit, darüber zu sprechen, weshalb Missverständnisse und aneinander vorbeireden vorherrschen. ODER: Ich fühle mich innerlich \"cool\" und kann kaum Gefühle bei mir wahrnehmen, weshalb diese auch nicht mitgeteilt werden können. Diese Leere wird evtl. durch gedankliches Argumentieren überspielt oder so-tun-als-ob, d. h. das Fehlen ist mir bewusst, wodurch aber kein Gefühl der Empathie entstehen kann.",
|
||||
"Meine eigenen Interessen nehme ich wahr. Sie werden jedoch durch die Interessen anderer bedroht. Streit gehe ich aus dem Weg, Disharmonie ist für mich nicht aushaltbar.",
|
||||
"Ich habe stabile innere Bilder meiner Bezugspersonen und ich kann eine Beziehung aufrecht erhalten. Wenn zu viel Zeit vergeht, wird diese Fähigkeit jedoch geschwächt und ich verliere den Bezug zu diesen Menschen. Dies bedeutet, dass meine Beziehung von der häufigen realen Anwesenheit des Anderen abhängig ist. Folge ist, dass ich nicht allein sein kann, da immer wenn ich allein bin, überwältigende Angst auftritt.",
|
||||
"Bei mir herrschen rasch wechselnde, kürzere Beziehungen vor. Der Partner wird von mir evtl. abwechselnd idealisiert oder abgewertet. Alleine sein fällt mir schwer, aber Beziehungen sind bald nicht mehr aushaltbar. Beziehungen kann ich nicht mit Bedacht pflegen.",
|
||||
"Es dauert viel zu lange, bis eine Beziehung, die schon längst keine ausreichende Qualität mehr hat und nicht mehr reparierbar ist, von mir beendet wird, es dauert meist Jahre.",
|
||||
"Ich habe wenige Ressourcen aufgebaut. Die vorhandenen Ressourcen kann ich entweder als solche nicht erkennen oder nicht nutzen.",
|
||||
"Ich kann mich von einer Krise überhaupt nicht aus eigener Kraft erholen und benötige aufwändige Hilfe und Unterstützung von anderen, um wieder herauszufinden.",
|
||||
"Ich kann ein großes Leid nicht ertragen oder mich damit abfinden. Ich verliere viel Kraft durch wirkungsloses dagegen Ankämpfen."
|
||||
),
|
||||
ziel = c(
|
||||
"Ich kann Gefühle situationsadäquat spüren und zeigen, sodass das Gegenüber deutlich das eigene Handeln nachvollziehen kann. Ich kann andererseits Gefühle aushalten (auch negative oder ambivalente) ohne gleich handeln zu müssen.",
|
||||
"Das Bild, das ich von mir habe, ist relativ stabil, über die Zeit konstant und realistisch. Ich kann Eigenschaften und Fähigkeiten benennen, die mich ausmachen. Auch in Stresssituationen ist mir dies möglich. Ich kann gut über meine eigenen Gefühle und Motive reflektieren.",
|
||||
"Lob kann ich annehmen, ich bin von Lob aber nicht abhängig. Kritik von anderen überprüfe ich. Es ist mir möglich, sofern die Kritik unberechtigt ist, diese nicht an mich heran zu lassen, sodass kein Gefühl der Kränkung entsteht.",
|
||||
"Ich kann mich in andere hineinversetzen und an deren Erleben teilhaben. Grenzen des anderen und eigene Grenzen kann ich gut beachten.",
|
||||
"Emotionale Kontaktaufnahme und kommunikativer Austausch mit anderen gelingt mir gut. Ich kann gut über meine Gefühle und Gedanken mit anderen Personen sprechen, sodass es dem anderen leicht fällt, sich empathisch in mich einzufühlen.",
|
||||
"Eigene und fremde Interessen nehme ich fast immer wahr und berücksichtige sie. Mir gelingen gute Beziehungen zu anderen, bei denen Kompromisse im Falle gegenteiliger Meinungen geschlossen werden können. Falls dies nicht möglich ist, kann ich Disharmonie aushalten.",
|
||||
"Ich habe innere Bilder mir wichtiger Menschen - und das Gefühl einer sicheren Bindung mit ihnen. Ich habe eine stabile Beziehung zu mehreren Menschen, die für mich verfügbar sind, die ich gut voneinander unterscheiden kann.",
|
||||
"Längere, intime Beziehungen sind mir möglich, die ich auch pflege. Ich kann mehrere wichtige Menschen beschreiben, zu denen nahe Beziehungen bestehen.",
|
||||
"Fällige und notwendige Trennungen sind mir möglich, die ich auch betrauern kann.",
|
||||
"Ich kann den Wert und die Menge meiner vorhandenen Ressourcen realistisch wahrnehmen und sie einsetzen.",
|
||||
"Ich kann mich aus Krisen mit angemessenen Anstrengungen und adäquatem Zeitbedarf herausarbeiten und erhole mich dann bald. Ich kann zusätzliche Hilfe anderer nutzen.",
|
||||
"Großes anhaltendes Leid, dem nicht zu entkommen ist, akzeptiere ich und ertrage es duldsam, ohne mich in wirkungsloses dagegen Ankämpfen zu verlieren."
|
||||
),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
|
||||
# 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; }
|
||||
.block-abschnitt { margin-bottom: 22px; }
|
||||
.block-abschnitt:last-child { margin-bottom: 0; }
|
||||
.block-titel {
|
||||
font-weight: 700; color: #333; font-size: 1.02em;
|
||||
padding-bottom: 4px; border-bottom: 1px solid #eee; margin-bottom: 4px;
|
||||
}
|
||||
.block-zaehler { color: #8B2635; font-weight: 600; font-size: 0.88em; margin-bottom: 8px; }
|
||||
.item-zeile {
|
||||
display: flex; align-items: flex-start; gap: 10px;
|
||||
padding: 8px 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; }
|
||||
.item-kurztitel { font-weight: 700; color: #555; margin-bottom: 3px; font-style: italic; }
|
||||
.item-problem { margin-bottom: 3px; }
|
||||
.zsf-zeile { padding: 8px 0; border-bottom: 1px solid #F0F0F0; }
|
||||
.zsf-zeile:last-child { border-bottom: none; }
|
||||
.zsf-titel { font-weight: 700; color: #8B2635; font-size: 0.92em; margin-bottom: 3px; }
|
||||
.zsf-text { color: #333; font-size: 0.92em; }
|
||||
.zsf-leer { color: #999; font-style: italic; font-size: 0.92em; }
|
||||
.freitext-block { margin-bottom: 16px; }
|
||||
.freitext-block:last-child { margin-bottom: 0; }
|
||||
.freitext-frage { font-weight: 600; color: #333; margin-bottom: 4px; font-size: 0.92em; }
|
||||
.freitext-antwort {
|
||||
color: #333; white-space: pre-wrap; padding: 9px 12px; font-size: 0.92em;
|
||||
background: #fafafa; border-radius: 4px; border-left: 3px solid #ddd;
|
||||
}
|
||||
.disclaimer-zeile {
|
||||
font-size: 0.82em; color: #777; font-style: italic;
|
||||
margin-top: 10px; 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("VDS51 – Meine Therapieziele"),
|
||||
tags$p("Verhaltensdiagnostiksystem VDS | Prof. Dr. Dr. Serge Sulz")
|
||||
),
|
||||
|
||||
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_vds51_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_block = fp_text(bold = TRUE, font.size = 11.5, color = "#333333")
|
||||
fp_zaehler = fp_text(italic = TRUE, font.size = 9.5, color = AKZENT_FARBE)
|
||||
fp_label = fp_text(bold = TRUE, font.size = 10.5)
|
||||
fp_normal = fp_text(font.size = 10.5)
|
||||
fp_kurztitel = fp_text(italic = TRUE, bold = TRUE, font.size = 10.5, color = "#555555")
|
||||
fp_leer = fp_text(italic = TRUE, font.size = 10.5, color = "#999999")
|
||||
fp_disclaimer = fp_text(font.size = 9, italic = TRUE, color = "#777777")
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext("VDS51 - Meine Therapieziele", 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)
|
||||
))
|
||||
for (w in erg$warnungen) {
|
||||
doc = body_add_fpar(doc, fpar(ftext(w,
|
||||
fp_text(font.size = 9, italic = TRUE, color = "#BF360C"))))
|
||||
}
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
|
||||
hauptgruppen = unique(vapply(erg$bloecke, function(b) b$hauptgruppe, character(1)))
|
||||
for (hg in hauptgruppen) {
|
||||
doc = body_add_fpar(doc, fpar(ftext(hg, fp_abschnitt)))
|
||||
bloecke_hg = Filter(function(b) identical(b$hauptgruppe, hg), erg$bloecke)
|
||||
for (b in bloecke_hg) {
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(paste0(b$code, " ", b$titel), fp_block),
|
||||
ftext(paste0(" (", b$n_angekreuzt, " von ", b$n_items, " Zielen ausgewählt)"), fp_zaehler)
|
||||
))
|
||||
for (it in b$items) {
|
||||
if (!is.na(it$kurztitel)) {
|
||||
doc = body_add_fpar(doc, fpar(ftext(it$kurztitel, fp_kurztitel)))
|
||||
}
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext(paste0(it$nr, ". Problem: "), fp_label),
|
||||
ftext(it$problem, fp_normal)
|
||||
))
|
||||
doc = body_add_fpar(doc, fpar(
|
||||
ftext("Ziel: ", fp_label),
|
||||
ftext(it$ziel, fp_normal)
|
||||
))
|
||||
}
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
}
|
||||
}
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext("Vom Patienten priorisierte Ziele", fp_abschnitt)))
|
||||
for (z in erg$zsf) {
|
||||
doc = body_add_fpar(doc, fpar(ftext(paste0(z$code, " ", z$titel), fp_label)))
|
||||
if (is.na(z$text)) {
|
||||
doc = body_add_fpar(doc, fpar(ftext("Kein Ziel priorisiert", fp_leer)))
|
||||
} else {
|
||||
doc = body_add_fpar(doc, fpar(ftext(z$text, fp_normal)))
|
||||
}
|
||||
}
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
|
||||
doc = body_add_fpar(doc, fpar(ftext("Frei formulierte Ziele", fp_abschnitt)))
|
||||
if (length(erg$freitexte) == 0) {
|
||||
doc = body_add_fpar(doc, fpar(ftext("Keine frei formulierten Ziele angegeben.", fp_leer)))
|
||||
} else {
|
||||
for (f in erg$freitexte) {
|
||||
doc = body_add_fpar(doc, fpar(ftext(paste0("Ziel ", f$nr, ":"), fp_label)))
|
||||
doc = body_add_fpar(doc, fpar(ftext(f$text, fp_normal)))
|
||||
}
|
||||
}
|
||||
|
||||
doc = body_add_par(doc, "", style = "Normal")
|
||||
doc = body_add_fpar(doc, fpar(ftext(VDS51_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 = "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)))
|
||||
}
|
||||
|
||||
ok_download = tryCatch({
|
||||
source(PFAD_DOWNLOAD_SKRIPT, local = FALSE)
|
||||
list(ok = TRUE)
|
||||
}, error = function(e) list(ok = FALSE, msg = conditionMessage(e)))
|
||||
if (!ok_download$ok) {
|
||||
return(list(typ = "skript_fehler",
|
||||
meldung = paste0("Fehler im Download-Skript: ", ok_download$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 = paste0(
|
||||
"pseudonyme.db nicht gefunden. Gesucht ausgehend vom Pseudonym-Skript-Ordner ",
|
||||
"bis zu 5 Ebenen nach oben."
|
||||
)))
|
||||
}
|
||||
|
||||
alter_wd = getwd()
|
||||
on.exit(setwd(alter_wd), add = TRUE)
|
||||
setwd(db_ordner)
|
||||
|
||||
ok_pseudonym = tryCatch({
|
||||
source(PFAD_PSEUDONYM_SKRIPT, local = FALSE)
|
||||
list(ok = TRUE)
|
||||
}, error = function(e) list(ok = FALSE, msg = conditionMessage(e)))
|
||||
if (!ok_pseudonym$ok) {
|
||||
return(list(typ = "skript_fehler",
|
||||
meldung = paste0("Fehler im Pseudonym-Skript: ", ok_pseudonym$msg)))
|
||||
}
|
||||
|
||||
if (!exists("daten_vds51", envir = .GlobalEnv)) {
|
||||
return(list(typ = "skript_fehler", meldung = paste0(
|
||||
"Objekt 'daten_vds51' wurde nach dem Sourcen des Download-Skripts nicht gefunden."
|
||||
)))
|
||||
}
|
||||
if (!exists("pseudo", envir = .GlobalEnv)) {
|
||||
return(list(typ = "skript_fehler", meldung = paste0(
|
||||
"Objekt 'pseudo' wurde nach dem Sourcen des Pseudonym-Skripts nicht gefunden."
|
||||
)))
|
||||
}
|
||||
|
||||
daten = get("daten_vds51", envir = .GlobalEnv)
|
||||
pseudo_df = get("pseudo", envir = .GlobalEnv)
|
||||
|
||||
if (!("session" %in% names(daten))) {
|
||||
return(list(typ = "skript_fehler",
|
||||
meldung = "Spalte 'session' wurde in daten_vds51 nicht gefunden."))
|
||||
}
|
||||
|
||||
alle_item_spalten = unlist(lapply(seq_len(nrow(VDS51_BLOECKE)), function(i) {
|
||||
vds51_item_spalten(VDS51_BLOECKE$feldpraefix[i], VDS51_BLOECKE$n_items[i])
|
||||
}))
|
||||
fehlende_spalten = alle_item_spalten[!(alle_item_spalten %in% names(daten))]
|
||||
if (length(fehlende_spalten) > 0) {
|
||||
return(list(typ = "skript_fehler", meldung = paste0(
|
||||
length(fehlende_spalten), " erwartete Item-Spalte(n) fehlen in daten_vds51 (z. B. ",
|
||||
paste(head(fehlende_spalten, 5), collapse = ", "), "). Bitte Datenexport prüfen."
|
||||
)))
|
||||
}
|
||||
|
||||
warnungen = c()
|
||||
pseudonym_wert = trimws(input$pseudonym)
|
||||
|
||||
# Wenn ein Pseudonym eingegeben wurde: Chiffre daraus zurueckerhalten, damit
|
||||
# Kopfzeile/Dateiname auch bei reiner Pseudonym-Eingabe korrekt sind.
|
||||
if (nchar(pseudonym_wert) > 0) {
|
||||
pw_treffer = pseudo_df[pseudo_df$pseudonym == pseudonym_wert, ]
|
||||
if (nrow(pw_treffer) == 0) {
|
||||
return(list(typ = "pseudonym_unbekannt", meldung = paste0(
|
||||
"Pseudonym '", pseudonym_wert, "' wurde in der Pseudonym-Datenbank nicht gefunden."
|
||||
)))
|
||||
}
|
||||
chiffre = toupper(trimws(pw_treffer$chiffre[1]))
|
||||
}
|
||||
|
||||
treffer_ps = pseudo_df[pseudo_df$chiffre == chiffre, ]
|
||||
if (nrow(treffer_ps) == 0) {
|
||||
return(list(typ = "chiffre_unbekannt", meldung = paste0(
|
||||
"Chiffre '", chiffre, "' wurde in der Pseudonym-Datenbank nicht gefunden."
|
||||
)))
|
||||
}
|
||||
|
||||
alle_session_ids = unique(treffer_ps$pseudonym)
|
||||
|
||||
# Eindeutigkeits-Override: explizit eingegebenes Pseudonym hat immer Vorrang.
|
||||
if (nchar(pseudonym_wert) > 0) alle_session_ids = pseudonym_wert
|
||||
|
||||
treffer_dat = daten[daten$session %in% alle_session_ids, ]
|
||||
if (nrow(treffer_dat) == 0) {
|
||||
return(list(typ = "kein_datensatz", meldung = paste0(
|
||||
"Kein VDS51-Datensatz für Chiffre '", chiffre, "' gefunden. ",
|
||||
"(", length(alle_session_ids), " Pseudonym(e) geprüft)"
|
||||
)))
|
||||
}
|
||||
|
||||
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"
|
||||
)
|
||||
warnungen = c(warnungen, 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]
|
||||
|
||||
ausfuelldatum = tryCatch(
|
||||
format(as.POSIXct(zeile[["created"]][1]), "%d.%m.%Y"),
|
||||
error = function(e) format(Sys.Date(), "%d.%m.%Y")
|
||||
)
|
||||
|
||||
bloecke_ergebnis = lapply(seq_len(nrow(VDS51_BLOECKE)), function(i) {
|
||||
vds51_verarbeite_block(daten, zeile, VDS51_BLOECKE[i, ])
|
||||
})
|
||||
|
||||
n_unklar_gesamt = sum(vapply(bloecke_ergebnis, function(b) b$n_unklar, integer(1)))
|
||||
if (n_unklar_gesamt > 0) {
|
||||
warnungen = c(warnungen, paste0(
|
||||
n_unklar_gesamt, " Item(s) mit nicht interpretierbarem Rohwert gefunden - diese ",
|
||||
"wurden nicht mitgezählt (weder als angekreuzt noch als nicht angekreuzt gewertet)."
|
||||
))
|
||||
}
|
||||
|
||||
zsf_ergebnis = lapply(seq_len(nrow(VDS51_BLOECKE)), function(i) {
|
||||
vds51_verarbeite_zsf(daten, zeile, VDS51_BLOECKE[i, ])
|
||||
})
|
||||
n_zsf_fehlt = sum(vapply(zsf_ergebnis, function(z) z$feld_fehlt, logical(1)))
|
||||
if (n_zsf_fehlt > 0) {
|
||||
warnungen = c(warnungen, paste0(
|
||||
n_zsf_fehlt, " Dropdown-Feld(er) aus Modul 2 (Zielformulierung) wurden in ",
|
||||
"daten_vds51 nicht gefunden."
|
||||
))
|
||||
}
|
||||
|
||||
freitexte = list()
|
||||
for (i in 1:5) {
|
||||
feld = paste0("vds51_end_ziel_", i)
|
||||
if (!(feld %in% names(daten))) next
|
||||
w = zeile[[feld]][1]
|
||||
if (is.null(w) || is.na(w)) next
|
||||
txt = trimws(as.character(w))
|
||||
if (nchar(txt) == 0) next
|
||||
freitexte[[length(freitexte) + 1]] = list(nr = i, text = txt)
|
||||
}
|
||||
|
||||
list(
|
||||
typ = "ok",
|
||||
chiffre = chiffre,
|
||||
ausfuelldatum = ausfuelldatum,
|
||||
warnungen = warnungen,
|
||||
bloecke = bloecke_ergebnis,
|
||||
zsf = zsf_ergebnis,
|
||||
freitexte = freitexte
|
||||
)
|
||||
})
|
||||
|
||||
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(
|
||||
"Ungültige Chiffre '", d$chiffre, "'. Erwartet: ein Großbuchstabe + 6 Ziffern (z. B. P000123)."
|
||||
),
|
||||
d$meldung
|
||||
)
|
||||
div(class = "alert-fehler", txt)
|
||||
})
|
||||
|
||||
output$warnung_ui = renderUI({
|
||||
req(input$btn_suchen)
|
||||
d = ergebnis_r()
|
||||
if (!identical(d$typ, "ok") || length(d$warnungen) == 0) return(NULL)
|
||||
div(lapply(d$warnungen, function(w) div(class = "alert-warnung", w)))
|
||||
})
|
||||
|
||||
output$ergebnis_ui = renderUI({
|
||||
req(input$btn_suchen)
|
||||
d = ergebnis_r()
|
||||
if (!identical(d$typ, "ok")) return(NULL)
|
||||
|
||||
item_zeile_ui = function(it) {
|
||||
div(class = "item-zeile",
|
||||
div(class = "item-nr", paste0(it$nr, ".")),
|
||||
div(class = "item-text",
|
||||
if (!is.na(it$kurztitel)) div(class = "item-kurztitel", it$kurztitel),
|
||||
div(class = "item-problem", tags$strong("Problem: "), it$problem),
|
||||
div(tags$strong("Ziel: "), it$ziel)
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
hauptgruppen = unique(vapply(d$bloecke, function(b) b$hauptgruppe, character(1)))
|
||||
|
||||
hauptgruppen_ui = lapply(hauptgruppen, function(hg) {
|
||||
bloecke_hg = Filter(function(b) identical(b$hauptgruppe, hg), d$bloecke)
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", hg),
|
||||
lapply(bloecke_hg, function(b) {
|
||||
div(class = "block-abschnitt",
|
||||
div(class = "block-titel", paste0(b$code, " ", b$titel)),
|
||||
div(class = "block-zaehler",
|
||||
paste0(b$n_angekreuzt, " von ", b$n_items, " Zielen ausgewählt")),
|
||||
if (length(b$items) > 0) div(lapply(b$items, item_zeile_ui))
|
||||
)
|
||||
})
|
||||
)
|
||||
})
|
||||
|
||||
zsf_ui = div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Vom Patienten priorisierte Ziele"),
|
||||
lapply(d$zsf, function(z) {
|
||||
div(class = "zsf-zeile",
|
||||
div(class = "zsf-titel", paste0(z$code, " ", z$titel)),
|
||||
if (is.na(z$text))
|
||||
div(class = "zsf-leer", "Kein Ziel priorisiert")
|
||||
else
|
||||
div(class = "zsf-text", z$text)
|
||||
)
|
||||
})
|
||||
)
|
||||
|
||||
freitext_ui = div(class = "abschnitt-karte",
|
||||
div(class = "abschnitt-titel", "Frei formulierte Ziele"),
|
||||
if (length(d$freitexte) == 0)
|
||||
div(class = "zsf-leer", "Keine frei formulierten Ziele angegeben.")
|
||||
else
|
||||
lapply(d$freitexte, function(f) {
|
||||
div(class = "freitext-block",
|
||||
div(class = "freitext-frage", paste0("Ziel ", f$nr)),
|
||||
div(class = "freitext-antwort", f$text)
|
||||
)
|
||||
})
|
||||
)
|
||||
|
||||
disclaimer_ui = div(class = "abschnitt-karte",
|
||||
div(class = "disclaimer-zeile", VDS51_DISCLAIMER)
|
||||
)
|
||||
|
||||
tagList(
|
||||
div(class = "abschnitt-karte",
|
||||
div(class = "meta-block",
|
||||
tags$strong("Chiffre: "), d$chiffre,
|
||||
tags$span(" | ", style = "color:#ccc;"),
|
||||
tags$strong("Ausfülldatum: "), d$ausfuelldatum
|
||||
)
|
||||
),
|
||||
hauptgruppen_ui,
|
||||
zsf_ui,
|
||||
freitext_ui,
|
||||
disclaimer_ui
|
||||
)
|
||||
})
|
||||
|
||||
output$download_word = downloadHandler(
|
||||
filename = function() {
|
||||
d = tryCatch(ergebnis_r(), error = function(e) NULL)
|
||||
if (!is.list(d) || !identical(d$typ, "ok")) return("VDS51_export.docx")
|
||||
chiffre_esc = gsub("[^A-Za-z0-9_-]", "_", d$chiffre)
|
||||
ausfuelldatum_fn = tryCatch(
|
||||
format(as.Date(d$ausfuelldatum, "%d.%m.%Y"), "%Y%m%d"),
|
||||
error = function(e) format(Sys.Date(), "%Y%m%d")
|
||||
)
|
||||
paste0("VDS51_", chiffre_esc, "_", ausfuelldatum_fn, ".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_vds51_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)
|
||||
3019
VDS51/renv.lock
Normal file
3019
VDS51/renv.lock
Normal file
File diff suppressed because it is too large
Load diff
14
VDS51/setup_renv.R
Normal file
14
VDS51/setup_renv.R
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
# Einmalig ausfuehren, bevor die App zum ersten Mal gestartet wird.
|
||||
# Initialisiert renv und installiert alle benoetigten Pakete.
|
||||
#
|
||||
# DBI und RSQLite werden vom gesourcten Pseudonym-Skript benoetigt,
|
||||
# nicht direkt von der App selbst.
|
||||
|
||||
renv::init()
|
||||
|
||||
pkgs = c("shiny", "dplyr", "ggplot2", "haven", "officer", "DBI", "RSQLite", "formr")
|
||||
install.packages(pkgs)
|
||||
|
||||
renv::snapshot()
|
||||
|
||||
message("Setup abgeschlossen. App starten mit: shiny::runApp()")
|
||||
Loading…
Add table
Add a link
Reference in a new issue