Nothing
########
# Simple Plots (these may spin into their own script like shark_plots)
########
#' Objective function changes across models
#'
#' @description
#' Another visualization of how individual objective functions change over
#' the course of model development.
#'
#'
#' @inheritParams xplot_boxplot
#' @param xpdb_s <`xpose_set`> object
#' @param ... <`tidyselect`> of models in set. If empty, all models are
#' used in order of their position in the set. May also use a formula,
#' which will just be processed with `all.vars()`.
#' @param .lineage <`logical`> where if `TRUE`, `...` is processed
#' @param auto_backfill <`logical`> If `TRUE`, apply <[`backfill_iofv()`]>
#' automatically. `FALSE` by default to encourage data control as a
#' separate process to plotting control.
#' @param type Passed to <[`xplot_boxplot`]>
#' @param axis.text What to label the model. This is parsed on a per-model
#' basis.
#' @param facets Additional facets
#' @param .problem Problem number
#' @param quiet Silence output
#'
#' @export
#' @returns The desired plot
#'
#' @examples
#' \donttest{
#'
#' pheno_set %>%
#' focus_qapply(backfill_iofv) %>%
#' iofv_vs_mod()
#'
#' pheno_set %>%
#' focus_qapply(backfill_iofv) %>%
#' iofv_vs_mod(run3,run11,run14,run15)
#'
#' pheno_set %>%
#' focus_qapply(backfill_iofv) %>%
#' iofv_vs_mod(.lineage = TRUE)
#'
#' }
iofv_vs_mod <- function(
xpdb_s,
...,
.lineage = FALSE,
auto_backfill = FALSE,
mapping = NULL,
orientation = "x",
type = 'bjc',
title = 'Individual OFVs across models',
subtitle = 'Based on @nind individuals, Initial OFV: @ofv',
caption = 'Initial @dir',
tag = NULL,
axis.text = "@run",
facets,
.problem,
quiet
) {
check_xpose_set(xpdb_s)
# Make sure dots are unnamed
rlang::check_dots_unnamed()
n_set_dots(xpdb_s, ..., .lineage=.lineage) # makes `mods`
pre_process <- function(x) unfocus_xpdb(x)
if (auto_backfill==TRUE) pre_process <- function(x) focus_qapply(x, backfill_iofv)
xpose_subset <- xpdb_s %>% pre_process() %>% select(!!mods)
# extra checks
if (missing(.problem))
.problem <- xpose::default_plot_problem(xpose_subset[[1]]$xpdb)
xpose::check_problem(.problem, .subprob = NULL, .method = NULL)
if (missing(quiet))
quiet <- xpose_subset[[1]]$xpdb$options$quiet
if (missing(facets))
facets <- xpose_subset[[1]]$xpdb$xp_theme$facets
xpdb_l <- purrr::map(xpose_subset, ~.x$xpdb)
rlang::try_fetch(
ofv_cols <- purrr::map_chr(xpdb_l,
~xp_var(.x, type="iofv", silent=TRUE)$col[1]),
error = function(s) {
rlang::abort(auto_backfill_suggestion, parent = s)
}
)
ofv_frk_cols <- paste0(ofv_cols,"_",seq_along(ofv_cols))
nicer_labs <- purrr::map_chr(xpdb_l,~xpose::parse_title(axis.text,.x, .problem))
# Get combined xpdb
xpdb_f <- franken_xpdb(
!!!xpdb_l,
.types = "iofv",
problem = .problem
)
post_processing <- function(df) {
df %>%
# Relabel variable
dplyr::mutate(
variable = nicer_labs[match(variable,ofv_frk_cols)] %>%
forcats::as_factor() %>%
forcats::fct_inorder()
)
}
opt <- xpose::data_opt(.problem = .problem,
filter = xpose::only_distinct(xpdb_f, .problem, facets, quiet),
tidy = TRUE, value_col = ofv_frk_cols, post_processing = post_processing)
if (orientation=="x") {
vars <- xpose::aes_c(aes(
x = .data[["variable"]],
y = .data[["value"]]), mapping)
xscale = "discrete"
yscale = xpose::check_scales('y', NULL)
} else {
vars <- xpose::aes_c(aes(
x = .data[["value"]],
y = .data[["variable"]]), mapping)
yscale = "discrete"
xscale = xpose::check_scales('x', NULL)
}
really_quiet <- function(x) x
if (quiet) really_quiet <- function(x) suppressWarnings(x) # <- trivial reshape warning silenced
really_quiet(xplot_boxplot(
xpdb = xpdb_f,
quiet = quiet,
opt = opt,
mapping = vars,
type = type,
facets = facets,
xscale = xscale,
yscale = yscale,
orientation = orientation,
title = title,
subtitle = subtitle, caption = caption,
tag = tag,
plot_name = stringr::str_remove(deparse(match.call()[[1]]), "(\\w+\\.*)+::")))
}
#' Specific waterfall plots
#'
#' @description
#' Differences are second listed model minus first listed. Eg, in
#' `eta_waterfall(run1,run2)`, the when etas in run2 are greater than
#' those in run1, the difference will be positive.
#'
#'
#' @rdname waterfalls
#'
#' @inheritParams xset_waterfall
#'
#' @return <`xpose_plot`> object
#' @export
#'
#'
#' @details
#' For type-based customization of plots:
#' \itemize{
#' \item `b` bar plot (from `geom_bar`)
#' \item `h` hline at 0 (from `geom_hline`)
#' \item `t` text of change value (from `geom_text`)
#' }
#'
#'
#' @examples
#'
#' # Parameter value changes
#' pheno_set %>%
#' # Ensure param is set
#' focus_qapply(set_var_types, param=c(CL,V)) %>%
#' prm_waterfall(run5,run6)
#'
#'
#' # EBE value changes
#' pheno_set %>%
#' eta_waterfall(run5,run6)
#'
#' # iOFV changes
#' pheno_set %>%
#' focus_qapply(backfill_iofv) %>%
#' # Note the default scaling is flipped here
#' iofv_waterfall(run5,run6)
#'
#'
prm_waterfall <- function(
xpdb_s,
...,
.inorder=FALSE,
type = "bh",
max_nind = 0.7,
scale_diff = TRUE,
show_n = TRUE,
title = "Parameter changes between models | @run",
subtitle = "Based on @nobs observations in @nind individuals",
caption = "@dir",
tag = NULL,
facets = NULL,
facet_scales = "free_x",
.problem,
.subprob,
.method,
quiet
) {
# process dots (this is also done in forwarded model, but need to do here. Plus it's fast enough)
two_set_dots(xpdb_s, ..., .inorder=.inorder)
# Now have mod1 and mod2
# Get params
waterfall_helper("param", "parameter")
xset_waterfall(
xpdb_s = xpdb_s,
...,
.inorder=.inorder,
type = type,
.cols = dplyr::all_of(c(m1col)),
max_nind = max_nind,
scale_diff = scale_diff,
show_n = show_n,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
plot_name = 'prm_waterfall',
facets = facets,
facet_scales = facet_scales,
.problem=.problem,
.subprob=.subprob,
.method=.method,
quiet=quiet
)
}
#' @rdname waterfalls
#' @export
eta_waterfall <- function(
xpdb_s,
...,
.inorder=FALSE,
type = "bh",
max_nind = 0.7,
scale_diff = TRUE,
show_n = TRUE,
title = "Eta changes between models | @run",
subtitle = "Based on @nobs observations in @nind individuals",
caption = "@dir",
tag = NULL,
facets = NULL,
facet_scales = "free_x",
.problem,
.subprob,
.method,
quiet
) {
# process dots (this is also done in forwarded model, but need to do here. Plus it's fast enough)
two_set_dots(xpdb_s, ..., .inorder=.inorder)
# Now have mod1 and mod2
# Get etas
waterfall_helper("eta", "eta")
# Eta label consistency
if (xpose::software(mod1$xpdb) == 'nonmem') {
post_processing <- function(x) {
x %>%
dplyr::mutate(
variable = stringr::str_replace(variable, "^ET(A?)(\\d+)$", "ETA(\\2)")
)
}
} else {
post_processing <- function(x) x
}
xset_waterfall(
xpdb_s = xpdb_s,
...,
.inorder=.inorder,
type = type,
.cols = dplyr::all_of(c(m1col)),
max_nind = max_nind,
scale_diff = scale_diff,
show_n = show_n,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
plot_name = 'eta_waterfall',
facets = facets,
facet_scales = facet_scales,
opt = xpose::data_opt(post_processing = post_processing),
.problem=.problem,
.subprob=.subprob,
.method=.method,
quiet=quiet
)
}
#' @rdname waterfalls
#' @export
iofv_waterfall <- function(
xpdb_s,
...,
.inorder=FALSE,
type = "bh",
max_nind = 0.7,
scale_diff = FALSE,
show_n = TRUE,
title = "iOFV changes between models | @run",
subtitle = "Based on @nobs observations in @nind individuals",
caption = "@dir",
tag = NULL,
facets = NULL,
facet_scales = "free_x",
.problem,
.subprob,
.method,
quiet
) {
# process dots (this is also done in forwarded model, but need to do here. Plus it's fast enough)
two_set_dots(xpdb_s, ..., .inorder=.inorder)
# Now have mod1 and mod2
# Get values
waterfall_helper("iofv", "iOFV")
xset_waterfall(
xpdb_s = xpdb_s,
...,
.inorder=.inorder,
type = type,
.cols = dplyr::all_of(c(m1col)),
max_nind = max_nind,
scale_diff = scale_diff,
show_n = show_n,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
plot_name = 'ofv_waterfall',
facets = facets,
facet_scales = facet_scales,
.problem=.problem,
.subprob=.subprob,
.method=.method,
quiet=quiet
)
}
#' Compare model predictions
#'
#' @rdname pred_vs_pred
#'
#' @description
#' For two models in an `xpose_set`, these functions are useful in comparing individual
#' and population predictions
#'
#' @param xpdb_s <`xpose_set`> object
#' @param ... See <[`two_set_dots`]>
#' @param .inorder See <[`two_set_dots`]>
#' @param type Passed to `xplot_scatter`
#' @param title Plot title
#' @param subtitle Plot subtitle
#' @param caption Plot caption
#' @param tag Plot tag
#' @param log Log scale covariate value?
#' @param guide Add guide line?
#' @param facets Additional facets
#' @param .problem Problem number
#' @param quiet Silence output
#'
#' @export
#'
#' @examples
#'
#' pheno_set %>%
#' ipred_vs_ipred(run5,run15)
#'
#' pheno_set %>%
#' pred_vs_pred(run5,run15)
#'
ipred_vs_ipred <- function(
xpdb_s,
...,
.inorder=FALSE,
type = "pls",
title = "Individual prediction comparison | @run",
subtitle = "Ofv: @ofv, Eps shrink: @epsshk",
caption = "@dir",
tag = NULL,
log = NULL,
guide = TRUE,
facets,
.problem,
quiet) {
# process dots
two_set_dots(xpdb_s, ..., .inorder=.inorder)
# Now have mod1 and mod2
# extra checks
if (missing(.problem))
.problem <- xpose::default_plot_problem(mod1$xpdb)
xpose::check_problem(.problem, .subprob = NULL, .method = NULL)
if (missing(quiet))
quiet <- mod1$xpdb$options$quiet
if (missing(facets))
facets <- mod1$xpdb$xp_theme$facets
# Use waterfall helper to make sure ipred is available and column names match
waterfall_helper("ipred", "IPRED")
# Get combined xpdb
xpdb_f <- franken_xpdb(
mod1$xpdb,
mod2$xpdb,
.types = "ipred",
problem = .problem,
prop_transforms = function(xpdb_f, xpdb_list, problem) {
# Combine OFV
updated <- franken_prop(
xpdb_f = xpdb_f,
xpdb_list = xpdb_list,
prop = "ofv",
problem = problem,
glue_cmd = franken_numprop)
# Combine epsshk
updated <- franken_prop(
xpdb_f = updated,
xpdb_list = xpdb_list,
prop = "epsshk",
problem = problem,
glue_cmd = franken_numprop)
# Combine dir
updated <- franken_prop(
xpdb_f = updated,
xpdb_list = xpdb_list,
prop = "dir")
updated
}
)
# TODO: add post-processing for levels labels etc of facets
new_col_names <- paste0(c(
m1col, m2col # should be the same, still
), " (", c(
get_prop(mod1$xpdb, "run"),
get_prop(mod2$xpdb, "run")
), ")")
post_processing <- function(df) {
df %>%
dplyr::rename_with(~dplyr::case_when(
grepl(sprintf("^%s_1$",m1col), .x) ~ new_col_names[1],
grepl(sprintf("^%s_2$",m2col), .x) ~ new_col_names[2],
TRUE ~ .x
))
}
xpose::xplot_scatter(
xpdb = xpdb_f,
mapping = aes(
x = .data[[new_col_names[1]]],
y = .data[[new_col_names[2]]]
),
opt = xpose::data_opt(.problem = .problem, filter = xpose::only_obs(xpdb_f, .problem, quiet),
post_processing = post_processing),
guide = guide,
guide_slope = 1,
facets = facets,
xscale = xpose::check_scales("x", log),
yscale = xpose::check_scales("y", log),
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
quiet = quiet,
plot_name = stringr::str_remove(deparse(match.call()[[1]]),"(\\w+\\.*)+::")
)
}
#' @rdname pred_vs_pred
#' @returns The desired plot
#' @export
pred_vs_pred <- function(
xpdb_s,
...,
.inorder=FALSE,
type = "pls",
title = "Population prediction comparison | @run",
subtitle = "Ofv: @ofv, Eps shrink: @epsshk",
caption = "@dir",
tag = NULL,
log = NULL,
guide = TRUE,
facets,
.problem,
quiet) {
# process dots
two_set_dots(xpdb_s, ..., .inorder=.inorder)
# Now have mod1 and mod2
# extra checks
if (missing(.problem))
.problem <- xpose::default_plot_problem(mod1$xpdb)
xpose::check_problem(.problem, .subprob = NULL, .method = NULL)
if (missing(quiet))
quiet <- mod1$xpdb$options$quiet
if (missing(facets))
facets <- mod1$xpdb$xp_theme$facets
# Use waterfall helper to make sure ipred is available and column names match
waterfall_helper("pred", "PRED")
# Get combined xpdb
xpdb_f <- franken_xpdb(
mod1$xpdb,
mod2$xpdb,
.types = "pred",
problem = .problem,
prop_transforms = function(xpdb_f, xpdb_list, problem) {
# Combine OFV
updated <- franken_prop(
xpdb_f = xpdb_f,
xpdb_list = xpdb_list,
prop = "ofv",
problem = problem,
glue_cmd = franken_numprop)
# Combine epsshk
updated <- franken_prop(
xpdb_f = updated,
xpdb_list = xpdb_list,
prop = "epsshk",
problem = problem,
glue_cmd = franken_numprop)
# Combine dir
updated <- franken_prop(
xpdb_f = updated,
xpdb_list = xpdb_list,
prop = "dir")
updated
}
)
# TODO: add post-processing for levels labels etc of facets
new_col_names <- paste0(c(
m1col, m2col # should be the same, still
), " (", c(
get_prop(mod1$xpdb, "run"),
get_prop(mod2$xpdb, "run")
), ")")
post_processing <- function(df) {
df %>%
dplyr::rename_with(~dplyr::case_when(
grepl(sprintf("^%s_1$",m1col), .x) ~ new_col_names[1],
grepl(sprintf("^%s_2$",m2col), .x) ~ new_col_names[2],
TRUE ~ .x
))
}
xpose::xplot_scatter(
xpdb = xpdb_f,
mapping = aes(
x = .data[[new_col_names[1]]],
y = .data[[new_col_names[2]]]
),
opt = xpose::data_opt(.problem = .problem, filter = xpose::only_obs(xpdb_f, .problem, quiet),
post_processing = post_processing),
guide = guide,
guide_slope = 1,
facets = facets,
xscale = xpose::check_scales("x", log),
yscale = xpose::check_scales("y", log),
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
quiet = quiet,
plot_name = stringr::str_remove(deparse(match.call()[[1]]),"(\\w+\\.*)+::")
)
}
# This would also just be an in situ xpdb, but there may need to be a function
# for model-averaging
#' Model average plots
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' This is for use when the model averaging of a set
#' is planned.
#'
#'
#' @inheritParams modavg_xpdb
#' @param .fun <`function`> For slightly more convenient
#' piping of model-averaged `xpose_data` into a plotting
#' function.
#' @param .funargs <`list`> Extra args to pass to function.
#' If passing `tidyselect` arguments, be mindful of where
#' quosures might be needed. See Examples.
#'
#' @seealso [modavg_xpdb()]
#' @returns The desired plot
#'
#' @rdname modavg_plots
#' @export
#'
#' @examples
#' \donttest{
#'
#' pheno_set %>%
#' dv_vs_ipred_modavg(run8,run9,run10, auto_backfill = TRUE)
#'
#' pheno_set %>%
#' dv_vs_pred_modavg(run8,run9,run10, auto_backfill = TRUE)
#'
#' pheno_set %>%
#' ipred_vs_idv_modavg(run8,run9,run10, auto_backfill = TRUE)
#'
#' pheno_set %>%
#' pred_vs_idv_modavg(run8,run9,run10, auto_backfill = TRUE)
#'
#' # Model averaged ETA covariates
#' pheno_set %>%
#' plotfun_modavg(run8,run9,run10, auto_backfill = TRUE,
#' avg_by_type = "eta",.fun = eta_vs_catcov,
#' # Note quoting
#' .funargs = list(etavar=quote(ETA1)))
#'
#' }
dv_vs_ipred_modavg <- function(
xpdb_s,
...,
.lineage = FALSE,
algorithm = c("maa","msa"),
weight_type = c("individual","population"),
auto_backfill = FALSE,
weight_basis = c("ofv","aic","res"),
res_col = "RES",
quiet) {
plotfun_modavg(
xpdb_s=xpdb_s,
...,
.lineage = .lineage,
avg_by_type = "ipred",
algorithm = algorithm,
weight_type = weight_type,
auto_backfill = auto_backfill,
weight_basis = weight_basis,
res_col = res_col,
.fun = xpose::dv_vs_ipred,
quiet=quiet
)
}
#' @rdname modavg_plots
#' @export
dv_vs_pred_modavg <- function(
xpdb_s,
...,
.lineage = FALSE,
algorithm = c("maa","msa"),
weight_type = c("individual","population"),
auto_backfill = FALSE,
weight_basis = c("ofv","aic","res"),
res_col = "RES",
quiet) {
plotfun_modavg(
xpdb_s=xpdb_s,
...,
.lineage = .lineage,
avg_by_type = "pred",
algorithm = algorithm,
weight_type = weight_type,
auto_backfill = auto_backfill,
weight_basis = weight_basis,
res_col = res_col,
.fun = xpose::dv_vs_pred,
quiet=quiet
)
}
#' @rdname modavg_plots
#' @export
ipred_vs_idv_modavg <- function(
xpdb_s,
...,
.lineage = FALSE,
algorithm = c("maa","msa"),
weight_type = c("individual","population"),
auto_backfill = FALSE,
weight_basis = c("ofv","aic","res"),
res_col = "RES",
quiet) {
plotfun_modavg(
xpdb_s=xpdb_s,
...,
.lineage = .lineage,
avg_by_type = "ipred",
algorithm = algorithm,
weight_type = weight_type,
auto_backfill = auto_backfill,
weight_basis = weight_basis,
res_col = res_col,
.fun = xpose::ipred_vs_idv,
quiet=quiet
)
}
#' @rdname modavg_plots
#' @export
pred_vs_idv_modavg <- function(
xpdb_s,
...,
.lineage = FALSE,
algorithm = c("maa","msa"),
weight_type = c("individual","population"),
auto_backfill = FALSE,
weight_basis = c("ofv","aic","res"),
res_col = "RES",
quiet) {
plotfun_modavg(
xpdb_s=xpdb_s,
...,
.lineage = .lineage,
avg_by_type = "pred",
algorithm = algorithm,
weight_type = weight_type,
auto_backfill = auto_backfill,
weight_basis = weight_basis,
res_col = res_col,
.fun = xpose::pred_vs_idv,
quiet=quiet
)
}
#' @rdname modavg_plots
#' @export
plotfun_modavg <- function(
xpdb_s,
...,
.lineage = FALSE,
avg_cols = NULL,
avg_by_type = NULL,
algorithm = c("maa","msa"),
weight_type = c("individual","population"),
auto_backfill = FALSE,
weight_basis = c("ofv","aic","res"),
res_col = "RES",
.fun = NULL,
.funargs = list(),
quiet) {
if (!is.function(.fun))
cli::cli_abort("`.fun` must be a function, not a {.emphasis {class(.fun)[1]}}")
# Prevent potentially common partial_match confusion
if ("xpdb" %in% rlang::call_args_names(rlang::frame_call())) {
if (xpose::is.xpdb(xpdb_s))
rlang::abort("An `xpose_set` is required, not an `xpose_data` item.")
}
# Any .funargs in dots?
dots_args <- rlang::enquos(..., .ignore_empty = "all", .unquote_names = TRUE)
dots_names <- names(dots_args)
ignore_check <- dots_names %in% c("xpdb","...",".")
funarg_check <- dots_names %in% names(formals(.fun))
funarg_dots <- dots_args[funarg_check]# & !ignore_check]
if (length(funarg_dots)>0) .funargs <- modifyList(
.funargs,
purrr::map(funarg_dots, rlang::eval_tidy)#, env = environment())
)
select_dots <- dots_args[!funarg_check]# & !ignore_check]
maXPDB <- rlang::inject(modavg_xpdb(
xpdb_s=xpdb_s,
!!!select_dots,
.lineage = .lineage,
avg_cols = avg_cols,
avg_by_type = avg_by_type,
algorithm = algorithm,
weight_type = weight_type,
auto_backfill = auto_backfill,
weight_basis = weight_basis,
res_col = res_col,
quiet=quiet
))
if (!missing(quiet)) .funargs$quiet <- quiet
if (!"title" %in% names(.funargs)) .funargs$title <- paste(
"Model averaged",
formals(.fun)$title
)
approach_that_works <- function(...) {
.fun(
maXPDB,
...
)
}
# works but doesn't have the same flexibility
# .fun(
# maXPDB,
# title = paste(
# "Model averaged",
# formals(.fun)$title
# )
# )
# Along with do.call, seemingly doesn't work
# rlang::exec(
# .fun,
# xpdb = maXPDB,
# title = paste(
# "Model averaged",
# formals(.fun)$title
# ),
# !!!.funargs
# )
rlang::exec(
approach_that_works,
!!!.funargs
)
}
########
# Helper functions (general)
########
#' Typical processing for plots of 2 sets
#'
#' @param xpdb_s <`xpose_set`> object
#' @param ... <[`dynamic-dots`][rlang::dyn-dots]> Passed to <[`select_subset`]>
#' @param .inorder <`logical`> Regardless of base model or parentage, use the
#' two plots in order of how they are in arguments. First plot listed is treated
#' as base or parent.
#' @param envir Where to assign `mod1` and `mod2` <`xpose_set_item`>s
#'
#' @returns Into environment specified by `envir`, <`xpose_set_item`> `mod1` and `mod2`
#' @keywords internal
#'
#' @details
#' Note that this function does not return valid `xpdb`-like objects (<`xpose_data`>
#' or <`xp_xtras`>). The necessary objects for most functions can be retrieved using
#' `mod1$xpdb` and `mod2$xpdb`.
#'
#'
two_set_dots <- function(
xpdb_s,
...,
.inorder=FALSE,
envir = parent.frame()
) {
check_xpose_set(xpdb_s, .warn = FALSE)
if (length(xpdb_s)<2) {
cli::cli_abort("Need at least two models in set.")
}
#if (identical(envir,.GlobalEnv)) rlang::abort("`two_set_dots` must be run inside a non-global environment")
tidyselect_check <- xpdb_s %>% select_subset(...) %>% length()
# Process dots
if (rlang::dots_n(...)==0 && length(xpdb_s)!=2) {
cli::cli_abort("Need to select at least two models in set or use a length 2 set.")
} else if (rlang::dots_n(...)==0) {
return(two_set_dots(
xpdb_s,
!!names(xpdb_s)[1],
!!names(xpdb_s)[2],
.inorder = .inorder,
envir = envir))
} else if (rlang::dots_n(...)!=2 && tidyselect_check!=2) {
cli::cli_abort("Need to select exactly two models in set.")
} else if (rlang::dots_n(...)==2 || tidyselect_check==2) {
dot_mods <- select_subset(xpdb_s, ...)
base_name <- get_base_model(xpdb_s)
parent_name <- names(dot_mods)[c(
xpdb_s[[dot_mods[1]]] %p% xpdb_s[[dot_mods[2]]],
xpdb_s[[dot_mods[2]]] %p% xpdb_s[[dot_mods[1]]]
)]
base_mod_irrelevant <- length(base_name)==0 || !base_name %in% names(dot_mods)
neither_is_parent <- length(parent_name)==0
no_base_or_parent <- base_mod_irrelevant && neither_is_parent
if (no_base_or_parent ||
isTRUE(.inorder)) {
mod1 <- xpdb_s[[dot_mods[1]]]
mod2 <- xpdb_s[[dot_mods[2]]]
assign("mod1", mod1, envir = envir)
assign("mod2", mod2, envir = envir)
return()
}
if (!base_mod_irrelevant) {
mod1 <- xpdb_s[[base_name]]
mod2 <- xpdb_s[[names(dot_mods)[names(dot_mods)!=base_name]]]
assign("mod1", mod1, envir = envir)
assign("mod2", mod2, envir = envir)
return()
}
if (!neither_is_parent) {
mod1 <- xpdb_s[[parent_name]]
mod2 <- xpdb_s[[names(dot_mods)[names(dot_mods)!=parent_name]]]
assign("mod1", mod1, envir = envir)
assign("mod2", mod2, envir = envir)
return()
}
cli::cli_abort()
}
}
# Generalization of two_set_dots, only used in a few functions
n_set_dots <- function(
xpdb_s,
...,
.lineage=FALSE,
envir = parent.frame()
) {
tidyselect_check <- FALSE
try_tidy <- try(select_subset(xpdb_s, ...), silent = TRUE)
if (!"try-error" %in% class(try_tidy)) tidyselect_check <- TRUE
#if (identical(envir,.GlobalEnv)) rlang::abort("`n_set_dots` must be run inside a non-global environment")
if (.lineage == TRUE) {
mods <- xset_lineage(xpdb_s, ..., .spinner = FALSE)
if (is.list(mods)) {
rlang::abort(paste(
"`xset_lineage()` returned a list.",
"If requesting to process `...` as a lineage, cannot request multiple lineages.",
"Specifically, `...` should be empty or a single model name."
))
}
} else if (rlang::dots_n(...) == 0) {
mods <- names(xpdb_s)
} else if (rlang::dots_n(...) == 1 && !tidyselect_check && suppressWarnings(is_formula_list(rlang::dots_list(...)))) {
# Warning is meaningless for this case, is using tidyselect in dots (eg, all_of(charcater list))
mods <- all.vars(rlang::dots_list(...)[[1]])
} else {
mods <- select_subset(xpdb_s, ...) %>% names()
}
if (any(!mods %in% names(xpdb_s)) && !tidyselect_check) {
cli::cli_abort("Selected models not in set: {.strong {setdiff(mods, names(xpdb_s))}}")
}
assign("mods",mods,envir = envir)
NULL
}
#' Combine several `xpose_data` objects into one
#'
#' @description
#' This is an internal function designed to meet the needs
#' of specific plotting functions
#'
#'
#' @param ... <[`dynamic-dots`][rlang::dyn-dots]> `xpose_data` or `xp_xtra` objects
#' @param .cols <`tidyselect`> of data columns
#' @param .types <`character`> of data types in addition to columns
#' @param prop_transforms <`function`> Extra processing using <[`franken_prop`]>
#' @param problem <`numeric`> Problems to look for `cols` and `types` (defaults all)
#' @param quiet Prevents extra output.
#'
#' @return The first `xpose_data` object with new data columns
#' @keywords internal
#' @export
#'
#' @examples
#'
#'
#' franken_xpdb(pheno_base, pheno_final, .types="catcov") %>%
#' xpose::get_data() %>%
#' select(starts_with("APGR"))
#'
franken_xpdb <- function(
...,
.cols = NULL,
.types = NULL,
prop_transforms = NULL,
problem,
quiet = TRUE
) {
rlang::check_dots_unnamed()
if (length(rlang::list2(...))<2) {
cli::cli_abort("Need at least two `xpose_data` or `xp_xtra` objects.")
}
if (is.null(.types) && rlang::quo_is_null(rlang::enquo(.cols)))
rlang::abort("Need `.cols` and/or `.types` to add into new object.")
# See if .cols is character
char_cols_check <- suppressWarnings(try(.cols,silent = TRUE))
if (!rlang::quo_is_null(rlang::enquo(.cols)) &&
!"try-error" %in% class(char_cols_check)) {
.cols <- suppressWarnings(all_of(.cols))
}
xpdb_list <- rlang::dots_list(...)
if (missing(problem)) problem <- xpose::all_data_problem(xpdb_list[[1]])
if (is.null(prop_transforms)) {
prop_transforms = function(xpdb_f, xpdb_list, problem) {
xpdb_f
}
}
# Make sure all data are compatible while extracting data
prob_data <- purrr::map(problem, ~vector(mode="list", length = length(xpdb_list)))
for (index in seq_along(xpdb_list)) {
db <- xpdb_list[[index]]
xpose::check_xpdb(db, check="data")
for (probi in seq_along(problem)) {
prob <- problem[probi]
if (!prob %in% xpose::all_data_problem(db))
cli::cli_abort("No prob no.{prob} in {.strong {get_prop(db, 'run')}}")
# Types check (and get cols)
tcols <- NULL
if (!is.null(.types))
tcols <- rlang::try_fetch(
xp_var(db, .problem = prob, type = .types)$col,
error = function(s) {
rlang::abort(
paste("Error with `xpose_data` for prob no.",prob,"in",get_prop(db, 'run')),
parent = s
)
})
# Get data
this_data <- xpose::get_data(db, .problem = prob, quiet=quiet)
# nrow check
prev_nrow <- nrow(this_data)
if (index>1) prev_nrow <- prob_data[[prob]] %>% .[[index-1]] %>% nrow()
if (nrow(this_data)!=prev_nrow)
cli::cli_abort(paste0("{.strong {get_prop(db, 'run')}} has {nrow(this_data)} rows",
", which does not match previous {prev_nrow} rows."))
# ID check
this_ids <- this_data[[xp_var(db, .problem = prob, type = "id")$col]]
prev_ids <- this_ids
if (index>1) prev_ids <- xpdb_list[[index-1]] %>%
xpose::get_data(.problem = problem, quiet=quiet) %>%
.[[xp_var(xpdb_list[[index-1]], .problem = prob, type = "id")$col]]
if (!identical(this_ids,prev_ids))
cli::cli_abort(paste0("{.strong {get_prop(db, 'run')}} IDs do not match previous runs.",
" This function expects data rows and order to be identical."))
# cols extract
cols_set <- rlang::try_fetch(
dplyr::select(this_data, c({{.cols}}, dplyr::any_of(tcols))),
error = function(s) {
rlang::abort(
paste("Error with `xpose_data` for prob no.",prob,"in",get_prop(db, 'run')),
parent = s
)
})
# Fill data
prob_data[[probi]][[index]] <- cols_set
}
}
## Create xpose_data type object which combines info
new_xpdb <- xpdb_list[[1]] %>%
# Ensure this commonly called property is updated
franken_prop(xpdb_list, "run")
for (prob in problem) {
new_data_list <- purrr::map2_dfc(prob_data[[prob]], seq_along(xpdb_list), ~{
# .x is the df of columns from the data
# .y is the numerical index of the object, to append to column names
.x %>%
dplyr::rename_with(function(nm) paste0(nm,"_",.y))
}) %>%
as.list()
new_xpdb <- new_xpdb %>%
xpose::mutate(!!!new_data_list, .problem = prob, .source = "data")
}
new_xpdb %>%
prop_transforms(xpdb_list,problem) %>%
as_xp_xtras()
}
#' Combine a property from all components of a `franken_xpdb`
#'
#' @param xpdb_f A product of [`franken_xpdb`]
#' @param xpdb_list List of the source `xpose_data` objects.
#' @param prop <`character`> of the property to combine
#' @param glue_cmd Any special transformation to the properties,
#' including how to collapse.
#' @param problem <`numeric`> If necessary to specify
#' @param indices <`numeric`> Index values `1:length(xpdb_list)`
#' to include in the property collapse.
#'
#' @details
#' This function is meant to be called within [`franken_xpdb`].
#' It is expected to be ready to handle cases where, for example,
#' multiple props are being set in a pipe, or a problem-associated
#' property is being set while a problem=0 property is also being
#' set.
#'
#' This is a *low-level* function, so its use outside of internal
#' functions is not intended.
#'
#' @return Same as `xpdb_f` with new properties.
#' @keywords internal
#' @export
#'
#' @examples
#' \donttest{
#' # This is designed to be called in a function environment which
#' # would provide something like the following:
#'
#' xpdb_f <- franken_xpdb(pheno_base, pheno_final, .types="catcov")
#'
#' xpdb_list <- list(pheno_base, pheno_final)
#'
#' # The following would be inside the function
#' xpdb_f %>%
#' franken_prop(xpdb_list, "run",
#' glue_cmd = function(x) paste(x, collapse="+"))
#'
#' # xpdb_f may have to be written to a few times if
#' # and problem-specific combinations are needed:
#'
#' updated <- xpdb_f %>%
#' franken_prop(xpdb_list, "run",
#' glue_cmd = function(x) paste(x, collapse="+"))
#'
#' # problem will also be available. Assume there's
#' # no reason to loop here, but that may be needed
#' problem <- 1
#' updated <- updated %>%
#' franken_prop(xpdb_list, "ofv", problem=problem,
#' glue_cmd = function(x) paste(x, collapse="&"))
#' }
franken_prop <- function(
xpdb_f,
xpdb_list,
prop,
problem=NULL,
glue_cmd = function(x) glue::glue_collapse(x, ", ", last = " and "),
indices = seq_along(xpdb_list)
) {
xpdb_f %>%
# Ensure this commonly called property is updated
set_prop(
!!prop := purrr::map_chr(
xpdb_list[indices],
get_prop,
prop,
.problem = problem) %>%
glue_cmd()
)
}
# Numeric properties like etashk are already
# comma-separated, and have a specific format.
# Need to try to match without creating eyesore.
franken_numprop <- function(x) {
purrr::map2_chr(seq_along(x), x, ~{
if (grepl("\\[\\d+\\]",.y)) return(sprintf("(%i): %s", .x, .y))
sprintf("%s [%i]", .y, .x)
}) %>%
# Semi-colon instead of comma, even if bracketed
paste(collapse="; ")
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.