Takes a remote database contection to CC-HIC, a vector of HIC codes (and optionally a vector of labels to rename the codes) and returns a table with 1 row per patient and 1 column per data item.
extract_demographics(
connection = NULL,
episode_ids = NA_integer_,
code_names = NA_character_,
rename = NA_character_
)a CC-HIC database connection
an integer vector of episode ids from the CC-HIC DB that you want to extact. The default (NULL) is to extract all.
a character vector of CC-HIC codes
a character vector of names you want to relabel CC-HIC codes as, or NULL (the default) if you do not want to relabel.
A tibble of 1d data
hic_codes <- "NIHR_HIC_ICU_0409"
new_labels <- "apache_score"
con <- setup_dummy_db()
#> Error in (function (cond) .Internal(C_tryCatchHelper(addr, 1L, cond)))(structure(list(message = "Problem while computing `time = strftime(time, format = \"%H:%M:%S\")`.", trace = structure(list(call = list(tryCatch(withCallingHandlers({ NULL saveRDS(do.call(do.call, c(readRDS("/var/folders/7r/d3tp4w4171vc57vmhwy6fv940000gn/T//Rtmp5xMCHY/callr-fun-3db3e4c70d1"), list(envir = .GlobalEnv, quote = TRUE)), envir = .GlobalEnv, quote = TRUE), file = "/var/folders/7r/d3tp4w4171vc57vmhwy6fv940000gn/T//Rtmp5xMCHY/callr-res-3dbc82c94b") flush(stdout()) flush(stderr()) NULL invisible() }, error = function(e) { { callr_data <- as.environment("tools:callr")$`__callr_data__` err <- callr_data$err assign(".Traceback", .traceback(4), envir = callr_data) dump.frames("__callr_dump__") assign(".Last.dump", .GlobalEnv$`__callr_dump__`, envir = callr_data) rm("__callr_dump__", envir = .GlobalEnv) e$call <- deparse(conditionCall(e), nlines = 6) e2 <- err$new_error(conditionMessage(e), call. = conditionCall(e)) class(e2) <- c("callr_remote_error", class(e2)) e2$error <- e calls <- sys.calls() dcframe <- which(vapply(calls, function(x) length(x) >= 1 && identical(x[[1]], quote(do.call)), logical(1)))[1] if (!is.na(dcframe)) e2$`_ignore` <- list(c(1, dcframe + 1L)) e2$`_pid` <- Sys.getpid() e2$`_timestamp` <- Sys.time() if (inherits(e, "rlib_error_2_0")) e2$parent <- e$parent e2 <- err$add_trace_back(e2, embed = FALSE) saveRDS(list("error", e2), file = paste0("/var/folders/7r/d3tp4w4171vc57vmhwy6fv940000gn/T//Rtmp5xMCHY/callr-res-3dbc82c94b", ".error")) } }, interrupt = function(e) { { callr_data <- as.environment("tools:callr")$`__callr_data__` err <- callr_data$err assign(".Traceback", .traceback(4), envir = callr_data) dump.frames("__callr_dump__") assign(".Last.dump", .GlobalEnv$`__callr_dump__`, envir = callr_data) rm("__callr_dump__", envir = .GlobalEnv) e$call <- deparse(conditionCall(e), nlines = 6) e2 <- err$new_error(conditionMessage(e), call. = conditionCall(e)) class(e2) <- c("callr_remote_error", class(e2)) e2$error <- e calls <- sys.calls() dcframe <- which(vapply(calls, function(x) length(x) >= 1 && identical(x[[1]], quote(do.call)), logical(1)))[1] if (!is.na(dcframe)) e2$`_ignore` <- list(c(1, dcframe + 1L)) e2$`_pid` <- Sys.getpid() e2$`_timestamp` <- Sys.time() if (inherits(e, "rlib_error_2_0")) e2$parent <- e$parent e2 <- err$add_trace_back(e2, embed = FALSE) saveRDS(list("error", e2), file = paste0("/var/folders/7r/d3tp4w4171vc57vmhwy6fv940000gn/T//Rtmp5xMCHY/callr-res-3dbc82c94b", ".error")) } }, callr_message = function(e) { try(signalCondition(e)) }), error = function(e) { NULL try(stop(e)) }, interrupt = function(e) { NULL e }), tryCatchList(expr, classes, parentenv, handlers), tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), names[nh], parentenv, handlers[[nh]]), doTryCatch(return(expr), name, parentenv, handler), tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), tryCatchOne(expr, names, parentenv, handlers[[1L]]), doTryCatch(return(expr), name, parentenv, handler), withCallingHandlers({ NULL saveRDS(do.call(do.call, c(readRDS("/var/folders/7r/d3tp4w4171vc57vmhwy6fv940000gn/T//Rtmp5xMCHY/callr-fun-3db3e4c70d1"), list(envir = .GlobalEnv, quote = TRUE)), envir = .GlobalEnv, quote = TRUE), file = "/var/folders/7r/d3tp4w4171vc57vmhwy6fv940000gn/T//Rtmp5xMCHY/callr-res-3dbc82c94b") flush(stdout()) flush(stderr()) NULL invisible() }, error = function(e) { { callr_data <- as.environment("tools:callr")$`__callr_data__` err <- callr_data$err assign(".Traceback", .traceback(4), envir = callr_data) dump.frames("__callr_dump__") assign(".Last.dump", .GlobalEnv$`__callr_dump__`, envir = callr_data) rm("__callr_dump__", envir = .GlobalEnv) e$call <- deparse(conditionCall(e), nlines = 6) e2 <- err$new_error(conditionMessage(e), call. = conditionCall(e)) class(e2) <- c("callr_remote_error", class(e2)) e2$error <- e calls <- sys.calls() dcframe <- which(vapply(calls, function(x) length(x) >= 1 && identical(x[[1]], quote(do.call)), logical(1)))[1] if (!is.na(dcframe)) e2$`_ignore` <- list(c(1, dcframe + 1L)) e2$`_pid` <- Sys.getpid() e2$`_timestamp` <- Sys.time() if (inherits(e, "rlib_error_2_0")) e2$parent <- e$parent e2 <- err$add_trace_back(e2, embed = FALSE) saveRDS(list("error", e2), file = paste0("/var/folders/7r/d3tp4w4171vc57vmhwy6fv940000gn/T//Rtmp5xMCHY/callr-res-3dbc82c94b", ".error")) } }, interrupt = function(e) { { callr_data <- as.environment("tools:callr")$`__callr_data__` err <- callr_data$err assign(".Traceback", .traceback(4), envir = callr_data) dump.frames("__callr_dump__") assign(".Last.dump", .GlobalEnv$`__callr_dump__`, envir = callr_data) rm("__callr_dump__", envir = .GlobalEnv) e$call <- deparse(conditionCall(e), nlines = 6) e2 <- err$new_error(conditionMessage(e), call. = conditionCall(e)) class(e2) <- c("callr_remote_error", class(e2)) e2$error <- e calls <- sys.calls() dcframe <- which(vapply(calls, function(x) length(x) >= 1 && identical(x[[1]], quote(do.call)), logical(1)))[1] if (!is.na(dcframe)) e2$`_ignore` <- list(c(1, dcframe + 1L)) e2$`_pid` <- Sys.getpid() e2$`_timestamp` <- Sys.time() if (inherits(e, "rlib_error_2_0")) e2$parent <- e$parent e2 <- err$add_trace_back(e2, embed = FALSE) saveRDS(list("error", e2), file = paste0("/var/folders/7r/d3tp4w4171vc57vmhwy6fv940000gn/T//Rtmp5xMCHY/callr-res-3dbc82c94b", ".error")) } }, callr_message = function(e) { try(signalCondition(e)) }), saveRDS(do.call(do.call, c(readRDS("/var/folders/7r/d3tp4w4171vc57vmhwy6fv940000gn/T//Rtmp5xMCHY/callr-fun-3db3e4c70d1"), list(envir = .GlobalEnv, quote = TRUE)), envir = .GlobalEnv, quote = TRUE), file = "/var/folders/7r/d3tp4w4171vc57vmhwy6fv940000gn/T//Rtmp5xMCHY/callr-res-3dbc82c94b"), do.call(do.call, c(readRDS("/var/folders/7r/d3tp4w4171vc57vmhwy6fv940000gn/T//Rtmp5xMCHY/callr-fun-3db3e4c70d1"), list(envir = .GlobalEnv, quote = TRUE)), envir = .GlobalEnv, quote = TRUE), `<fn>`(base::quote(`<fn>`), base::quote(`<named list>`), envir = base::quote(`<env>`), quote = base::quote(TRUE)), `<fn>`(pkg = base::quote(`<pkgdown>`), examples = base::quote(TRUE), run_dont_run = base::quote(FALSE), seed = base::quote(1014), lazy = base::quote(FALSE), override = base::quote(`<list>`), install = base::quote(FALSE), preview = base::quote(FALSE), new_process = base::quote(FALSE), devel = base::quote(FALSE), crayon_enabled = base::quote(FALSE), crayon_colors = base::quote(1L), pkgdown_internet = base::quote(TRUE)), pkgdown::build_site(...), build_site_local(pkg = pkg, examples = examples, run_dont_run = run_dont_run, seed = seed, lazy = lazy, override = override, preview = preview, devel = devel), build_reference(pkg, lazy = lazy, examples = examples, run_dont_run = run_dont_run, seed = seed, override = override, preview = FALSE, devel = devel), purrr::map(topics, build_reference_topic, pkg = pkg, lazy = lazy, examples_env = examples_env, run_dont_run = run_dont_run), .f(.x[[i]], ...), withCallingHandlers(data_reference_topic(topic, pkg, examples_env = examples_env, run_dont_run = run_dont_run), error = function(err) { msg <- c(paste0("Failed to parse Rd in ", topic$file_in), i = err$message) abort(msg, parent = err) }), data_reference_topic(topic, pkg, examples_env = examples_env, run_dont_run = run_dont_run), run_examples(tags$tag_examples[[1]], env = if (is.null(examples_env)) NULL else new.env(parent = examples_env), topic = tools::file_path_sans_ext(topic$file_in), run_dont_run = run_dont_run), highlight_examples(code, topic, env = env), downlit::evaluate_and_highlight(code, fig_save = fig_save_topic, env = child_env(env), output_handler = evaluate::new_output_handler(value = pkgdown_print)), evaluate::evaluate(code, child_env(env), new_device = TRUE, output_handler = output_handler), evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos, debug = debug, last = i == length(out), use_try = stop_on_error != 2L, keep_warning = keep_warning, keep_message = keep_message, output_handler = output_handler, include_timing = include_timing), timing_fn(handle(ev <- withCallingHandlers(withVisible(eval_with_user_handlers(expr, envir, enclos, user_handlers)), warning = wHandler, error = eHandler, message = mHandler))), handle(ev <- withCallingHandlers(withVisible(eval_with_user_handlers(expr, envir, enclos, user_handlers)), warning = wHandler, error = eHandler, message = mHandler)), try(f, silent = TRUE), tryCatch(expr, error = function(e) { call <- conditionCall(e) if (!is.null(call)) { if (identical(call[[1L]], quote(doTryCatch))) call <- sys.call(-4L) dcall <- deparse(call, nlines = 1L) prefix <- paste("Error in", dcall, ": ") LONG <- 75L sm <- strsplit(conditionMessage(e), "\n")[[1L]] w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], type = "w") if (is.na(w)) w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L], type = "b") if (w > LONG) prefix <- paste0(prefix, "\n ") } else prefix <- "Error : " msg <- paste0(prefix, conditionMessage(e), "\n") .Internal(seterrmessage(msg[1L])) if (!silent && isTRUE(getOption("show.error.messages"))) { cat(msg, file = outFile) .Internal(printDeferredWarnings()) } invisible(structure(msg, class = "try-error", condition = e)) }), tryCatchList(expr, classes, parentenv, handlers), tryCatchOne(expr, names, parentenv, handlers[[1L]]), doTryCatch(return(expr), name, parentenv, handler), withCallingHandlers(withVisible(eval_with_user_handlers(expr, envir, enclos, user_handlers)), warning = wHandler, error = eHandler, message = mHandler), withVisible(eval_with_user_handlers(expr, envir, enclos, user_handlers)), eval_with_user_handlers(expr, envir, enclos, user_handlers), eval(expr, envir, enclos), eval(expr, envir, enclos), setup_dummy_db(), .events %>% dplyr::mutate(datetime = strftime(datetime), date = strftime(date, format = "%Y-%m-%d"), time = strftime(time, format = "%H:%M:%S")) %>% DBI::dbWriteTable(conn, "events", .), DBI::dbWriteTable(conn, "events", .), dplyr::mutate(., datetime = strftime(datetime), date = strftime(date, format = "%Y-%m-%d"), time = strftime(time, format = "%H:%M:%S")), mutate.data.frame(., datetime = strftime(datetime), date = strftime(date, format = "%Y-%m-%d"), time = strftime(time, format = "%H:%M:%S")), mutate_cols(.data, dplyr_quosures(...), caller_env = caller_env()), withCallingHandlers({ for (i in seq_along(dots)) { context_poke("column", old_current_column) quosures <- expand_across(dots[[i]]) quosures_results <- vector(mode = "list", length = length(quosures)) for (k in seq_along(quosures)) { quo <- quosures[[k]] quo_data <- attr(quo, "dplyr:::data") if (!is.null(quo_data$column)) { context_poke("column", quo_data$column) } chunks <- NULL result <- NULL if (quo_is_symbol(quo)) { name <- as_string(quo_get_expr(quo)) if (name %in% names(new_columns)) { result <- new_columns[[name]] chunks <- mask$resolve(name) } else if (name %in% names(.data)) { result <- .data[[name]] chunks <- mask$resolve(name) } if (inherits(.data, "rowwise_df") && vec_is_list(result)) { sizes <- list_sizes(result) wrong <- which(sizes != 1) if (length(wrong)) { group <- wrong[1L] mask$set_current_group(group) abort(class = c("dplyr:::mutate_incompatible_size", "dplyr:::internal_error"), dplyr_error_data = list(result_size = sizes[group], expected_size = 1)) } } } else if (!quo_is_symbolic(quo) && !is.null(quo_get_expr(quo))) { result <- quo_get_expr(quo) result <- withCallingHandlers(vec_recycle(result, vec_size(.data)), error = function(cnd) { abort(class = c("dplyr:::mutate_constant_recycle_error", "dplyr:::internal_error"), constant_size = vec_size(result), data_size = vec_size(.data)) }) chunks <- vec_chop(result, rows) } if (is.null(chunks)) { if (is.null(quo_data$column)) { chunks <- mask$eval_all_mutate(quo) } else { chunks <- withCallingHandlers(mask$eval_all_mutate(quo), error = function(cnd) { msg <- glue("Problem while computing column `{quo_data$name_auto}`.") abort(msg, call = call("across"), parent = cnd) }) } } if (is.null(chunks)) { next } if (is.null(result)) { if (length(rows) == 1) { result <- chunks[[1]] } else { chunks <- dplyr_vec_cast_common(chunks, quo_data$name_auto) result <- vec_unchop(chunks, rows) } } quosures_results[[k]] <- list(result = result, chunks = chunks) } for (k in seq_along(quosures)) { quo <- quosures[[k]] quo_data <- attr(quo, "dplyr:::data") quo_result <- quosures_results[[k]] if (is.null(quo_result)) { if (quo_data$is_named) { name <- quo_data$name_given new_columns[[name]] <- zap() mask$remove(name) } next } result <- quo_result$result chunks <- quo_result$chunks if (!quo_data$is_named && is.data.frame(result)) { types <- vec_ptype(result) types_names <- names(types) chunks_extracted <- .Call(dplyr_extract_chunks, chunks, types) for (j in seq_along(types)) { mask$add_one(types_names[j], chunks_extracted[[j]], result = result[[j]]) } new_columns[types_names] <- result } else { name <- quo_data$name_auto mask$add_one(name = name, chunks = chunks, result = result) new_columns[[name]] <- result } } } }, error = function(e) { local_error_context(dots = dots, .index = i, mask = mask) bullets <- c(cnd_bullet_header("computing"), mutate_bullets(e)) abort(bullets, class = "dplyr:::mutate_error", parent = skip_internal_condition(e), bullets = bullets, call = error_call) }, warning = function(w) { if (check_muffled_warning(w)) { maybe_restart("muffleWarning") } local_error_context(dots = dots, .index = i, mask = mask) warn(c(cnd_bullet_header("computing"), i = cnd_header(w), i = cnd_bullet_cur_group_label(what = "warning"))) maybe_restart("muffleWarning") }), mask$eval_all_mutate(quo), strftime(time, format = "%H:%M:%S"), format(as.POSIXlt(x, tz = tz), format = format, usetz = usetz, ...), as.POSIXlt(x, tz = tz), as.POSIXlt.default(x, tz = tz), stop(gettextf("do not know how to convert '%s' to class %s", deparse1(substitute(x)), dQuote("POSIXlt")), domain = NA), .handleSimpleError(`<fn>`, "do not know how to convert 'x' to class “POSIXlt”", base::quote(as.POSIXlt.default(x, tz = tz))), h(simpleError(msg, call)), abort(bullets, class = "dplyr:::mutate_error", parent = skip_internal_condition(e), bullets = bullets, call = error_call)), parent = c(0L, 1L, 2L, 3L, 2L, 5L, 6L, 0L, 0L, 0L, 0L, 0L, 12L, 13L, 14L, 15L, 16L, 17L, 17L, 19L, 20L, 21L, 22L, 23L, 24L, 24L, 26L, 27L, 28L, 29L, 30L, 24L, 24L, 24L, 34L, 35L, 36L, 37L, 0L, 0L, 0L, 41L, 42L, 42L, 0L, 45L, 45L, 45L, 48L, 0L, 50L, 51L), visible = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE), namespace = c("base", "base", "base", "base", "base", "base", "base", "base", "base", "base", "base", NA, "pkgdown", "pkgdown", "pkgdown", "purrr", "pkgdown", "base", "pkgdown", "pkgdown", "pkgdown", "downlit", "evaluate", "evaluate", "evaluate", "evaluate", "base", "base", "base", "base", "base", "base", "base", "evaluate", "base", "base", "wranglEHR", NA, "DBI", "dplyr", "dplyr", "dplyr", "base", NA, "base", "base", "base", "base", "base", "base", "dplyr", "rlang"), scope = c("::", "local", "local", "local", "local", "local", "local", "::", "::", "::", "local", "global", "::", ":::", "::", "::", "local", "::", ":::", ":::", ":::", "::", "::", ":::", "local", "local", "::", "::", "local", "local", "local", "::", "::", ":::", "::", "::", "::", NA, "::", "::", ":::", ":::", "::", NA, "::", "::", "::", "::", "::", "::", "local", "::")), row.names = c(NA, -52L), version = 2L, class = c("rlang_trace", "rlib_trace", "tbl", "data.frame")), parent = structure(list( message = "do not know how to convert 'x' to class “POSIXlt”", call = as.POSIXlt.default(x, tz = tz)), class = c("simpleError", "error", "condition")), bullets = "Problem while computing `time = strftime(time, format = \"%H:%M:%S\")`.", call = dplyr::mutate(., datetime = strftime(datetime), date = strftime(date, format = "%Y-%m-%d"), time = strftime(time, format = "%H:%M:%S")), use_cli_format = TRUE), class = c("dplyr:::mutate_error", "rlang_error", "error", "condition"))): error in evaluating the argument 'value' in selecting a method for function 'dbWriteTable': Problem while computing `time = strftime(time, format = "%H:%M:%S")`.
#> Caused by error in `as.POSIXlt.default()`:
#> ! do not know how to convert 'x' to class “POSIXlt”
dtb <- extract_demographics(
connection = con,
episode_ids = 1:10,
code_names = hic_codes,
rename = new_labels)
#> Error in extract_demographics(connection = con, episode_ids = 1:10, code_names = hic_codes, rename = new_labels): object 'con' not found
head(dtb)
#> Error in head(dtb): object 'dtb' not found