From 819f2496ee32748802ed3b4e430471af400f9ce5 Mon Sep 17 00:00:00 2001 From: Gabe Becker Date: Tue, 4 Jun 2024 16:46:51 -0700 Subject: [PATCH] clean up unused code, a few new tests --- R/make_subset_expr.R | 15 ---------- R/tree_accessors.R | 53 ++++------------------------------ R/tt_compatibility.R | 2 ++ tests/testthat/test-printing.R | 13 +++++++++ 4 files changed, 21 insertions(+), 62 deletions(-) diff --git a/R/make_subset_expr.R b/R/make_subset_expr.R index 0bd589bfe..682cd57e4 100644 --- a/R/make_subset_expr.R +++ b/R/make_subset_expr.R @@ -267,21 +267,6 @@ create_colinfo <- function(lyt, df, rtpos = TreePos(), 0L } else { vec <- try(eval(ex, envir = alt_counts_df), silent = TRUE) - ## likely unneeded now because it happens in splitvec_to_coltree - ## which is called during coltree construction above - ## TODO remove me - if (is(vec, "try-error")) { - stop(sprintf( - paste( - counts_df_name, "appears", - "incompatible with column-split", - "structure. Offending column subset", - "expression: %s\nOriginal error", - "message: %s" - ), deparse(ex[[1]]), - conditionMessage(attr(vec, "condition")) - )) - } if (is(vec, "numeric")) { length(vec) } else if (is(vec, "logical")) { ## sum(is.na(.)) ???? diff --git a/R/tree_accessors.R b/R/tree_accessors.R index f380868c6..3c3720673 100644 --- a/R/tree_accessors.R +++ b/R/tree_accessors.R @@ -2447,31 +2447,6 @@ setMethod( } ) -match_path_by_pos <- function(kidlst, path) { - ret <- -1 - nmval_pairs <- lapply( - kidlst, - function(kd) { - pos <- tree_pos(kd) - c( - obj_name(tail(pos_splits(pos), 1)[[1]]), - value_names(tail(pos_splvals(pos), 1))[[1]] - ) - } - ) - - matches <- vapply( - nmval_pairs, - function(pair) { - (pair[1] == path[1]) && (is.na(pair[2]) || (path[2] %in% c(pair[2], "*"))) - }, - TRUE - ) - if (any(matches)) { - ret <- which(matches) - } - ret -} ## this is a horrible hack but when we have non-nested siblings at the top level ## the beginning of the "path <-> position" relationship breaks down. @@ -2482,24 +2457,6 @@ match_path_by_pos <- function(kidlst, path) { ## ## those first non-nested siblings currently have (incorrect) ## empty tree_pos elements so we just look at the obj_name -root_match_finder <- function(kidlst, path) { - matches <- vapply(kidlst, function(kid) { - obj_name(kid) == path[1] - }, TRUE) - if (sum(matches) == 0) { - stop("unable to find first-step match in path: ", path[1]) - } else if (sum(matches) > 1) { - stop("multiple matches for first-step in path: ", path[1]) - } else { - which(matches) - } -} - - -is_all_split <- function(ct) { - splvals <- pos_splvals(ct) - length(splvals) > 0 && rawvalues(tail(pos_splvals(ct), 1))[[1]] == tail(value_names(pos_splvals(ct)), 1) -} pos_singleton_path <- function(obj) { pos <- tree_pos(obj) @@ -2522,10 +2479,6 @@ coltree_at_path <- function(obj, path, ...) { stop("@content token is not valid for column paths.") } - - ## if(obj_name(obj) == path[1]) { - ## path <- path[-1] - ## } cur <- obj curpath <- pos_to_path(tree_pos(obj)) # path num_consume_path <- 2 @@ -2559,6 +2512,12 @@ find_kid_path_match <- function(kids, path) { which(matches) } + +## almost a duplicate of recursive_replace, but I spent a bunch +## of time ramming my head against the different way pathing happens +## in column space (unfortunately) before giving up building +## coltree_at_path around recursive_replace, so here we are. + ct_recursive_replace <- function(ctree, path, value, pos = 1) { pos <- tree_pos(ctree) curpth <- pos_to_path(pos) diff --git a/R/tt_compatibility.R b/R/tt_compatibility.R index 56677f166..da9998ec6 100644 --- a/R/tt_compatibility.R +++ b/R/tt_compatibility.R @@ -384,6 +384,7 @@ only_first_annot <- function(all_annots) { #' @aliases rbind #' @export rbindl_rtables <- function(x, gap = lifecycle::deprecated(), check_headers = lifecycle::deprecated()) { + ## nocov start if (lifecycle::is_present(gap)) { lifecycle::deprecate_warn( when = "0.3.2", @@ -396,6 +397,7 @@ rbindl_rtables <- function(x, gap = lifecycle::deprecated(), check_headers = lif what = "rbindl_rtables(check_headers)" ) } + ## nocov end firstcols <- col_info(x[[1]]) i <- 1 diff --git a/tests/testthat/test-printing.R b/tests/testthat/test-printing.R index 8e86d212b..407bab95c 100644 --- a/tests/testthat/test-printing.R +++ b/tests/testthat/test-printing.R @@ -340,6 +340,7 @@ test_that("Various Printing things work", { table_structure(tab, detail = "subtable") ## treestruct(tab) table_structure(tab, detail = "row") ## treestruct(tab) + coltree_structure(tab) ## this is not intended to be a valid layout, it just ## tries to hit every type of split for the print machinery @@ -805,6 +806,10 @@ test_that("showing higher-level ncols works", { analyze("AGE") tbl <- build_table(lyt, mydat) + expect_equal(colcount_na_str(tbl), "") + colcount_na_str(tbl) <- "wut" + expect_equal(colcount_na_str(tbl), "wut") + colcount_na_str(tbl) <- "" cwds <- rep(8, ncol(tbl) + 1) expect_equal(nlines(col_info(tbl), colwidths = cwds, fontspec = NULL), 7) mpf <- matrix_form(tbl, TRUE) @@ -822,6 +827,7 @@ test_that("showing higher-level ncols works", { expect_true(all(!grepl("(N=", strs[-c(2, 5), -1], fixed = TRUE))) broken_tbl <- tbl + expect_true(colcount_visible(broken_tbl, c("ARM", "A: Drug X", "SEX2", "males"))) colcount_visible(broken_tbl, c("ARM", "A: Drug X", "SEX2", "males")) <- FALSE expect_error(print(broken_tbl), "different colcount visibility among sibling facets") @@ -888,6 +894,13 @@ test_that("showing higher-level ncols works", { c("", "", "") ) + ## turning counts for a facet's children off is different than setting + ## the visible counts to NA, note alignment here, no spaces under risk diff + ## arms + facet_colcounts_visible(tbl5, c("rr_header", "Risk Difference % CI", "ARM")) <- FALSE + mpf5b <- matrix_form(tbl5, TRUE) + expect_equal(mf_strings(mpf5b)[3, 7:8], + c("A: Drug X", "C: Combination")) lyt6 <- basic_table(show_colcounts = TRUE, colcount_format = "N=xx") %>% split_cols_by("active_trt", split_fun = trim_levels_in_group("ARM")) %>% split_cols_by("ARM", split_fun = add_combo_levels(combodf), show_colcounts = TRUE, colcount_format = "(N=xx)") %>%