├── .gitignore ├── Graphics └── tiny_MOSAIC_short.png ├── R ├── datamgmt_progress.R └── plot_asmts_comp.R ├── README.md ├── StudyProgress.Rproj ├── favicon_48x48.png ├── mosaic_makedash.R └── progressdash.Rmd /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | .Renviron 6 | *.html 7 | *.md 8 | *.txt 9 | figure/ 10 | Graphics/ 11 | testdata/ 12 | *.js 13 | 14 | -------------------------------------------------------------------------------- /Graphics/tiny_MOSAIC_short.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jenniferthompson/MOSAICProgress/80d83348554fc5df1739b727f8a2f3106f9a4995/Graphics/tiny_MOSAIC_short.png -------------------------------------------------------------------------------- /R/datamgmt_progress.R: -------------------------------------------------------------------------------- 1 | ################################################################################ 2 | ## Data management to create MOSAIC study progress dashboard 3 | ################################################################################ 4 | 5 | library(httr) 6 | library(tidyverse) 7 | library(lubridate) 8 | 9 | ## -- Import each data set from REDCap (exclusions, in-hospital, follow-up) ---- 10 | ## All tokens are stored in .Renviron 11 | 12 | ## We'll be doing the same thing for each, so write some functions 13 | ## 1. Function to create postForm() object given a database token 14 | get_pF <- function(rctoken){ 15 | httr::POST( 16 | url = "https://redcap.vanderbilt.edu/api/", 17 | body = list( 18 | token = Sys.getenv(rctoken), ## API token gives you permission 19 | content = "record", ## export *records* 20 | format = "csv", ## export as *CSV* 21 | rawOrLabel = "label", ## export factor *labels* v codes 22 | exportCheckboxLabel = TRUE, ## exp. checkbox labels vs U/C 23 | exportDataAccessGroups = FALSE ## don't need data access grps 24 | ) 25 | ) 26 | } 27 | 28 | get_csv <- function(pF){ 29 | read.csv(text = as.character(pF), na.strings = "", stringsAsFactors = FALSE) 30 | } 31 | 32 | import_df <- function(rctoken){ 33 | tmp_pF <- get_pF(rctoken) 34 | tmp_csv <- get_csv(tmp_pF) 35 | 36 | ## REDCap loves to use so many underscores; one per instance seems like plenty 37 | names(tmp_csv) <- gsub("_+", "_", names(tmp_csv)) 38 | 39 | tmp_csv 40 | } 41 | 42 | ## Comment out while building dashboard to save time 43 | inhosp_df <- import_df("MOSAIC_IH_TOKEN") 44 | exc_df <- import_df("MOSAIC_EXC_TOKEN") 45 | fu_df <- import_df("MOSAIC_FU_TOKEN") 46 | # save(inhosp_df, exc_df, fu_df, file = "testdata/testdata.Rdata") 47 | # load("../testdata/testdata.Rdata") 48 | 49 | ## Remove test patients from each database 50 | inhosp_df <- inhosp_df[grep("test", tolower(inhosp_df$id), invert = TRUE),] 51 | exc_df <- exc_df[grep("test", tolower(exc_df$exc_id), invert = TRUE),] 52 | 53 | ## Data management prep: Create POSIXct versions of most relevant date/times 54 | dtvars <- c("enroll_dttm", "death_dttm", "hospdis_dttm") 55 | datevars <- c("daily_date") 56 | 57 | inhosp_df <- inhosp_df %>% 58 | mutate_at(dtvars, "ymd_hm") %>% 59 | mutate_at(dtvars, funs(date = "as_date")) %>% 60 | rename_at(dtvars, ~ gsub("tm$", "", .)) %>% 61 | rename_at(paste0(dtvars, "_date"), ~ gsub("_dttm", "", ., fixed = TRUE)) %>% 62 | mutate(studywd_date = ymd(studywd_dttm)) %>% 63 | mutate_at(datevars, ymd) %>% 64 | select(-studywd_dttm) 65 | 66 | ################################################################################ 67 | ## Screening and Exclusions 68 | ################################################################################ 69 | 70 | ## -- Barchart for screening and enrollment by month --------------------------- 71 | ## We want to plot the number of patients screened, approached, and enrolled by 72 | ## month. Need a list of all unique IDs (exclusions + enrolled). 73 | 74 | ## Screened: Everyone recorded 75 | ## Approached: Enrolled + refusals 76 | ## Refused: exclusion #14 checked 77 | ## (Inability to obtain informed consent: Patient and/or surrogate refusal) 78 | ## Enrolled: Included in in-hospital database 79 | 80 | ## Get list of any patients with no exclusion date entered, then remove them 81 | exc_id_nodate <- exc_df %>% 82 | filter(is.na(exc_date)) %>% 83 | pull(exc_id) 84 | 85 | exc_combine <- exc_df %>% 86 | filter(!is.na(exc_date)) %>% 87 | separate(exc_date, into = c("year", "month", "day"), sep = "-") %>% 88 | mutate(Screened = TRUE, 89 | Approached = !is.na(exc_rsn_14), 90 | Refused = !is.na(exc_rsn_14), 91 | Enrolled = FALSE) %>% 92 | rename(id = exc_id) %>% 93 | dplyr::select(id, year, month, Screened, Approached, Refused, Enrolled) 94 | 95 | inhosp_combine <- inhosp_df %>% 96 | filter(redcap_event_name == 'Enrollment /Trial Day 1') %>% 97 | separate(enroll_dt, into = c("year", "month", "day", "time"), sep = "-| ") %>% 98 | mutate(Screened = TRUE, 99 | Approached = TRUE, 100 | Refused = FALSE, 101 | Enrolled = TRUE) %>% 102 | dplyr::select(id, year, month, Screened, Approached, Refused, Enrolled) 103 | 104 | screening_combine <- bind_rows(exc_combine, inhosp_combine) %>% 105 | mutate(mabb = month.abb[as.numeric(month)], 106 | myear = paste(year, month, sep = "-"), 107 | myear_char = ifelse(mabb == "Mar", paste(mabb, year), mabb)) 108 | 109 | screening_summary <- screening_combine %>% 110 | group_by(myear, myear_char) %>% 111 | summarise_at(c("Screened", "Approached", "Refused", "Enrolled"), sum) %>% 112 | arrange(myear) 113 | 114 | ## How many patients have been enrolled so far? What is our enrollment goal? 115 | n_screened <- sum(screening_combine$Screened) 116 | pct_approached <- mean(screening_combine$Approached) 117 | pct_excluded <- 1 - pct_approached 118 | pct_refused <- mean(subset(screening_combine, Approached)$Refused) 119 | n_enrolled <- sum(screening_combine$Enrolled) 120 | pct_enrolled <- mean(subset(screening_combine, Approached)$Enrolled) 121 | n_goal <- 312 122 | 123 | ## -- Line chart for exclusion percentages over time --------------------------- 124 | ## Create long-format data set of all exclusions, one row each 125 | exc_df_long <- exc_df %>% 126 | gather(key = exc_reason, value = was_excluded, exc_rsn_1:exc_rsn_99) %>% 127 | separate(exc_date, into = c("year", "month", "day"), sep = "-") %>% 128 | mutate(was_excluded = !is.na(was_excluded), 129 | mabb = month.abb[as.numeric(month)], 130 | myear = paste(year, month, sep = "-"), 131 | myear_char = ifelse(mabb == "Mar", paste(mabb, year), mabb), 132 | Reason = ifelse(exc_reason == "exc_rsn_1", "Rapidly resolving organ failure", 133 | ifelse(exc_reason == "exc_rsn_2", ">5 hospital days in last 30", 134 | ifelse(exc_reason == "exc_rsn_3", "Inability to live independently", 135 | ifelse(exc_reason == "exc_rsn_4", "Severe neurologic injury", 136 | ifelse(exc_reason == "exc_rsn_5", "BMI > 50", 137 | ifelse(exc_reason == "exc_rsn_6", "Substance abuse, etc", 138 | ifelse(exc_reason == "exc_rsn_7", "Blind, deaf, English", 139 | ifelse(exc_reason == "exc_rsn_8", "Death within 24h/hospice", 140 | ifelse(exc_reason == "exc_rsn_9", "Prisoner", 141 | ifelse(exc_reason == "exc_rsn_10", "Lives >150 miles from VUMC", 142 | ifelse(exc_reason == "exc_rsn_11", "Homeless", 143 | ifelse(exc_reason == "exc_rsn_12", "Study with no co-enrollment", 144 | ifelse(exc_reason == "exc_rsn_13", "Attending refusal", 145 | ifelse(exc_reason == "exc_rsn_14", "Patient/surrogate refusal", 146 | ifelse(exc_reason == "exc_rsn_15", "No surrogate within 72h", 147 | ifelse(exc_reason == "exc_rsn_16", ">72h eligibility prior to screening", 148 | ifelse(exc_reason == "exc_rsn_99", "Other", 149 | NA)))))))))))))))))) %>% 150 | filter(was_excluded) 151 | 152 | ## Data set for exclusions over time: Proportion of each exclusion each month 153 | ## How many exclusions total per month? 154 | exc_per_month <- exc_df_long %>% 155 | dplyr::select(exc_id, myear, was_excluded) %>% 156 | unique() %>% 157 | group_by(myear) %>% 158 | summarise(n_all_exclusions = sum(was_excluded)) 159 | 160 | exc_over_time <- exc_df_long %>% 161 | group_by(myear, myear_char, Reason) %>% 162 | summarise(n_this_exclusion = sum(was_excluded)) %>% 163 | left_join(exc_per_month, by = "myear") %>% 164 | mutate(Percent = round((n_this_exclusion / n_all_exclusions)*100)) %>% 165 | ungroup() %>% 166 | arrange(myear) 167 | 168 | ## -- Treemap for cumulative exclusions ---------------------------------------- 169 | exc_cumul <- exc_df_long %>% 170 | group_by(Reason) %>% 171 | summarise(n_reason = n()) %>% 172 | mutate(n_patients_exc = nrow(exc_df), 173 | reason_type = case_when( 174 | .$Reason %in% c( 175 | "Inability to live independently", 176 | "Homeless", 177 | "BMI > 50", 178 | "Blind, deaf, English", 179 | "Substance abuse, etc" 180 | ) ~ "Patient characteristics", 181 | .$Reason %in% c( 182 | ">5 hospital days in last 30", 183 | "Death within 24h/hospice", 184 | "Rapidly resolving organ failure", 185 | "Severe neurologic injury" 186 | ) ~ "Medical exclusions", 187 | .$Reason %in% c("Lives >150 miles from VUMC") ~ "Geography", 188 | .$Reason %in% c( 189 | "Attending refusal", 190 | "No surrogate within 72h", 191 | "Patient/surrogate refusal", 192 | ">72h eligibility prior to screening" 193 | ) ~ "Informed consent", 194 | TRUE ~ "Other exclusions" 195 | )) 196 | 197 | ################################################################################ 198 | ## Phase I (In-Hospital) 199 | ################################################################################ 200 | 201 | ## -- Currently: died/withdrew in hospital, discharged, still in hospital ------ 202 | ## Get IDs for anyone with no enrollment date entered 203 | enroll_id_nodate <- inhosp_df %>% 204 | filter(redcap_event_name == "Enrollment /Trial Day 1" & is.na(enroll_date)) %>% 205 | pull(id) 206 | 207 | all_enrolled <- inhosp_df %>% 208 | ## Restrict to patients with an enrollment date entered 209 | filter( 210 | redcap_event_name == "Enrollment /Trial Day 1" & !is.na(enroll_date) 211 | ) %>% 212 | mutate(inhosp_status = factor(ifelse(!is.na(hospdis_date), 1, 213 | ifelse(!is.na(death_date), 2, 214 | ifelse(!is.na(studywd_date), 3, 4))), 215 | levels = 1:4, 216 | labels = c("Discharged alive", 217 | "Died in hospital", 218 | "Withdrew in hospital", 219 | "Still in hospital"))) 220 | 221 | status_count <- all_enrolled %>% 222 | group_by(inhosp_status) %>% 223 | summarise(n_status = n()) 224 | 225 | ## -- Completion of pre-hospital surrogate, caregiver batteries ---------------- 226 | ## Surrogate battery: General questions, PASE, basic/IADLs, life space, 227 | ## employment questionnaire, AUDIT, IQCODE; BDI, if enrolled >= 6/19/2018 228 | ## Caregiver battery: Zarit, memory/behavior checklist 229 | ## "Complete" = every section fully or partially completed 230 | surrogate_compvars <- paste0( 231 | c("gq", "pase", "adl", "ls", "emp", "audit", "iqcode", "bdi"), 232 | "_comp_ph" 233 | ) 234 | caregiver_compvars <- paste0(c("zarit", "memory"), "_comp_ph") 235 | 236 | all_enrolled <- all_enrolled %>% 237 | mutate_at( 238 | vars(one_of(c(surrogate_compvars, caregiver_compvars))), 239 | funs(!is.na(.) & str_detect(., "^Yes")) 240 | ) %>% 241 | ## BDI was not included in the battery until June 19, 2018; set these to 242 | ## missing, rather than FALSE 243 | mutate( 244 | bdi_comp_ph = if_else(enroll_date < as.Date("2018-06-19"), NA, bdi_comp_ph) 245 | ) %>% 246 | mutate( 247 | ph_surrogate_comp = case_when( 248 | enroll_date < as.Date("2018-06-19") ~ 249 | rowSums(.[, setdiff(surrogate_compvars, "bdi_comp_ph")]) == 250 | length(surrogate_compvars) - 1, 251 | TRUE ~ rowSums(.[, surrogate_compvars]) == length(surrogate_compvars) 252 | ), 253 | ph_caregiver_comp = 254 | rowSums(.[, caregiver_compvars]) == length(caregiver_compvars) 255 | ) 256 | 257 | ## -- Specimen log: compliance = >0 tubes drawn on days 1, 3, 5, discharge ----- 258 | ## Get "proper" study *dates* for each ID 259 | study_dates <- tibble( 260 | study_date = 261 | map(pull(all_enrolled, enroll_date), ~ seq(., by = 1, length.out = 29)) %>% 262 | flatten_int() %>% 263 | as.Date(origin = "1970-1-1") 264 | ) 265 | 266 | ## Create "dummy" data frame with ID, study event, study day, study date up to 267 | ## day 30 for each patient 268 | timeline_df <- tibble( 269 | id = rep(sort(unique(all_enrolled$id)), each = 29), 270 | study_day = rep(1:29, length(unique(all_enrolled$id))) 271 | ) %>% 272 | left_join(subset(all_enrolled, 273 | select = c(id, enroll_date, death_date, hospdis_date, 274 | studywd_date)), 275 | by = "id") %>% 276 | bind_cols(study_dates) %>% 277 | ## Add "status" for each day: 278 | ## - deceased 279 | ## - discharged 280 | ## - withdrawn 281 | ## - in hospital 282 | ## With additional indicator for "transition day", or days on which patients 283 | ## died, were discharged, or withdrew. These days may or may not have data 284 | ## collected (eg, if patient died in evening, data may have been collected, 285 | ## but if patient died in morning, likely that no data was collected). 286 | mutate( 287 | redcap_event_name = case_when( 288 | study_day == 1 ~ "Enrollment /Trial Day 1", 289 | study_day == 29 ~ "Discharge Day", 290 | TRUE ~ paste("Trial Day", study_day) 291 | ), 292 | transition_day = (!is.na(death_date) & study_date == death_date) | 293 | (!is.na(studywd_date) & study_date == studywd_date) | 294 | (!is.na(hospdis_date) & study_date == hospdis_date), 295 | study_status = factor( 296 | ifelse(!is.na(death_date) & study_date >= death_date, 4, 297 | ifelse(!is.na(hospdis_date) & study_date >= hospdis_date, 3, 298 | ifelse(!is.na(studywd_date) & study_date >= studywd_date, 2, 1))), 299 | levels = 1:4, 300 | labels = c("In hospital", "Withdrawn", "Discharged", "Deceased")) 301 | ) 302 | 303 | specimen_df <- inhosp_df %>% 304 | dplyr::select( 305 | id, redcap_event_name, specimen_date, starts_with("study_day_specimen"), 306 | blue_drawn, purple_drawn 307 | ) %>% 308 | ## Create a single value for which specimen was drawn (days 1/3/5/discharge) 309 | unite( 310 | specimen_time, 311 | study_day_specimen_e, study_day_specimen_3, study_day_specimen_5, 312 | study_day_specimen_dc, 313 | sep = "; " 314 | ) %>% 315 | mutate( 316 | ## String manipulation so each value includes only "Day x [and Discharge]" 317 | specimen_time = str_remove_all(specimen_time, "NA|; *"), 318 | specimen_time = ifelse( 319 | specimen_time == "", NA, 320 | str_remove(specimen_time, "Enrollment/| only") 321 | ) 322 | ) %>% 323 | separate( 324 | specimen_time, into = c("specimen_time", "double_duty"), sep = " and " 325 | ) %>% 326 | mutate(double_duty = !is.na(double_duty)) 327 | 328 | ## Concatenate records pulling double duty: serve as both day 5 + d/c, eg 329 | specimen_df <- bind_rows( 330 | specimen_df, 331 | specimen_df %>% 332 | filter(double_duty) %>% 333 | mutate( 334 | redcap_event_name = "Discharge Day", 335 | specimen_time = "Discharge" 336 | ) 337 | ) %>% 338 | ## Remove records with no specimen_time; this affects a few records during 339 | ## the transition between the old + new ways of recording double-duty logs 340 | ## (eg: VMO-058, prior to EH correcting it) 341 | filter(!is.na(specimen_time)) %>% 342 | ## Join with records from timeline_df representing days which "should" have 343 | ## specimens (days 1, 3, 5, discharge) 344 | right_join( 345 | timeline_df %>% 346 | filter( 347 | redcap_event_name %in% c( 348 | "Enrollment /Trial Day 1", "Trial Day 3", 349 | "Trial Day 5", "Discharge Day" 350 | ) 351 | ), 352 | by = c("id", "redcap_event_name") 353 | ) %>% 354 | ## Keep rows where: 355 | ## - study day 1, 3, 5 and patient hospitalized; or 356 | ## - discharge day and patient is not deceased or withdrawn 357 | filter( 358 | (redcap_event_name %in% 359 | c("Enrollment /Trial Day 1", "Trial Day 3", "Trial Day 5") & 360 | (study_status == "In hospital" | transition_day)) | 361 | (redcap_event_name == "Discharge Day" & 362 | !(study_status %in% c("Deceased", "Withdrawn"))) 363 | ) %>% 364 | ## Reshape to long format, with one record per day/tube color 365 | dplyr::select(id, redcap_event_name, blue_drawn, purple_drawn) %>% 366 | gather(key = Color, value = drawn, blue_drawn:purple_drawn) %>% 367 | mutate( 368 | Color = str_remove(Color, "\\_drawn"), 369 | ## Compliance: At least one tube drawn 370 | compliant = !is.na(drawn) & drawn > 0, 371 | ## Factor version of event; rely on redcap_event_name, in case no data was 372 | ## entered for specimens 373 | Day = fct_relevel( 374 | str_remove(redcap_event_name, "[Enrollment /]*Trial | Day$"), 375 | "Day 1", "Day 3", "Day 5", "Discharge" 376 | ) 377 | ) %>% 378 | ## Blue tubes are not drawn on days 3/5 (unless it was also discharge day) 379 | filter(!(Color == "blue" & Day %in% c("Day 3", "Day 5"))) %>% 380 | ## Summarize % compliance by study day, tube color 381 | group_by(Day, Color) %>% 382 | summarise( 383 | Compliance = mean(compliant, na.rm = TRUE) 384 | ) %>% 385 | ungroup() 386 | 387 | ## -- Accelerometer info ------------------------------------------------------- 388 | 389 | ## Patient-days 390 | ## On what percentage of patient-days has the accelerometer been removed? 391 | n_hosp_days <- sum(!is.na(inhosp_df$daily_date)) 392 | 393 | ## Get number of days accelerometer was worn 394 | n_accel_days <- with(inhosp_df, sum(coord_ever == "Yes", na.rm = TRUE)) 395 | 396 | ## Get number of days accelerometer was removed at least once 397 | n_accel_rm <- sum(inhosp_df$bed_device_num > 0, na.rm = TRUE) 398 | 399 | ## Patients with device permanently removed *prior to 48h before discharge* 400 | pts_accel_rm <- inhosp_df %>% 401 | dplyr::select(id, daily_date, starts_with("bed_remove_why")) %>% 402 | right_join(subset(all_enrolled, select = c(id, hospdis_date))) %>% 403 | gather(key = time, value = reason, bed_remove_why_1:bed_remove_why_8) %>% 404 | filter(!is.na(reason)) %>% 405 | ## Indicator for whether device was permanently removed on day of or just 406 | ## prior to discharge (should not count for study monitoring purposes) 407 | mutate( 408 | days_before_discharge = 409 | as.numeric(difftime(hospdis_date, daily_date, units = "days")), 410 | prep_discharge = 411 | reason == "Permanent discontinuation" & days_before_discharge %in% 0:1, 412 | reason_mod = case_when( 413 | reason == "Permanent discontinuation" & prep_discharge ~ 414 | "Removed within a day of hospital discharge", 415 | TRUE ~ reason 416 | ) 417 | ) %>% 418 | unique() 419 | 420 | n_accel_permrm <- sum(pts_accel_rm$reason_mod == "Permanent discontinuation") 421 | 422 | ## Summarize reasons for device removal 423 | sum_accel_rm <- pts_accel_rm %>% 424 | group_by(reason_mod) %>% 425 | count() %>% 426 | arrange(desc(n)) 427 | 428 | ## -- Number of times/day accelerometer was removed ---------------------------- 429 | accel_rm_df <- inhosp_df %>% 430 | filter(!is.na(daily_date)) %>% 431 | dplyr::select(id, daily_date, bed_device_num) %>% 432 | separate(daily_date, into = c("year", "month", "day"), sep = "-") %>% 433 | mutate(mabb = month.abb[as.numeric(month)], 434 | myear = paste(year, month, sep = "-"), 435 | myear_char = ifelse(mabb == "Mar", paste(mabb, year), mabb)) 436 | 437 | ################################################################################ 438 | ## Follow-Up Phase 439 | ################################################################################ 440 | 441 | ## Note: No date field for PASE 442 | 443 | ## -- Create dummy df: One record per enrolled patient per f/u time point ------ 444 | fu_dummy <- cross_df( 445 | list( 446 | id = unique(all_enrolled$id), 447 | redcap_event_name = unique(fu_df$redcap_event_name) 448 | ) 449 | ) 450 | 451 | ## List of assessments done at each time point 452 | asmts_phone <- c("ls", "ph_biadl") 453 | asmts_full <- c( 454 | "gq", "biadl", "sppb", "hand", "rbans", "trails", "social", "eq5d", "pase", 455 | "emp", "hus", "bpi", "audit", "zarit", "membehav", "ls" 456 | ) 457 | asmts_all <- unique(c(asmts_phone, asmts_full)) 458 | asmts_withdate <- setdiff(asmts_all, "pase") ## No date variable for PASE 459 | 460 | ## -- Function to turn missing assessment indicators to FALSE ------------------ 461 | ## This happens if (eg) the patient has not yet been reached for an assessment 462 | ## at a given time point; the "test_complete" variable has not yet been filled 463 | ## out, but for monitoring purposes, patient should be counted as not assessed 464 | turn_na_false <- function(x, phone_asmt, df){ 465 | if(phone_asmt){ 466 | ifelse(is.na(x) & df$phone_only & df$fu_elig, FALSE, x) 467 | } else{ 468 | ifelse(is.na(x) & !df$phone_only & df$fu_elig, FALSE, x) 469 | } 470 | } 471 | 472 | ## -- Combine in-hospital dates with follow-up data ---------------------------- 473 | fu_df2 <- fu_dummy %>% 474 | ## Merge in-hospital info onto dummy records 475 | left_join( 476 | all_enrolled %>% 477 | select(id, hospdis_date, studywd_date, death_date, inhosp_status), 478 | by = "id" 479 | ) %>% 480 | left_join( 481 | fu_df %>% 482 | ## Select only variables needed for status, completion at time point 483 | dplyr::select( 484 | id, redcap_event_name, ends_with("complete_yn"), gq_rsn, rbans_completed, 485 | trails_completed, pase_comp_ph, emp_complete, hus_complete, bpi_complete, 486 | ends_with("datecomp"), ends_with("date"), ends_with("date_complete"), 487 | ends_with("date_compl") 488 | ), 489 | by = c("id", "redcap_event_name") 490 | ) %>% 491 | ## Rename all completion, date variables for consistency 492 | rename_at( 493 | vars(matches("\\_complete.*$"), pase_comp_ph), 494 | ~ str_replace(., "\\_comp.+$", "_complete") 495 | ) %>% 496 | rename_at( 497 | vars(matches("\\_date.+")), ~ str_replace(., "\\_date.+", "_date") 498 | ) %>% 499 | ## Convert dates to Date 500 | mutate_at(paste0(asmts_withdate, "_date"), ymd) %>% 501 | ## Was each assessment completed at this time point? 502 | mutate_at( 503 | paste0(unique(c(asmts_phone, asmts_full)), "_complete"), 504 | ~ str_detect(., "^Yes") 505 | ) %>% 506 | mutate( 507 | ## Is this a phone assessment or a full assessment? 508 | phone_only = str_detect(redcap_event_name, "Phone Call"), 509 | ## How many assessments were done at each? 510 | ## If time point involved a phone assessment, info for full assessment is 511 | ## missing, and vice versa 512 | n_asmts_phone = ifelse( 513 | phone_only, 514 | rowSums(.[, paste0(asmts_phone, "_complete")], na.rm = TRUE), 515 | NA 516 | ), 517 | n_asmts_full = ifelse( 518 | phone_only, 519 | NA, 520 | rowSums(.[, paste0(asmts_full, "_complete")], na.rm = TRUE) 521 | ), 522 | any_phone = n_asmts_phone > 0, 523 | any_full = n_asmts_full > 0, 524 | all_phone = n_asmts_phone == length(asmts_phone), 525 | all_full = n_asmts_full == length(asmts_full) 526 | ) 527 | 528 | ## -- Figure out patient's status at each time point --------------------------- 529 | ## Get first, last asssessment at each time point (these will often, but not 530 | ## always, be the same; sometimes the assessment was broken up into 2+ calls or 531 | ## visits due to time/fatigue) 532 | asmt_minmax <- fu_df2 %>% 533 | dplyr::select(id, redcap_event_name, paste0(asmts_withdate, "_date")) %>% 534 | gather(key = "asmt_type", value = "asmt_date", ends_with("_date")) %>% 535 | ## What is the earliest, latest followup date at this assessment? 536 | group_by(id, redcap_event_name) %>% 537 | summarise( 538 | ## Necessary to redo ymd(); otherwise it thinks none of them are NA? 539 | first_asmt = ymd(min(asmt_date, na.rm = TRUE)), 540 | last_asmt = ymd(max(asmt_date, na.rm = TRUE)) 541 | ) %>% 542 | ungroup() 543 | 544 | fu_long <- fu_df2 %>% 545 | left_join(asmt_minmax, by = c("id", "redcap_event_name")) %>% 546 | ## Don't need dates anymore 547 | dplyr::select(-one_of(paste0(asmts_withdate, "_date"))) %>% 548 | ## Determine status at each time point 549 | mutate( 550 | fu_month = as.numeric(str_extract(redcap_event_name, "^\\d+(?= )")), 551 | daysto_window = case_when( 552 | fu_month == 1 ~ 30, 553 | fu_month == 2 ~ 60, 554 | fu_month == 3 ~ 83, 555 | fu_month == 6 ~ 180, 556 | fu_month == 12 ~ 335, 557 | TRUE ~ as.numeric(NA) 558 | ), 559 | enter_window = as.Date(hospdis_date + daysto_window), 560 | exit_window = as.Date( 561 | case_when( 562 | fu_month %in% c(1, 2) ~ enter_window + 14, 563 | fu_month == 3 ~ enter_window + 56, 564 | fu_month == 6 ~ enter_window + 30, 565 | fu_month == 12 ~ enter_window + 90, 566 | TRUE ~ as.Date(NA) 567 | ) 568 | ), 569 | in_window = ifelse(is.na(hospdis_date), NA, enter_window <= Sys.Date()), 570 | 571 | ## Indicator for whether patient refused assessment (but didn't withdraw) 572 | ## Currently relies on general questions only; checking with Julie 573 | refused_gq = !is.na(gq_rsn) & gq_rsn == "Patient refusal", 574 | 575 | ## Followup status: 576 | ## - Had >1 assessment: Assessed 577 | ## - Died prior to end of followup window: Died 578 | ## - Withdrew prior to end of followup window: Withdrew 579 | ## - Not yet in the follow-up window: Currently ineligible 580 | ## - VMO-001-7: consent did not include phone assessments (1, 2, 6m) 581 | ## - None of the above: Currently lost to follow-up 582 | fu_status = factor( 583 | case_when( 584 | (phone_only & any_phone) | (!phone_only & any_full) ~ 1, 585 | !is.na(death_date) & 586 | (inhosp_status == "Died in hospital" | 587 | death_date < exit_window) ~ 2, 588 | !is.na(studywd_date) & 589 | (inhosp_status == "Withdrew in hospital" | 590 | studywd_date < exit_window) ~ 3, 591 | Sys.Date() < enter_window ~ 4, 592 | inhosp_status == "Still in hospital" ~ as.numeric(NA), 593 | phone_only & id %in% paste0("VMO-00", 1:7) ~ 5, 594 | refused_gq ~ 6, 595 | TRUE ~ 7 596 | ), 597 | levels = 1:7, 598 | labels = c( 599 | "Assessment fully or partially completed", 600 | "Died before follow-up window ended", 601 | "Withdrew before follow-up window ended", 602 | "Not yet eligible for follow-up", 603 | "Consent did not include phone assessment", 604 | "Refused assessment (but did not withdraw)", 605 | "Eligible, but not yet assessed" 606 | ) 607 | ), 608 | 609 | ## Indicators for whether patient is eligible for followup (included in 610 | ## denominator) and has been assessed (included in numerator) 611 | fu_elig = fu_status %in% c( 612 | "Assessment fully or partially completed", 613 | "Refused assessment (but did not withdraw)", 614 | "Eligible, but not yet assessed" 615 | ), 616 | fu_comp = ifelse( 617 | !fu_elig, NA, fu_status == "Assessment fully or partially completed" 618 | ) 619 | ) %>% 620 | ## Set asmt indicators to FALSE if pt eligible but no data yet entered 621 | ## Phone only 622 | mutate_at( 623 | vars(paste0(asmts_phone, "_complete")), 624 | funs(ifelse(is.na(.) & phone_only & fu_elig, FALSE, .)) 625 | ) %>% 626 | ## Full batteries 627 | mutate_at( 628 | vars(paste0(asmts_full, "_complete")), 629 | funs(ifelse(is.na(.) & !phone_only & fu_elig, FALSE, .)) 630 | ) 631 | 632 | # ## -- Check patients without followup for JV ----------------------------------- 633 | # fu_long %>% 634 | # filter(fu_status == "Eligible, but not yet assessed") %>% 635 | # dplyr::select( 636 | # id, redcap_event_name, hospdis_date, enter_window, exit_window 637 | # ) %>% 638 | # arrange(redcap_event_name) %>% 639 | # write_csv(path = "testdata/eligible_nofu.csv", na = "", col_names = TRUE) 640 | 641 | ## -- Summary statistics for dashboard ----------------------------------------- 642 | ## Overall % complete at each time point 643 | fu_totals <- fu_long %>% 644 | dplyr::select(redcap_event_name, fu_elig, fu_comp) %>% 645 | filter(fu_elig) %>% 646 | group_by(redcap_event_name) %>% 647 | summarise( 648 | n_elig = sum(fu_elig), 649 | n_comp = sum(fu_comp), 650 | prop_comp = mean(fu_comp) 651 | ) 652 | 653 | fu_asmts <- fu_long %>% 654 | dplyr::select(redcap_event_name, fu_comp, ends_with("_complete")) %>% 655 | filter(fu_comp) %>% 656 | gather(key = asmt_type, value = asmt_done, ends_with("_complete")) %>% 657 | ## Only include assessments that "match" the time point 658 | filter( 659 | (redcap_event_name %in% paste(c(3, 12), "Month Assessment") & 660 | asmt_type %in% paste0(asmts_full, "_complete")) | 661 | (redcap_event_name %in% paste(c(1, 2, 6), "Month Phone Call") & 662 | asmt_type %in% paste0(asmts_phone, "_complete")) 663 | ) %>% 664 | group_by(redcap_event_name, asmt_type) %>% 665 | summarise( 666 | n_elig = sum(fu_comp), 667 | n_comp = sum(asmt_done), 668 | prop_comp = mean(asmt_done) 669 | ) 670 | 671 | ## -- Rearrange data for Sankey plot ------------------------------------------- 672 | ## source = enrollment; target = end of hospitalization 673 | sankey_hospital <- all_enrolled %>% 674 | dplyr::select(id, inhosp_status) %>% 675 | distinct() %>% 676 | set_names(c("id", "target")) %>% 677 | mutate( 678 | source = "Enrolled", 679 | target = case_when( 680 | target == "Still in hospital" ~ "Hospitalized", 681 | target == "Discharged alive" ~ "Discharged", 682 | TRUE ~ stringr::str_replace(target, " in ", ", ") 683 | ) 684 | ) 685 | 686 | ## source = status after illness; target = status at 3m 687 | sankey_3m <- fu_long %>% 688 | filter( 689 | redcap_event_name == "3 Month Assessment", 690 | inhosp_status != "Still in hospital" 691 | ) %>% 692 | dplyr::select(id, inhosp_status, fu_status) %>% 693 | set_names(c("id", "source", "target")) %>% 694 | mutate( 695 | source = case_when( 696 | source == "Died in hospital" ~ "Died, hospital", 697 | source == "Withdrew in hospital" ~ "Withdrew, hospital", 698 | source == "Still in hospital" ~ "Hospitalized", 699 | TRUE ~ "Discharged" 700 | ), 701 | target = case_when( 702 | source == "Died, hospital" | 703 | target == "Died before follow-up window ended" ~ "Died, 3m", 704 | source == "Withdrew, hospital" | 705 | target == "Withdrew before follow-up window ended" ~ "Withdrew, 3m", 706 | source == "Hospitalized" ~ "Hospitalized", 707 | target == "Assessment fully or partially completed" ~ "Assessed, 3m", 708 | target %in% c( 709 | "Eligible, but not yet assessed", 710 | "Refused assessment (but did not withdraw)" 711 | ) ~ "Not assessed, 3m", 712 | target == "Not yet eligible for follow-up" ~ "Not yet eligible, 3m", 713 | TRUE ~ "Missing" 714 | ) 715 | ) 716 | 717 | ## source = status at 3m; target = status at 12m 718 | sankey_12m <- fu_long %>% 719 | filter( 720 | redcap_event_name == "12 Month Assessment", 721 | inhosp_status != "Still in hospital" 722 | ) %>% 723 | dplyr::select(id, fu_status) %>% 724 | left_join(dplyr::select(sankey_3m, id, target)) %>% 725 | ## target at 3m is now source at 12m 726 | set_names(c("id", "target", "source")) %>% 727 | mutate( 728 | target = case_when( 729 | source == "Hospitalized" ~ "Hospitalized", 730 | target == "Died before follow-up window ended" ~ "Died, 12m", 731 | target == "Withdrew before follow-up window ended" ~ "Withdrew, 12m", 732 | target == "Assessment fully or partially completed" ~ "Assessed, 12m", 733 | target %in% c( 734 | "Eligible, but not yet assessed", 735 | "Refused assessment (but did not withdraw)" 736 | ) ~ "Not assessed, 12m", 737 | target == "Not yet eligible for follow-up" ~ "Not yet eligible, 12m", 738 | TRUE ~ "Missing" 739 | ) 740 | ) 741 | 742 | ## Calculate final weights for each edge (# patients with each source/target combo) 743 | sankey_edges <- bind_rows(sankey_hospital, sankey_3m, sankey_12m) %>% 744 | dplyr::select(-id) %>% 745 | group_by(source, target) %>% 746 | summarise(weight = n()) %>% 747 | ungroup() 748 | -------------------------------------------------------------------------------- /R/plot_asmts_comp.R: -------------------------------------------------------------------------------- 1 | ## -- Function to plot % complete for a set of individual assessments ---------- 2 | ## Creates a ggplot2 object, with intention to pipe to ggplotly() 3 | 4 | ## This function assumes that df includes the columns 5 | ## - asmt_type: name of assessment (eg, RBANS) 6 | ## - prop_comp: proportion of this assessment counted as complete 7 | ## - htext: text for tooltip (eg, "RBANS: 98%") 8 | ## - comp_ok: factor categorizing % complete; used to color lollipops 9 | plot_asmts_comp <- function(df, ybreaks, order_desc = TRUE){ 10 | ## Reorder assessment types if requested; otherwise, default is alphabetical 11 | if(order_desc){ 12 | df <- df %>% 13 | mutate(asmt_type = fct_reorder(asmt_type, prop_comp, .desc = TRUE)) 14 | } 15 | 16 | p <- ggplot( 17 | data = df 18 | ) + 19 | aes(x = asmt_type, y = prop_comp, text = htext) + 20 | scale_y_continuous( 21 | limits = c(0, 1.05), breaks = ybreaks, label = scales::percent 22 | ) + 23 | geom_pointrange( 24 | aes(ymin = 0, ymax = prop_comp, color = comp_ok), size = 3 25 | ) + 26 | scale_colour_manual( 27 | values = asmt_values 28 | ) + 29 | theme_minimal() + 30 | theme( 31 | axis.title.x = element_blank(), 32 | axis.title.y = element_blank(), 33 | legend.position = "none" 34 | ) 35 | 36 | return(p) 37 | 38 | } -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # MOSAICProgress 2 | Dashboard for MOSAIC study monitoring. [Link to example](https://jenthompson.me/examples/progressdash.html) 3 | 4 | To create the dashboards automatically, set up a cron job in the terminal like 5 | this [(one `cron` reference guide)](https://www.ostechnix.com/a-beginners-guide-to-cron-jobs/): 6 | 7 | ``` 8 | 30 9 * * 1 cd /my/file/path && Rscript mosaic_makedash.R 9 | ``` 10 | 11 | The above sets the working directory and runs `mosaic_makedash.R` every Monday 12 | morning at 9:30. 13 | -------------------------------------------------------------------------------- /StudyProgress.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /favicon_48x48.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jenniferthompson/MOSAICProgress/80d83348554fc5df1739b727f8a2f3106f9a4995/favicon_48x48.png -------------------------------------------------------------------------------- /mosaic_makedash.R: -------------------------------------------------------------------------------- 1 | rmarkdown::render("progressdash.Rmd") 2 | -------------------------------------------------------------------------------- /progressdash.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "MOSAIC Study Progress" 3 | output: 4 | flexdashboard::flex_dashboard: 5 | orientation: columns 6 | vertical_layout: fill 7 | theme: cosmo 8 | logo: favicon_48x48.png 9 | favicon: favicon_48x48.png 10 | --- 11 | 12 | 21 | 22 | 28 | 29 | ```{r setup, include=FALSE} 30 | library(flexdashboard) 31 | library(plotly) 32 | library(highcharter) 33 | library(treemap) 34 | library(knitr) 35 | library(scales) 36 | library(glue) 37 | library(googleVis) 38 | 39 | source("R/datamgmt_progress.R") 40 | source("R/plot_asmts_comp.R") 41 | 42 | mosaic_pal <- c( 43 | ## Row 1, starting with leftmost diamond 44 | "blue1" = "#283C72", "blue2" = "#243E8B", "blue3" = "#0477BF", 45 | "green1" = "#8EC63E", "green2" = "#3BB547", 46 | ## Row 2 47 | "blue4" = "#24ADCD", "blue5" = "#0976B7", "blue6" = "#23AEDD", 48 | "green3" = "#3BB54A", "green4" = "#1A653E", 49 | ## Row 3 50 | "orange1" = "#E76A32", "orange2" = "#F69723", "orange3" = "#FA961F", 51 | "orange4" = "#FBCD93", "ecru" = "#FFF8DE", 52 | ## Row 4 53 | "red1" = "#D71A60", "red2" = "#F27074", "red3" = "#EC835F", 54 | "gray1" = "#E4DAD1", "gray2" = "#F7F5EB", 55 | ## Row 5 56 | "red4" = "#C0232C", "red5" = "#EE1C27", "red6" = "#FF686D", 57 | "red7" = "#F8D4D1", "cream" = "#FEFEFC" 58 | ) 59 | 60 | ## Function to get hex for a specific element 61 | mosaic_col <- function(hex){ as.character(mosaic_pal[hex]) } 62 | 63 | ## Colors for assessment plots 64 | asmt_values = c( 65 | "Excellent" = mosaic_col("green4"), 66 | "Okay" = mosaic_col("orange3"), 67 | "Uh-oh" = mosaic_col("red5") 68 | ) 69 | 70 | ## Named vector of colors for exclusions 71 | exc_colors <- c( 72 | ">5 hospital days in last 30" = mosaic_col("blue1"), 73 | "Severe neurologic injury" = mosaic_col("blue3"), 74 | "Death within 24h/hospice" = mosaic_col("blue4"), 75 | "Rapidly resolving organ failure" = mosaic_col("blue5"), 76 | "BMI > 50" = mosaic_col("red1"), 77 | "Substance abuse, etc" = mosaic_col("red2"), 78 | "Blind, deaf, English" = mosaic_col("red3"), 79 | "Prisoner" = mosaic_col("red4"), 80 | "Inability to live independently" = mosaic_col("red5"), 81 | "Homeless" = mosaic_col("red6"), 82 | "Patient/surrogate refusal" = mosaic_col("green4"), 83 | "No surrogate within 72h" = mosaic_col("green1"), 84 | "Attending refusal" = mosaic_col("green3"), 85 | ">72h eligibility prior to screening" = mosaic_col("green4"), 86 | "Lives >150 miles from VUMC" = mosaic_col("orange1"), 87 | "Study with no co-enrollment" = mosaic_col("orange2"), 88 | "Other" = mosaic_col("orange3") 89 | ) 90 | 91 | ## Manually set width, height for screening/enrollment over time plots 92 | screenplot_wd <- 640 93 | screenplot_ht <- 325 94 | 95 | ``` 96 | 97 | Screening & Enrollment 98 | ===================================== 99 | 100 | Column {data-width=60%} 101 | ----------------------------------------------------------------------- 102 | 103 | ### Patients Screened, Approached, and Enrolled 104 | 105 | ```{r nodate_ids} 106 | nodate_ids <- unique(c(exc_id_nodate, enroll_id_nodate)) 107 | 108 | nodate_statement <- ifelse( 109 | length(nodate_ids > 0), 110 | paste( 111 | "These IDs have no exclusion/enrollment date entered and are not included:", 112 | paste(nodate_ids, collapse = "; ") 113 | ), 114 | "" 115 | ) 116 | 117 | ``` 118 | 119 | `r nodate_statement` 120 | 121 | ```{r screening} 122 | ## Want figure to start in March 2017 123 | screening_myears <- unique(screening_summary$myear) 124 | screening_myears_num <- 1:length(screening_myears) 125 | names(screening_myears_num) <- screening_myears 126 | 127 | ## X axis labels: character versions of unique months of enrollment 128 | ## Applies to both screening and exclusion charts 129 | screening_xlabs <- exc_over_time %>% 130 | dplyr::select(myear, myear_char) %>% 131 | distinct() %>% 132 | pull(myear_char) 133 | 134 | ## Which months to use on X axes? (After a year of enrollment, axis labels 135 | ## getting crowded) 136 | use_xlabs <- seq(1, length(screening_xlabs), 2) 137 | 138 | screening_summary <- screening_summary %>% 139 | mutate(myear_num = screening_myears_num[myear]) 140 | 141 | x_screen <- list( 142 | tickvals = as.numeric(screening_myears_num)[use_xlabs], 143 | ticktext = screening_xlabs[use_xlabs], 144 | title = "" 145 | ) 146 | y <- list(title = "") 147 | 148 | screen_plotly <- plot_ly( 149 | data = screening_summary, 150 | x = ~ myear_num, 151 | y = ~ Screened, 152 | type = "bar", 153 | name = "Screened", 154 | color = I(mosaic_col("red5")), 155 | alpha = 0.75, 156 | hoverinfo = "text", 157 | text = ~ sprintf("%s, Screened: %s", myear_char, Screened) 158 | ) %>% 159 | add_bars( 160 | y = ~ Approached, 161 | name = "Approached", 162 | color = I(mosaic_col("orange3")), 163 | hoverinfo = "text", 164 | text = ~ sprintf("%s, Approached: %s", myear_char, Approached) 165 | ) %>% 166 | add_bars( 167 | y = ~ Enrolled, 168 | name = "Enrolled", 169 | color = I(mosaic_col("green4")), 170 | hoverinfo = "text", 171 | text = ~ sprintf("%s, Enrolled: %s", myear_char, Enrolled) 172 | ) 173 | 174 | screen_plotly %>% 175 | layout(legend = list(x = 0, y = 0.95, bgcolor='transparent'), 176 | xaxis = x_screen, yaxis = y) 177 | 178 | ``` 179 | 180 | ### Study Exclusions (% of All Patients Excluded) 181 | 182 | ```{r exclusions_over_time} 183 | ## plotly needs x value to be numeric to sort properly? 184 | exc_myears <- sort(unique(exc_over_time$myear)) 185 | exc_myears_num <- 1:length(exc_myears) 186 | names(exc_myears_num) <- exc_myears 187 | 188 | exc_over_time <- exc_over_time %>% 189 | mutate(myear_num = exc_myears_num[myear]) 190 | 191 | x_exc <- list(tickvals = as.numeric(exc_myears_num)[use_xlabs], 192 | ticktext = screening_xlabs[use_xlabs], 193 | title = "") 194 | y_exc <- list(tickvals = seq(0, 100, 20), 195 | ticktext = paste0(seq(0, 100, 20), "%"), 196 | title = "Percent of Exclusions") 197 | 198 | exc_plotly <- plot_ly( 199 | data = exc_over_time, 200 | x = ~ myear_num, 201 | y = ~ Percent, 202 | type = "scatter", 203 | mode = "lines+markers", 204 | color = ~ Reason, 205 | colors = exc_colors, 206 | alpha = 0.6, 207 | hoverinfo = "text", 208 | text = ~ sprintf("%s, %s: %s%%", myear_char, Reason, Percent) 209 | ) 210 | 211 | exc_plotly %>% 212 | layout(showlegend = FALSE, 213 | xaxis = x_exc, 214 | yaxis = y_exc) 215 | 216 | ``` 217 | 218 | Column {data-width=40%} 219 | ----------------------------------------------------------------------- 220 | 221 | ### Cumulative Enrollment as of `r format(Sys.Date(), "%B %d, %Y")` {data-height=40%} 222 | 223 | ```{r enrollment} 224 | screening_statement <- sprintf( 225 | "We have screened %s patients; %s%% were excluded and %s%% approached. Of those approached, %s%% refused consent and %s%% were enrolled.", 226 | format(n_screened, big.mark = ","), 227 | round(pct_excluded*100), 228 | round(pct_approached*100), 229 | round(pct_refused*100), 230 | round(pct_enrolled*100) 231 | ) 232 | 233 | enroll_gauge <- gauge( 234 | value = n_enrolled, 235 | min = 0, 236 | max = n_goal, 237 | sectors = gaugeSectors(colors = mosaic_col("green1")), 238 | label = "patients" 239 | ) 240 | 241 | enroll_gauge 242 | 243 | ``` 244 |
245 | `r screening_statement` 246 | 247 | ### Cumulative Exclusions (Total: `r format(nrow(exc_df), big.mark = ",")`) {data-height=60%} 248 | 249 | ```{r exclusions_cumulative} 250 | tm_exc <- treemap(dtf = exc_cumul, 251 | index = c("reason_type", "Reason"), 252 | vSize = "n_reason", 253 | type = "index", 254 | title = "", 255 | algorithm = "squarified", 256 | palette = mosaic_pal[c("orange1", "green2", "blue3", "green4", "red1")], 257 | draw = FALSE) 258 | 259 | hc_tm_exc <- hctreemap( 260 | tm_exc, 261 | allowDrillToNode = TRUE, 262 | layoutAlgorithm = "squarified", 263 | levels = list(levelIsConstant = "false"), 264 | dataLabels = list(style = list(color = "white", 265 | textOutline = "0px contrast", 266 | fontSize = "8px")) 267 | ) 268 | 269 | hc_tm_exc 270 | 271 | ``` 272 | 273 | Study Conduct{data-orientation=rows} 274 | ================================================================================ 275 | 276 | Row{data-height=50%} 277 | -------------------------------------------------------------------------------- 278 | 279 | ### Prehospital Surrogate Battery Completion Rate{data-width=35%} 280 | 281 | ```{r ph_comp} 282 | ## -- Proportion of full batteries completed ----------------------------------- 283 | pct_surrogate_comp <- 284 | round(mean(all_enrolled$ph_surrogate_comp, na.rm = TRUE) * 100) 285 | pct_caregiver_comp <- 286 | round(mean(all_enrolled$ph_caregiver_comp, na.rm = TRUE) * 100) 287 | 288 | ## -- Proportion of individual surrogate assessments completed ----------------- 289 | surrogate_compvars <- paste0( 290 | c("gq", "pase", "adl", "ls", "emp", "audit", "iqcode", "bdi", "zarit", 291 | "memory"), 292 | "_comp_ph" 293 | ) 294 | 295 | surrogate_pctcomp <- all_enrolled %>% 296 | dplyr::select(one_of(surrogate_compvars)) %>% 297 | summarise_all(mean, na.rm = TRUE) %>% 298 | gather(key = asmt_type, value = prop_comp) %>% 299 | mutate(sort_order = if_else(asmt_type == "ph_surrogate_comp", 1, 2)) %>% 300 | arrange(sort_order, desc(prop_comp)) %>% 301 | mutate( 302 | ## Sort in descending order of % completed 303 | x_sorted = 1:n(), 304 | ## Clearer battery names 305 | asmt_type = case_when( 306 | asmt_type == "memory_comp_ph" ~ "Mem/Behav", 307 | asmt_type == "gq_comp_ph" ~ "General", 308 | asmt_type == "emp_comp_ph" ~ "Employment", 309 | asmt_type == "zarit_comp_ph" ~ "Zarit", 310 | TRUE ~ toupper(str_remove(asmt_type, "\\_comp\\_ph$")) 311 | ), 312 | asmt_type = fct_reorder(asmt_type, x_sorted), 313 | htext = paste0(asmt_type, ": ", scales::percent(prop_comp)), 314 | comp_ok = case_when( 315 | prop_comp > 0.90 ~ "Excellent", 316 | prop_comp > 0.80 ~ "Okay", 317 | TRUE ~ "Uh-oh" 318 | ) 319 | ) 320 | 321 | ``` 322 | 323 | ```{r ph_surrogate} 324 | valueBox( 325 | value = paste0(pct_surrogate_comp, "%"), 326 | caption = "fully completed surrogate questionnaires
(General, PASE, ADLs, LS, employment, AUDIT, IQCODE, BDI)", 327 | color = ifelse( 328 | pct_surrogate_comp < 80, mosaic_col("orange3"), mosaic_col("green3") 329 | ), 330 | icon = "ion-person-stalker" 331 | ) 332 | 333 | ``` 334 | 335 | ### Surrogate/Caregiver Battery Completion 336 | 337 | ```{r surrogate_pctcomp_ind} 338 | p_surr <- plot_asmts_comp(df = surrogate_pctcomp, ybreaks = seq(0, 1, 0.2)) 339 | ggplotly(p_surr, tooltip = "text") 340 | 341 | ``` 342 | 343 | Row{data-height=50%} 344 | -------------------------------------------------------------------------------- 345 | 346 | ### Prehospital Caregiver Battery Completion Rate{data-width=35%} 347 | 348 | ```{r ph_caregiver} 349 | valueBox( 350 | value = paste0(pct_caregiver_comp, "%"), 351 | caption = 352 | "fully completed caregiver questionnaires
(Zarit, Memory & Behavior)", 353 | color = ifelse( 354 | pct_caregiver_comp < 80, mosaic_col("orange3"), mosaic_col("green3") 355 | ), 356 | icon = "ion-heart" 357 | ) 358 | 359 | ``` 360 | 361 | ### Specimen Log Compliance (% of Patients Eligible) 362 | 363 | ```{r specimen_compliance} 364 | ## Add text for tooltips 365 | specimen_df$htext <- glue::glue_data( 366 | specimen_df, 367 | "{Day}, {Color}: {scales::percent(Compliance)}" 368 | ) 369 | 370 | specimen_plot <- ggplot( 371 | data = specimen_df, 372 | aes(group = Color, x = Day, y = Compliance, text = htext) 373 | ) + 374 | geom_bar(aes(fill = Color), position = "dodge", stat = "identity") + 375 | scale_y_continuous(limits = c(0, 1), 376 | breaks = seq(0, 1, 0.5), 377 | label = scales::percent) + 378 | scale_fill_manual(values = c(mosaic_col("blue3"), "#5F0395"), guide = FALSE) + 379 | scale_alpha_manual(values = c(0.65, 0.85)) + 380 | theme_minimal() + 381 | theme(legend.position = "none", 382 | axis.title = element_blank(), 383 | axis.text = element_text(size = 10), 384 | panel.background = element_rect(fill = NA, color = "gray80"), 385 | panel.spacing = unit(2, "lines")) 386 | 387 | x <- y <- list(title = NULL) 388 | 389 | specimen_plot %>% 390 | ggplotly(tooltip = "text") %>% 391 | layout(xaxis = x, yaxis = y) 392 | 393 | ``` 394 | 395 | ### Current In-Hospital Status 396 | 397 | ```{r current_status} 398 | ## List of patients currently in hospital 399 | pts_inhosp <- subset(all_enrolled, inhosp_status == "Still in hospital")$id 400 | pts_inhosp_text <- ifelse(length(pts_inhosp) == 0, "None", 401 | paste0(pts_inhosp, collapse = "; ")) 402 | 403 | tm_status <- treemap( 404 | dtf = status_count, 405 | index = c("inhosp_status"), 406 | vSize = "n_status", 407 | type = "index", 408 | title = "", 409 | algorithm = "squarified", 410 | palette = mosaic_pal[c("blue3", "red1", "orange1", "green2")], 411 | draw = FALSE 412 | ) 413 | 414 | hc_tm_status <- hctreemap( 415 | tm_status, 416 | allowDrillToNode = TRUE, 417 | layoutAlgorithm = "squarified", 418 | levels = list(levelIsConstant = "false"), 419 | dataLabels = list(style = list(color = "white", 420 | textOutline = "0px contrast", 421 | fontSize = "12px")) 422 | ) %>% 423 | hc_subtitle( 424 | text = paste("Patients currently in hospital:", pts_inhosp_text), 425 | align = "left" 426 | ) 427 | 428 | hc_tm_status 429 | 430 | ``` 431 | 432 | Accelerometers{data-orientation=rows} 433 | ================================================================================ 434 | 435 | Row {data-height=50%} 436 | -------------------------------------------------------------------------------- 437 | 438 | ### Accelerometer Snapshot: Patient-Days{data-width=50%} 439 | 440 | ```{r accel_snapshot_days} 441 | ## -- Patient-days accelerometer was worn -------------------------------------- 442 | pct_accel_worn <- round((n_accel_days / n_hosp_days) * 100) 443 | 444 | accel_text <- "days accelerometer worn

