diff --git a/R/crunch.R b/R/crunch.R index f8a04e2..a452b96 100644 --- a/R/crunch.R +++ b/R/crunch.R @@ -8,24 +8,24 @@ #' @param to_combine Levels to combine. #' @param other_level Name of the new level, e.g., "Other 3" if three levels are combined. #' @returns A factor with combined levels. -combine_levels <- function(f, to_combine, other_level = "Other") { - if (length(to_combine) <= 2L) { - return(f) - } - old_levels <- lvl <- levels(f) - to_keep <- setdiff(lvl, to_combine) - if (other_level %in% to_keep) { - stop("The 'other_level' level is already present in 'f'") - } - new_levels <- c(to_keep, other_level) - old_levels[!(lvl %in% to_keep)] <- other_level - - # like in forcats:::lvls_revalue() - out <- match(old_levels, new_levels)[f] - attributes(out) <- attributes(f) - attr(out, "levels") <- new_levels - return(out) -} +# combine_levels <- function(f, to_combine, other_level = "Other") { +# if (length(to_combine) <= 2L) { +# return(f) +# } +# old_levels <- lvl <- levels(f) +# to_keep <- setdiff(lvl, to_combine) +# if (other_level %in% to_keep) { +# stop("The 'other_level' level is already present in 'f'") +# } +# new_levels <- c(to_keep, other_level) +# old_levels[!(lvl %in% to_keep)] <- other_level +# +# # like in forcats:::lvls_revalue() +# out <- match(old_levels, new_levels)[f] +# attributes(out) <- attributes(f) +# attr(out, "levels") <- new_levels +# return(out) +# } #' Lump rare factor levels (currently unused) #' @@ -42,27 +42,27 @@ combine_levels <- function(f, to_combine, other_level = "Other") { #' A list with three elements: "f" is a factor with combined levels, #' "combined" is a character vector with the combined levels, and "other_level" #' is the name of the new level. -flump <- function(f, combine_m, w = NULL) { - if (is.null(w)) { - N <- collapse::fnobs(f, g = f) - } else { - N <- collapse::fsum(w, g = f, fill = TRUE) - } - to_combine <- levels(f)[order(N)][seq_len(combine_m)] - to_combine <- setdiff(to_combine, NA) # don't collapse explicit NA levels - m_other <- length(to_combine) - if (m_other <= 2L) { - return(list(f = f, combined = NULL, other_level = NULL)) - } - other_level <- paste("Other", m_other) - - out <- list( - f = combine_levels(f, to_combine = to_combine, other_level = other_level), - combined = to_combine, - other_level = other_level - ) - return(out) -} +# flump <- function(f, combine_m, w = NULL) { +# if (is.null(w)) { +# N <- collapse::fnobs(f, g = f) +# } else { +# N <- collapse::fsum(w, g = f, fill = TRUE) +# } +# to_combine <- levels(f)[order(N)][seq_len(combine_m)] +# to_combine <- setdiff(to_combine, NA) # don't collapse explicit NA levels +# m_other <- length(to_combine) +# if (m_other <= 2L) { +# return(list(f = f, combined = NULL, other_level = NULL)) +# } +# other_level <- paste("Other", m_other) +# +# out <- list( +# f = combine_levels(f, to_combine = to_combine, other_level = other_level), +# combined = to_combine, +# other_level = other_level +# ) +# return(out) +# } #' Prepares discrete feature for grouped operations of {collapse} diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 7024f77..4c7ec00 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -3,19 +3,45 @@ xvars <- colnames(iris)[-1] M <- feature_effects(fit, v = xvars, data = iris, y = "Sepal.Length", breaks = 5) test_that("plot() returns correct class", { - expect_s3_class(plot(M), "patchwork") - expect_s3_class(plot(M[1L]), "ggplot") + expect_s3_class(plot(M, rotate_x = 45, title = "multiple plots"), "patchwork") + expect_s3_class(plot(M, stats = "resid_mean", interval = "ci"), "patchwork") + + expect_s3_class(plot(M[1L], rotate_x = 45), "ggplot") + expect_s3_class(plot(M[1L], stats = "resid_mean", interval = "ci"), "ggplot") # Plotly - p <- plot(M, plotly = TRUE) + p <- plot(M, plotly = TRUE, title = "multiple plots") expect_s3_class(p, "plotly") expect_true("subplot" %in% names(p$x)) p <- plot(M[1L], plotly = TRUE) expect_s3_class(p, "plotly") expect_false("subplot" %in% names(p$x)) + + p <- plot(M, stats = "resid_mean", interval = "ci", plotly = TRUE) + expect_s3_class(p, "plotly") + expect_true("subplot" %in% names(p$x)) + + p <- plot(M[1L], stats = "resid_mean", interval = "ci", plotly = TRUE) + expect_s3_class(p, "plotly") + expect_false("subplot" %in% names(p$x)) +}) + +test_that("plot() returns correct class with single ALE line", { + expect_s3_class(plot(M[1:2], stats = "ale"), "patchwork") + expect_s3_class(plot(M[1L], stats = "ale"), "ggplot") + + # Plotly + p <- plot(M[1:2], plotly = TRUE, stats = "ale") + expect_s3_class(p, "plotly") + expect_true("subplot" %in% names(p$x)) + + p <- plot(M[1L], plotly = TRUE, stats = "ale") + expect_s3_class(p, "plotly") + expect_false("subplot" %in% names(p$x)) }) + test_that("ncols has an effect", { # How to do with patchwork?? @@ -59,4 +85,3 @@ test_that("y axis can be shared", { expect_null(p1$x$layout$yaxis$range) expect_equal(p2$x$layout$yaxis$range, p2$x$layout$yaxis3$range) }) -