From c7d02491c039041dc495ff88617d6ac22d209c2d Mon Sep 17 00:00:00 2001 From: Andreas Bender Date: Sat, 24 Feb 2024 15:41:10 +0100 Subject: [PATCH 1/3] remove cross, cross_df in favor of tidyr::expand_grid --- NAMESPACE | 3 +-- R/make-newdata.R | 12 ++++++------ man/newdata.Rd | 3 --- 3 files changed, 7 insertions(+), 11 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c3915be6..2c1f0d96 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -156,7 +156,6 @@ importFrom(mgcv,predict.gam) importFrom(mvtnorm,rmvnorm) importFrom(pec,predictSurvProb) importFrom(purrr,compose) -importFrom(purrr,cross) importFrom(purrr,cross_df) importFrom(purrr,discard) importFrom(purrr,flatten) @@ -169,7 +168,6 @@ importFrom(purrr,map_int) importFrom(purrr,map_lgl) importFrom(purrr,reduce) importFrom(purrr,set_names) -importFrom(purrr,transpose) importFrom(rlang,":=") importFrom(rlang,.data) importFrom(rlang,.env) @@ -196,6 +194,7 @@ importFrom(stats,vcov) importFrom(tibble,as_tibble) importFrom(tidyr,complete) importFrom(tidyr,crossing) +importFrom(tidyr,expand_grid) importFrom(tidyr,gather) importFrom(tidyr,nest) importFrom(tidyr,pivot_longer) diff --git a/R/make-newdata.R b/R/make-newdata.R index 237a942e..bc824286 100644 --- a/R/make-newdata.R +++ b/R/make-newdata.R @@ -131,7 +131,8 @@ combine_df <- function(...) { #' the time argument, but see "Details" an "Examples" below. #' @import dplyr #' @importFrom checkmate assert_data_frame assert_character -#' @importFrom purrr map cross_df +#' @importFrom purrr map +#' @importFrom tidyr expand_grid #' @details Depending on the type of variables in \code{x}, mean or modus values #' will be used for variables not specified in ellipsis #' (see also \code{\link[pammtools]{sample_info}}). If \code{x} is an object @@ -159,9 +160,6 @@ combine_df <- function(...) { #' # mean/modus values of unspecified variables are calculated over whole data #' tumor %>% make_newdata(sex=unique(sex)) #' tumor %>% group_by(sex) %>% make_newdata() -#' # You can also pass a part of the data sets as data frame to make_newdata -#' purrr::cross_df(list(days = c(0, 500, 1000), sex = c("male", "female"))) %>% -#' make_newdata(x=tumor) #' #' # Examples for PED data #' ped <- tumor %>% slice(1:3) %>% as_ped(Surv(days, status)~., cut = c(0, 500, 1000)) @@ -193,11 +191,13 @@ make_newdata.default <- function(x, ...) { orig_names <- names(x) expressions <- quos(...) - expr_evaluated <- map(expressions, lazyeval::f_eval, data = x) + expr_evaluated <- map(expressions, lazyeval::f_eval, data = x) |> + map(list_simplify, strict = FALSE) # construct data parts depending on input type lgl_atomic <- map_lgl(expr_evaluated, is_atomic) - part1 <- expr_evaluated[lgl_atomic] %>% cross_df() + # part1 <- expr_evaluated[lgl_atomic] |> cross_df() + part1 <- do.call(tidyr::expand_grid, rev(expr_evaluated[lgl_atomic])) part2 <- do.call(combine_df, expr_evaluated[!lgl_atomic]) ndf <- combine_df(part1, part2) diff --git a/man/newdata.Rd b/man/newdata.Rd index acfc8bc7..46f33f7c 100644 --- a/man/newdata.Rd +++ b/man/newdata.Rd @@ -63,9 +63,6 @@ tumor \%>\% make_newdata(days=seq_range(days, 3), status=unique(status), age=c(5 # mean/modus values of unspecified variables are calculated over whole data tumor \%>\% make_newdata(sex=unique(sex)) tumor \%>\% group_by(sex) \%>\% make_newdata() -# You can also pass a part of the data sets as data frame to make_newdata -purrr::cross_df(list(days = c(0, 500, 1000), sex = c("male", "female"))) \%>\% - make_newdata(x=tumor) # Examples for PED data ped <- tumor \%>\% slice(1:3) \%>\% as_ped(Surv(days, status)~., cut = c(0, 500, 1000)) From b09683fae7d88a10a35bd5e4dca1dfe6c06b9381 Mon Sep 17 00:00:00 2001 From: Andreas Bender Date: Sat, 24 Feb 2024 15:41:35 +0100 Subject: [PATCH 2/3] remove cross, cross_df in favor of expand_grid --- R/make-newdata.R | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/R/make-newdata.R b/R/make-newdata.R index bc824286..c1af0212 100644 --- a/R/make-newdata.R +++ b/R/make-newdata.R @@ -83,7 +83,7 @@ sample_info.fped <- function(x) { #' #' @importFrom dplyr slice bind_cols #' @importFrom vctrs vec_c -#' @importFrom purrr map map_lgl map2 transpose cross +#' @importFrom purrr map map_lgl #' @importFrom checkmate test_data_frame #' @param ... Data frames that should be combined to one data frame. #' Elements of first df vary fastest, elements of last df vary slowest. @@ -102,10 +102,10 @@ combine_df <- function(...) { } ind_seq <- map(dots, ~ seq_len(nrow(.x))) not_empty <- map_lgl(ind_seq, ~ length(.x) > 0) - ind_list <- ind_seq[not_empty] %>% cross() %>% transpose() %>% map(function(x) vec_c(!!!x)) - map2(dots[not_empty], ind_list, function(.x, .y) slice(.x, .y)) %>% - bind_cols() + ord <- lapply(dots[not_empty], function(z) colnames(z)) |> unlist() + out <- do.call(expand_grid, rev(dots[not_empty])) + out <- out[, ord] } @@ -121,6 +121,7 @@ combine_df <- function(...) { #' #' @rdname newdata #' @aliases make_newdata +#' @importFrom tidyr expand_grid #' @inheritParams sample_info #' @param ... Covariate specifications (expressions) that will be evaluated #' by looking for variables in \code{x}. Must be of the form \code{z = f(z)} @@ -192,7 +193,7 @@ make_newdata.default <- function(x, ...) { expressions <- quos(...) expr_evaluated <- map(expressions, lazyeval::f_eval, data = x) |> - map(list_simplify, strict = FALSE) + map(c) # construct data parts depending on input type lgl_atomic <- map_lgl(expr_evaluated, is_atomic) From d968ddaa2b776fcf034c55de2caf99db2cd33468 Mon Sep 17 00:00:00 2001 From: Andreas Bender Date: Sat, 24 Feb 2024 15:41:51 +0100 Subject: [PATCH 3/3] dplyr adjustments --- R/model-evaluation.R | 4 ++-- R/sim-pexp.R | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/R/model-evaluation.R b/R/model-evaluation.R index b356e146..9be594c0 100644 --- a/R/model-evaluation.R +++ b/R/model-evaluation.R @@ -16,7 +16,7 @@ as.data.frame.crps <- function(x, row.names = NULL, optional = FALSE, ...) { m$method <- attr(x, "dimnames")[[1]] m <- m %>% - pivot_longer(cols = -.data$method, values_to = "IBS") %>% - dplyr::rename(time = .data$name) + pivot_longer(cols = -one_of("method"), values_to = "IBS") %>% + dplyr::rename(time = "name") } diff --git a/R/sim-pexp.R b/R/sim-pexp.R index cf9a11b6..eab54cfd 100644 --- a/R/sim-pexp.R +++ b/R/sim-pexp.R @@ -155,9 +155,9 @@ sim_pexp <- function(formula, data, cut) { status = 1L * (.data$time <= max(cut)), time = pmin(.data$time, max(cut))) - suppressMessages( + suppressMessages( sim_df <- sim_df %>% - left_join(select(data, -.data$time, -.data$status)) + left_join(select(data, -all_of(c("time", "status")))) ) attr(sim_df, "id_var") <- "id" @@ -166,7 +166,7 @@ sim_pexp <- function(formula, data, cut) { attr(sim_df, "tz_var") <- tz_vars attr(sim_df, "cens_value") <- 0 attr(sim_df, "breaks") <- cut - attr(sim_df, "tz") <- imap(tz_vars, ~select(sim_df, .x) %>% + attr(sim_df, "tz") <- imap(tz_vars, ~select(sim_df, all_of(.x)) %>% pull(.x) %>% unique()) %>% flatten() if (exists("ll_funs")) attr(sim_df, "ll_funs") <- ll_funs if (exists("cumu_funs")) attr(sim_df, "cumu_funs") <- cumu_funs