diff --git a/DESCRIPTION b/DESCRIPTION index 465c07ea..7516a6fa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: pammtools Title: Piece-Wise Exponential Additive Mixed Modeling Tools Version: 0.1.11 -Date: 2019-03-28 +Date: 2019-04-17 Authors@R: c( person("Andreas", "Bender", , "andreas.bender@stat.uni-muenchen.de", role = c("aut", "cre"), comment=c(ORCID = "0000-0001-5628-8611")), person("Fabian", "Scheipl", , "fabian.scheipl@stat.uni-muenchen.de", role = c("aut"))) diff --git a/NAMESPACE b/NAMESPACE index ba487548..22018dcd 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -5,8 +5,6 @@ S3method(arrange,ped) S3method(as_ped,data.frame) S3method(as_ped,list) S3method(as_ped,nested_fdf) -S3method(distinct_,nested_fdf) -S3method(distinct_,ped) S3method(fill,nested_fdf) S3method(fill,ped) S3method(filter,nested_fdf) @@ -25,7 +23,6 @@ S3method(gg_laglead,nested_fdf) S3method(gg_smooth,default) S3method(group_by,nested_fdf) S3method(group_by,ped) -S3method(group_by_,nested_fdf) S3method(group_by_,ped) S3method(inner_join,nested_fdf) S3method(inner_join,ped) @@ -43,8 +40,6 @@ S3method(nest_tdc,default) S3method(nest_tdc,list) S3method(rename,nested_fdf) S3method(rename,ped) -S3method(rename_,nested_fdf) -S3method(rename_,ped) S3method(right_join,nested_fdf) S3method(right_join,ped) S3method(sample_frac,nested_fdf) @@ -56,8 +51,6 @@ S3method(sample_n,nested_fdf) S3method(sample_n,ped) S3method(select,nested_fdf) S3method(select,ped) -S3method(select_,nested_fdf) -S3method(select_,ped) S3method(slice,nested_fdf) S3method(slice,ped) S3method(summarise,nested_fdf) @@ -85,7 +78,6 @@ export(arrange) export(as_ped) export(combine_df) export(cumulative) -export(distinct_) export(fcumu) export(fill) export(filter) @@ -121,14 +113,12 @@ export(mutate) export(nest_tdc) export(ped_info) export(rename) -export(rename_) export(right_join) export(riskset_info) export(sample_frac) export(sample_info) export(sample_n) export(select) -export(select_) export(seq_range) export(sim_pexp) export(slice) diff --git a/NEWS.md b/NEWS.md index 9079d0ad..0fe163cd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,13 @@ +# pammtools 0.1.11 + +## bugs +* fixes bug in **`dplyr`** reverse dependency (see #101) +* fixes bug in tidiers for Aalen models (see #99) + +## documentation +* Better documentation and functionality for `make_newdata` +* Added new vignette linking to tutorial paper (online only) + # pammtools 0.1.9 * maintainance update: fixes CRAN issues due to new RNG @@ -26,7 +36,7 @@ * Updates homepage (via pkgdown) -# pamtools 0.1.3 +# pammtools 0.1.3 ## Minor changes diff --git a/R/cumulative-coefficient.R b/R/cumulative-coefficient.R index b66287af..eef37365 100644 --- a/R/cumulative-coefficient.R +++ b/R/cumulative-coefficient.R @@ -128,10 +128,14 @@ cumu_coef <- function(data, model, term, ...) { #' @inherit get_cumu_coef #' @keywords internal get_cumu_coef_baseline <- function(data, model, ...) { + + vars_modify <- colnames(data)[map_lgl(data, is.numeric)] %>% + setdiff(c("tstart", "tend", "intlen", "intmid")) + data %>% mutate_at( - .vars = vars(-one_of(c("tstart", "tend", "intlen", "intmid", "interval"))), - .funs = ~0) %>% + .vars = vars(one_of(vars_modify)), + .funs = ~c(0)) %>% add_cumu_hazard(model) %>% mutate( method = class(model)[1], diff --git a/R/tidyverse-methods.R b/R/tidyverse-methods.R index 22876f92..aed44675 100644 --- a/R/tidyverse-methods.R +++ b/R/tidyverse-methods.R @@ -79,13 +79,6 @@ ungroup.ped <- function(x, ...) { #------------------------------------------------------------------------------- # single table: row ops -#' @export -#' @export distinct_ -#' @rdname dplyr_verbs -distinct_.ped <- function(.data, ..., .dots = list()) { - reped(distinct_(unped(.data), ..., .dots = .dots)) -} - #' @export #' @export filter #' @rdname dplyr_verbs @@ -128,13 +121,6 @@ select.ped <- function(.data, ...) { reped(select(unped(.data), ...)) } -#' @export -#' @export select_ -#' @rdname dplyr_verbs -select_.ped <- function(.data, ..., .dots = list()) { - reped(select_(unped(.data), ..., .dots = .dots)) -} - #' @param keep_attributes conserve attributes? defaults to \code{TRUE} #' @export #' @export mutate @@ -157,13 +143,6 @@ rename.ped <- function(.data, ...) { reped(rename(unped(.data), ...)) } -#' @export -#' @export rename_ -#' @rdname dplyr_verbs -rename_.ped <- function(.data, ..., .dots = list()) { - reped(rename_(unped(.data), ..., .dots = .dots)) -} - #' @export #' @export summarise #' @rdname dplyr_verbs @@ -275,21 +254,6 @@ fill.ped <- function(data, ..., .direction=c("down", "up"), keep_attributes=TRUE } -# #' @inheritParams tidyr::fill_ -# #' @export fill_ -# #' @export -# #' @rdname tidyr_verbs -# fill_.ped <- function(data, fill_cols, .direction=c("down", "up")) { - -# data_attr <- ped_attr(data) -# tbl <- reped(fill_(unped(data), fill_cols, .direction)) -# attributes(tbl) <- c(attributes(tbl), data_attr) - -# return(tbl) - -# } - - #' @importFrom purrr discard un_nested_df <- function(nested_fdf) { class(nested_fdf) <- class(nested_fdf) %>% discard(~.=="nested_fdf") @@ -322,14 +286,6 @@ group_by.nested_fdf <- function(.data, ..., add = FALSE) { re_nested_df(group_by(un_nested_df(.data), ..., add = add)) } -#' @inheritParams dplyr::group_by_ -#' @export -#' @export group_by_ -#' @rdname dplyr_verbs -group_by_.nested_fdf <- function(.data, ..., .dots = list(), add = FALSE) { - re_nested_df(group_by_(un_nested_df(.data), ..., .dots = .dots, add = add)) -} - #' @export #' @export ungroup #' @rdname dplyr_verbs @@ -340,13 +296,6 @@ ungroup.nested_fdf <- function(x, ...) { #------------------------------------------------------------------------------- # single table: row ops -#' @export -#' @export distinct_ -#' @rdname dplyr_verbs -distinct_.nested_fdf <- function(.data, ..., .dots = list()) { - re_nested_df(distinct_(un_nested_df(.data), ..., .dots = .dots)) -} - #' @export #' @export filter #' @rdname dplyr_verbs @@ -389,12 +338,6 @@ select.nested_fdf <- function(.data, ...) { re_nested_df(select(un_nested_df(.data), ...)) } -#' @export -#' @export select_ -#' @rdname dplyr_verbs -select_.nested_fdf <- function(.data, ..., .dots = list()) { - re_nested_df(select_(un_nested_df(.data), ..., .dots = .dots)) -} #' @param keep_attributes conserve attributes? defaults to \code{TRUE} #' @export @@ -418,12 +361,6 @@ rename.nested_fdf <- function(.data, ...) { re_nested_df(rename(un_nested_df(.data), ...)) } -#' @export -#' @export rename_ -#' @rdname dplyr_verbs -rename_.nested_fdf <- function(.data, ..., .dots = list()) { - re_nested_df(rename_(un_nested_df(.data), ..., .dots = .dots)) -} #' @export #' @export summarise @@ -515,11 +452,15 @@ right_join.nested_fdf <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x" #' @export fill #' @rdname tidyr_verbs #' @keywords internal -fill.nested_fdf <- function(data, ..., .direction=c("down", "up"), keep_attributes=TRUE) { +fill.nested_fdf <- function( + data, + ..., + .direction = c("down", "up"), + keep_attributes = TRUE) { if (keep_attributes) { data_attr <- nested_fdf_attr(data) } - tbl <- re_nested_df(fill(un_nested_df(data), ..., .direction=.direction)) + tbl <- re_nested_df(fill(un_nested_df(data), ..., .direction = .direction)) if (keep_attributes) { attributes(tbl) <- c(attributes(tbl), data_attr) } diff --git a/_pkgdown.yml b/_pkgdown.yml index 37caa79d..d1337111 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -18,9 +18,6 @@ reference: - int_info - ped_info - make_newdata - - gg_slice - - gg_partial - - get_cumu_eff - title: "Extract information from PAMMs" desc: "Functions that help extract information from fitted model objects, e.g., smooth effects for plotting" @@ -44,6 +41,7 @@ reference: - gg_smooth - gg_tensor - gg_re + - gg_slice - gg_partial - gg_partial_ll - gg_laglead diff --git a/cran-comments.md b/cran-comments.md index 26232fa0..53fe2842 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,14 +1,15 @@ ## Test environments * R release and devel with Travis CI -* R 3.5.2 patched with appveyor -* win-builder (devel and release) +* R 3.5.3 patched with AppVeyor +* win-builder (R version 3.6.0 beta (2019-04-16 r76403)) +* win-builder * R-hub ## R CMD check results 0 errors | 0 warnings | 0 notes -* maintainance update: fixes CRAN issues due to new RNG +* Fixes dplyr reverse dependency bug + documentation updates ## Reverse dependencies diff --git a/man/dplyr_verbs.Rd b/man/dplyr_verbs.Rd index a138e33d..68427d09 100644 --- a/man/dplyr_verbs.Rd +++ b/man/dplyr_verbs.Rd @@ -26,16 +26,13 @@ \alias{group_by.ped} \alias{group_by_.ped} \alias{ungroup.ped} -\alias{distinct_.ped} \alias{filter.ped} \alias{sample_n.ped} \alias{sample_frac.ped} \alias{slice.ped} \alias{select.ped} -\alias{select_.ped} \alias{mutate.ped} \alias{rename.ped} -\alias{rename_.ped} \alias{summarise.ped} \alias{summarize.ped} \alias{transmute.ped} @@ -45,18 +42,14 @@ \alias{right_join.ped} \alias{arrange.nested_fdf} \alias{group_by.nested_fdf} -\alias{group_by_.nested_fdf} \alias{ungroup.nested_fdf} -\alias{distinct_.nested_fdf} \alias{filter.nested_fdf} \alias{sample_n.nested_fdf} \alias{sample_frac.nested_fdf} \alias{slice.nested_fdf} \alias{select.nested_fdf} -\alias{select_.nested_fdf} \alias{mutate.nested_fdf} \alias{rename.nested_fdf} -\alias{rename_.nested_fdf} \alias{summarise.nested_fdf} \alias{summarize.nested_fdf} \alias{transmute.nested_fdf} @@ -74,8 +67,6 @@ \method{ungroup}{ped}(x, ...) -\method{distinct_}{ped}(.data, ..., .dots = list()) - \method{filter}{ped}(.data, ...) \method{sample_n}{ped}(tbl, size, replace = FALSE, weight = NULL, @@ -88,14 +79,10 @@ \method{select}{ped}(.data, ...) -\method{select_}{ped}(.data, ..., .dots = list()) - \method{mutate}{ped}(.data, ..., keep_attributes = TRUE) \method{rename}{ped}(.data, ...) -\method{rename_}{ped}(.data, ..., .dots = list()) - \method{summarise}{ped}(.data, ...) \method{summarize}{ped}(.data, ...) @@ -118,12 +105,8 @@ \method{group_by}{nested_fdf}(.data, ..., add = FALSE) -\method{group_by_}{nested_fdf}(.data, ..., .dots = list(), add = FALSE) - \method{ungroup}{nested_fdf}(x, ...) -\method{distinct_}{nested_fdf}(.data, ..., .dots = list()) - \method{filter}{nested_fdf}(.data, ...) \method{sample_n}{nested_fdf}(tbl, size, replace = FALSE, @@ -136,14 +119,10 @@ \method{select}{nested_fdf}(.data, ...) -\method{select_}{nested_fdf}(.data, ..., .dots = list()) - \method{mutate}{nested_fdf}(.data, ..., keep_attributes = TRUE) \method{rename}{nested_fdf}(.data, ...) -\method{rename_}{nested_fdf}(.data, ..., .dots = list()) - \method{summarise}{nested_fdf}(.data, ...) \method{summarize}{nested_fdf}(.data, ...) diff --git a/tests/testthat/test-cumulative-coefficients.R b/tests/testthat/test-cumulative-coefficients.R index d918fe04..2e842cf9 100644 --- a/tests/testthat/test-cumulative-coefficients.R +++ b/tests/testthat/test-cumulative-coefficients.R @@ -17,10 +17,18 @@ test_that("Cumulative coefficients work", { ## pam ped <- as_ped(df, formula = Surv(days, status)~ x1 + age) - pam <- mgcv::gam(ped_status ~ x1 + age, data = ped, family = poisson(), - offset = offset) + pam <- mgcv::gam(ped_status ~ s(tend) + x1 + age, data = ped, + family = poisson(), offset = offset) cumu_coef_pam <- get_cumu_coef(pam, ped, terms = c("age", "x1"), nsim = 20L) expect_data_frame(cumu_coef_pam, nrows = 36L, ncols = 6L) expect_equal(unique(cumu_coef_pam$variable), c("age", "x1 (b)", "x1 (c)")) + cumu_coef_pam <- get_cumu_coef(pam, ped, terms = c("(Intercept)", "age")) + expect_data_frame(cumu_coef_pam, nrows = 24L, ncols = 6L) + # ggplot( + # filter(cc2, variable == "(Intercept)"), + # aes(x = time, y = cumu_hazard)) + + # geom_step() + + # geom_step(data = filter(cumu_coef_aalen, variable == "(Intercept)"), col = 2) + }) diff --git a/tests/testthat/test-newdata.R b/tests/testthat/test-newdata.R index ea52e379..cf2b4552 100644 --- a/tests/testthat/test-newdata.R +++ b/tests/testthat/test-newdata.R @@ -36,6 +36,7 @@ test_that("creating newdata fails on ungrouped data", { test_that("make_newdata works for PED data", { + ped <- simdf_elra %>% slice(1:6) %>% as_ped(Surv(time, status)~x1 + x2, cut = seq(0, 10, by = 5)) @@ -55,7 +56,7 @@ test_that("make_newdata works for PED data", { test_that("make_newdata works for PED with matrix columns", { - # library(mgcv) + ped_simdf <- simdf_elra %>% as_ped( Surv(time, status)~ x1 + x2 | cumulative(time, latency(tz1), z.tz1, tz_var = "tz1", @@ -80,7 +81,7 @@ test_that("make_newdata works for PED with matrix columns", { expect_equal(nd1$tstart, 0) expect_equal(nd1$tend, 1) expect_equal(nd1$x1, 0.05) - expect_equal(nd1$x2, 2.65, tolerance=1e-3) + expect_equal(nd1$x2, 2.65, tolerance = 1e-3) expect_equal(nd1$z.tz1_tz1, -0.370, 1e-3) nd2 <- ped_simdf %>% make_newdata(x1 = seq_range(x1, 2))