" 445 | 446 | valueBox( 447 | value = paste0(pct_accel_worn, "%"), 448 | caption = accel_text, 449 | color = ifelse( 450 | pct_accel_worn < 80, mosaic_col("orange3"), mosaic_col("green3") 451 | ), 452 | icon = "ion-watch" 453 | ) 454 | 455 | ``` 456 | 457 | ### On Days Accelerometer Was Removed, How Many Times? 458 | 459 | ```{r times_accel_removed} 460 | accel_rm_atleast1 <- accel_rm_df %>% 461 | filter(bed_device_num > 0) %>% 462 | rename(Times = bed_device_num) 463 | 464 | accel_rm_hist <- ggplot(data = accel_rm_atleast1, aes(x = Times)) + 465 | geom_histogram(fill = mosaic_col("blue1"), alpha = 0.5, binwidth = 1) + 466 | scale_x_continuous(breaks = 1:8, labels = 1:8) + 467 | theme_minimal() + 468 | theme(axis.title = element_blank()) 469 | 470 | accel_rm_hist %>% 471 | ggplotly(tooltip = c("x", "y")) 472 | 473 | ``` 474 | 475 | Row {data-height=50%} 476 | -------------------------------------------------------------------------------- 477 | 478 | ### Accelerometer Snapshot: Patients{data-width=50%} 479 | 480 | ```{r accel_snapshot_pts} 481 | 482 | ## -- Pts for whom accel was permanently removed >1 day before discharge ------- 483 | pct_accel_permrm <- round((n_accel_permrm / n_enrolled) * 100) 484 | 485 | valueBox( 486 | value = paste0(pct_accel_permrm, "%"), 487 | caption = "patients with accelerometer permanently removed
>1 day before discharge", 488 | color = ifelse(pct_accel_permrm > 20, mosaic_col("red4"), 489 | ifelse(pct_accel_permrm > 15, mosaic_col("orange3"), 490 | mosaic_col("green3"))), 491 | icon = "ion-close-circle" 492 | ) 493 | 494 | ``` 495 | 496 | ### Reasons for Accelerometer Removal 497 | 498 | ```{r reasons_removed} 499 | sum_accel_rm %>% 500 | knitr::kable( 501 | format = "markdown", 502 | row.names = FALSE, col.names = c("Reason", "Patients") 503 | ) 504 | 505 | ``` 506 | 507 | Follow-Up {data-orientation=rows} 508 | ================================================================================ 509 | 510 | Row {data-height=33%} 511 | -------------------------------------------------------------------------------- 512 | 513 | ```{r fu_prep} 514 | prop_totals <- map_dbl( 515 | fu_totals %>% pull(prop_comp), ~ round(., 2) 516 | ) %>% 517 | set_names(fu_totals %>% pull(redcap_event_name)) 518 | 519 | fu_asmts <- fu_asmts %>% 520 | mutate( 521 | asmt_type = case_when( 522 | asmt_type %in% paste0(c("ph_", ""), "biadl_complete") ~ "ADL", 523 | asmt_type == "emp_complete" ~ "Emp.", 524 | asmt_type == "gq_complete" ~ "Gen.", 525 | asmt_type == "hand_complete" ~ "Hand.", 526 | asmt_type == "membehav_complete" ~ "M/B", 527 | asmt_type == "social_complete" ~ "Social", 528 | asmt_type == "trails_complete" ~ "Trails", 529 | asmt_type == "zarit_complete" ~ "Zarit", 530 | TRUE ~ toupper(str_remove(asmt_type, "\\_complete$")) 531 | ), 532 | htext = paste0(asmt_type, ": ", scales::percent(round(prop_comp, 2))), 533 | comp_ok = case_when( 534 | prop_comp > 0.90 ~ "Excellent", 535 | prop_comp > 0.80 ~ "Okay", 536 | TRUE ~ "Uh-oh" 537 | ) 538 | ) 539 | 540 | ``` 541 | 542 | ### 1-Month Follow-Up{data-width=20%} 543 | 544 | ```{r fu_total_1m} 545 | valueBox( 546 | value = scales::percent(pluck(prop_totals, "1 Month Phone Call")), 547 | caption = "fully or partially completed,
1 month", 548 | color = ifelse( 549 | pluck(prop_totals, "1 Month Phone Call") < 0.9, 550 | mosaic_col("orange3"), 551 | mosaic_col("green3") 552 | ) 553 | ) 554 | 555 | ``` 556 | 557 | ### Assessments {data-width=20%} 558 | 559 | ```{r fu_asmts_1m} 560 | p_1m <- plot_asmts_comp( 561 | df = fu_asmts %>% filter(redcap_event_name == "1 Month Phone Call"), 562 | ybreaks = 0:1, 563 | order_desc = FALSE 564 | ) 565 | ggplotly(p_1m + theme(axis.text.y = element_blank()), tooltip = "text") 566 | 567 | ``` 568 | 569 | ### 3-Month Follow-Up{data-width=20%} 570 | 571 | ```{r fu_total_3m} 572 | valueBox( 573 | value = scales::percent(pluck(prop_totals, "3 Month Assessment")), 574 | caption = "fully or partially completed,
3 months", 575 | color = ifelse( 576 | pluck(prop_totals, "3 Month Assessment") < 0.9, 577 | mosaic_col("orange3"), 578 | mosaic_col("green3") 579 | ) 580 | ) 581 | 582 | ``` 583 | 584 | ### **3-Month Assessments** (Out of `r nrow(fu_long %>% filter(redcap_event_name == "3 Month Assessment" & fu_comp))` Completed Assessments)
*Not Yet Assessed*: `r paste(fu_long %>% filter(fu_elig, fu_status == "Eligible, but not yet assessed", redcap_event_name == "3 Month Assessment") %>% pull(id), collapse = "; ")` 585 | 586 | ```{r fu_asmts_3m} 587 | p_3m <- plot_asmts_comp( 588 | df = fu_asmts %>% filter(redcap_event_name == "3 Month Assessment"), 589 | ybreaks = 0:1 590 | ) 591 | ggplotly(p_3m, tooltip = "text") 592 | 593 | ``` 594 | 595 | Row {data-height=33%} 596 | -------------------------------------------------------------------------------- 597 | 598 | ### 2-Month Follow-Up{data-width=15%} 599 | 600 | ```{r fu_total_2m} 601 | valueBox( 602 | value = scales::percent(pluck(prop_totals, "2 Month Phone Call")), 603 | caption = "fully or partially completed,
2 months", 604 | color = ifelse( 605 | pluck(prop_totals, "2 Month Phone Call") < 0.9, 606 | mosaic_col("orange3"), 607 | mosaic_col("green3") 608 | ) 609 | ) 610 | 611 | ``` 612 | 613 | ### Assessments{data-width=20%} 614 | 615 | ```{r fu_asmts_2m} 616 | p_2m <- plot_asmts_comp( 617 | df = fu_asmts %>% filter(redcap_event_name == "2 Month Phone Call"), 618 | ybreaks = 0:1, 619 | order_desc = FALSE 620 | ) 621 | ggplotly(p_2m + theme(axis.text.y = element_blank()), tooltip = "text") 622 | 623 | ``` 624 | 625 | ### 12-Month Follow-Up{data-width=20%} 626 | 627 | ```{r fu_total_12m} 628 | valueBox( 629 | value = scales::percent(pluck(prop_totals, "12 Month Assessment")), 630 | caption = "fully or partially completed,
12 months", 631 | color = ifelse( 632 | pluck(prop_totals, "12 Month Assessment") < 0.9, 633 | mosaic_col("orange3"), 634 | mosaic_col("green3") 635 | ) 636 | ) 637 | 638 | ``` 639 | 640 | ### **12-Month Assessments** (Out of `r nrow(fu_long %>% filter(redcap_event_name == "12 Month Assessment" & fu_comp))` Completed Assessments)
*Not Yet Assessed*: `r paste(fu_long %>% filter(fu_elig, fu_status == "Eligible, but not yet assessed", redcap_event_name == "12 Month Assessment") %>% pull(id), collapse = "; ")` 641 | 642 | ```{r fu_asmts_12m} 643 | p_12m <- plot_asmts_comp( 644 | df = fu_asmts %>% filter(redcap_event_name == "12 Month Assessment"), 645 | ybreaks = 0:1 646 | ) 647 | ggplotly(p_12m, tooltip = "text") 648 | 649 | ``` 650 | 651 | Row {data-height=33%} 652 | -------------------------------------------------------------------------------- 653 | 654 | ### 6-Month Follow-Up{data-width=15%} 655 | 656 | ```{r fu_total_6m} 657 | valueBox( 658 | value = scales::percent(pluck(prop_totals, "6 Month Phone Call")), 659 | caption = "fully or partially completed,
6 months", 660 | color = ifelse( 661 | pluck(prop_totals, "6 Month Phone Call") < 0.9, 662 | mosaic_col("orange3"), 663 | mosaic_col("green3") 664 | ) 665 | ) 666 | 667 | ``` 668 | 669 | ### Assessments{data-width=20%} 670 | 671 | ```{r fu_asmts_6m} 672 | p_6m <- plot_asmts_comp( 673 | df = fu_asmts %>% filter(redcap_event_name == "6 Month Phone Call"), 674 | ybreaks = 0:1, 675 | order_desc = FALSE 676 | ) 677 | ggplotly(p_6m + theme(axis.text.y = element_blank()), tooltip = "text") 678 | 679 | ``` 680 | 681 | ### Patient Flow 682 | 683 | ```{r sankey} 684 | ## Create data.frame of nodes 685 | ## Possible states: 686 | ## 0) Enrolled 687 | ## 1) Discharged alive 688 | ## 2) Assessed, 3m 689 | ## 3) Not assessed, 3m 690 | ## 4) Not yet eligible, 3m 691 | ## 5) Assessed, 12m 692 | ## 6) Not assessed, 12m 693 | ## 7) Not yet eligible, 12m 694 | ## 8) Hospitalized 695 | ## 9) Withdrawn 696 | ## 10) Died 697 | sankey_nodes <- data.frame( 698 | id = 0:10, 699 | label = c( 700 | "Enrolled", "Discharged", "Assessed, 3m", "Not assessed, 3m", 701 | "Not yet eligible, 3m", "Assessed, 12m", "Not assessed, 12m", 702 | "Not yet eligible, 12m", "Hospitalized", "Withdrew", "Died" 703 | ) 704 | ) 705 | 706 | ## -- Sankey chart using plotly ------------------------------------------------ 707 | # ## Couldn't get this to actually show up, and caused issues with DT, other JS 708 | # ## widgets, I think due to spacing? 709 | # 710 | # ## Convert edge labels to numeric values 711 | # sankey_edges2 <- sankey_edges %>% 712 | # left_join(sankey_nodes, by = c("source" = "label")) %>% 713 | # left_join(sankey_nodes, by = c("target" = "label")) %>% 714 | # dplyr::select(-source, -target) %>% 715 | # set_names(c("weight", "source", "target")) 716 | # 717 | # pt_flow <- plot_ly( 718 | # type = "sankey", 719 | # orientation = "h", 720 | # 721 | # node = list( 722 | # label = sankey_nodes %>% pull(label), 723 | # color = c( 724 | # mosaic_col("blue1"), ## enrolled 725 | # mosaic_col("green4"), ## discharged 726 | # mosaic_col("green4"), ## assessed, 3m 727 | # mosaic_col("orange1"), ## not assessed, 3m 728 | # mosaic_col("cream"), ## not yet eligible, 3m 729 | # mosaic_col("green4"), ## assessed, 12m 730 | # mosaic_col("orange1"), ## not assessed, 12m 731 | # mosaic_col("cream"), ## not yet eligible, 12m 732 | # mosaic_col("orange4"), ## still hospitalized 733 | # mosaic_col("red2"), ## withdrew 734 | # mosaic_col("red4") ## died 735 | # ) 736 | # ), 737 | # 738 | # link = list( 739 | # source = sankey_edges2 %>% pull(source), 740 | # target = sankey_edges2 %>% pull(target), 741 | # value = sankey_edges2 %>% pull(weight), 742 | # 743 | # width = 500, height = 25 744 | # ) 745 | # ) %>% 746 | # layout(autosize = FALSE) 747 | 748 | ## -- Sankey chart using googleVis --------------------------------------------- 749 | ## Nodes need to be in correct order 750 | sankey_edges2 <- sankey_edges %>% 751 | mutate( 752 | sort_source = case_when( 753 | source == "Died, 3m" ~ 8, 754 | source == "Withdrew, 3m" ~ 7, 755 | source == "Not yet eligible, 3m" ~ 6, 756 | source == "Not assessed, 3m" ~ 5, 757 | source == "Assessed, 3m" ~ 4, 758 | source == "Died, hospital" ~ 3, 759 | source == "Withdrew, hospital" ~ 2, 760 | source == "Discharged" ~ 1, 761 | source == "Enrolled" ~ 0, 762 | TRUE ~ as.numeric(NA) 763 | ), 764 | sort_target = case_when( 765 | target == "Died, 12m" ~ 13, 766 | target == "Withdrew, 12m" ~ 12, 767 | target == "Not yet eligible, 12m" ~ 11, 768 | target == "Not assessed, 12m" ~ 10, 769 | target == "Assessed, 12m" ~ 9, 770 | target == "Died, 3m" ~ 8, 771 | target == "Withdrew, 3m" ~ 7, 772 | target == "Not yet eligible, 3m" ~ 6, 773 | target == "Not assessed, 3m" ~ 5, 774 | target == "Assessed, 3m" ~ 4, 775 | target == "Died, hospital" ~ 3, 776 | target == "Withdrew, hospital" ~ 2, 777 | target == "Discharged" ~ 1, 778 | target == "Hospitalized" ~ 0, 779 | TRUE ~ as.numeric(NA) 780 | ) 781 | ) %>% 782 | arrange(sort_source, sort_target) %>% 783 | ## Add Ns for total source, targets 784 | group_by(source) %>% 785 | add_tally(weight) %>% 786 | ungroup() %>% 787 | group_by(target) %>% 788 | add_tally(weight) %>% 789 | ungroup() %>% 790 | dplyr::select(-sort_source, -sort_target) %>% 791 | set_names(c("source", "target", "weight", "source_total", "target_total")) %>% 792 | mutate( 793 | to_from = paste0("", source, " -> ", target, ":"), 794 | flow.tooltip = case_when( 795 | ## Target nodes where 100% of patients came from same source: 796 | ## N + % (n) of source 797 | target %in% c( 798 | "Discharged", "Withdrew, hospital", "Died, hospital", "Hospitalized", 799 | "Assessed, 3m", "Not assessed, 3m", "Not yet eligible, 3m" 800 | ) ~ paste0( 801 | to_from, 802 | "
N = ", weight, "
", scales::percent(weight / source_total), 803 | " of ", source_total, " ", tolower(source) 804 | ), 805 | ## Source nodes where 100% of patients go to same target: 806 | ## N + % (n) of target 807 | source %in% c( 808 | "Withdrew, hospital", "Died, hospital", "Died, 3m", "Withdrew, 3m" 809 | ) ~ paste0( 810 | to_from, "
N = ", weight, "
", 811 | scales::percent(weight / target_total), " of ", 812 | target_total, " ", tolower(target) 813 | ), 814 | ## Otherwise, add N, % (n) of source, and % (n) of target 815 | TRUE ~ paste0( 816 | to_from, "
N = ", weight, "
", 817 | scales::percent(weight / source_total), " of ", source_total, " ", 818 | tolower(source), 819 | "
", scales::percent(weight / target_total), " of ", 820 | target_total, " ", tolower(target) 821 | ) 822 | ) 823 | ) 824 | 825 | ptflow_gvis <- gvisSankey( 826 | sankey_edges2, 827 | from = "source", 828 | to = "target", 829 | weight = "weight", 830 | options = list( 831 | height = 200, width = 750, 832 | tooltip = "{isHtml:'True'}", 833 | sankey = "{link: { colorMode: 'gradient' }, 834 | node: { colors: ['#283C72', 835 | '#243E8B', 836 | '#1A653E', 837 | '#FA961F', 838 | '#C0232C', 839 | 840 | '#1A653E', 841 | '#E76A32', 842 | '#24ADCD', 843 | '#FA961F', 844 | '#C0232C', 845 | 846 | '#1A653E', 847 | '#E76A32', 848 | '#24ADCD', 849 | '#C0232C', 850 | '#FA961F'], 851 | label: { fontSize: 12, bold: true } 852 | }, 853 | iterations: 0 }" 854 | ) 855 | ) 856 | 857 | ``` 858 | 859 | ```{r print_sankey, results = "asis"} 860 | ## plotly: not showing up 861 | # pt_flow 862 | 863 | # ## networkD3: This isn't showing up, makes DT go away 864 | # networkD3::sankeyNetwork( 865 | # Links = sankey_edges2, Nodes = sankey_nodes, 866 | # Source = "source", Target = "target", Value = "weight", 867 | # NodeID = "label", 868 | # fontSize = 16, unit = "Patients", height = 500, width = 750 869 | # ) 870 | 871 | ## Let's try googleVis 872 | print(ptflow_gvis, tag = "chart") 873 | 874 | ``` 875 | 876 | Study & Technical Info 877 | ===================================== 878 | 879 | MOSAIC is funded by the National Institutes of Health. Please see our listing on [clinicaltrials.gov](https://clinicaltrials.gov/ct2/show/NCT03115840). 880 | 881 | This dashboard uses `r devtools::session_info()$platform$version`. Packages: 882 | 883 | ```{r} 884 | DT::datatable(devtools::session_info()$packages) 885 | 886 | ``` --------------------------------------------------------------------------------