fix github link on packagedown site & address deprecations (#208)

* fix github link on packagedown site

* update dependency versions

* update snapshot tests

* update documentation

* update forcats function

* revert back to original, change strategy

* update versions

* replace deprecated functions

* modify another snapshot test

* update news

* changes!

* Update .gitignore

* Increment version number to 0.2.0.9001

---------

Co-authored-by: Daniel Sjoberg <[email protected]>

.gitignore

@@ -40,3 +40,4 @@ vignettes/*.pdf
 .Rproj.user
 docs
 inst/doc
+.DS_Store

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: gtreg
 Title: Regulatory Tables for Clinical Research
-Version: 0.2.0.9000
+Version: 0.2.0.9001
 Authors@R: c(
     person("Shannon", "Pileggi", , "[email protected]", role = c("aut", "cre", "cph"),
            comment = c(ORCID = "0000-0002-7732-4164")),
@@ -19,24 +19,24 @@ BugReports: https://github.com/shannonpileggi/gtreg/issues
 Depends: 
     R (>= 3.4)
 Imports: 
-    broom.helpers (>= 1.5.0),
-    cli (>= 3.1.0),
-    dplyr (>= 1.0.7),
-    forcats (>= 0.5.1),
-    glue (>= 1.6.0),
-    gtsummary (>= 1.6.1),
-    purrr (>= 0.3.4),
-    rlang (>= 1.0.0),
-    stringr (>= 1.4.0),
-    tibble (>= 3.1.6),
-    tidyr (>= 1.1.4)
+    broom.helpers (>= 1.13.0),
+    cli (>= 3.6.1),
+    dplyr (>= 1.1.1),
+    forcats (>= 1.0.0),
+    glue (>= 1.6.2),
+    gtsummary (>= 1.7.1),
+    purrr (>= 1.0.1),
+    rlang (>= 1.1.1),
+    stringr (>= 1.5.0),
+    tibble (>= 3.2.1),
+    tidyr (>= 1.2.1)
 Suggests: 
-    covr (>= 3.5.1),
-    gt (>= 0.3.1),
-    knitr (>= 1.37),
-    rmarkdown,
-    spelling (>= 2.2),
-    testthat (>= 3.1.1)
+    covr (>= 3.6.1),
+    gt (>= 0.9.0),
+    knitr (>= 1.43),
+    rmarkdown (>= 2.22),
+    spelling (>= 2.2.1),
+    testthat (>= 3.1.9)
 VignetteBuilder: 
     knitr
 Config/testthat/edition: 3

NEWS.md

@@ -1,5 +1,13 @@
 # gtreg (development version)
 
+
+* Fix GitHub link on `pkgdown` site (#207).
+
+* Address deprecated `purrr::when()` and `forcats::fct_explicit_na()` (#210).
+
+* Update package versions for dependencies.
+
+
 # gtreg 0.2.0
 
 Documentation:

R/complete_ae_data.R

@@ -140,7 +140,7 @@
     tidyr::drop_na(!!!rlang::syms(intersect(c("soc", "ae"), names(data))))
 
   # replace unobserved AEs with an explicit level ------------------------------
-  data_full$by <- forcats::fct_explicit_na(data_full$by, initial_dummy)
+  data_full$by <- .fct_explicit_na(data_full$by, initial_dummy)
 
   # re-level to put unobserved and missing in front
   if (any(c(initial_dummy, initial_missing) %in% levels(data_full$by))) {
@@ -236,7 +236,7 @@
 
   # adding missing level, as needed
   if (any(is.na(data$by))) {
-    data$by <- forcats::fct_explicit_na(data$by, na_level = initial_missing)
+    data$by <- .fct_explicit_na(data$by, na_level = initial_missing)
   }
 
   data

R/tbl_ae.R

@@ -191,7 +191,7 @@ tbl_ae <- function(data,
     # add class
     structure(class = c("tbl_ae", "gtsummary")) %>%
     # add default spanning headers
-    purrr::when(
+    .when(
       !is.null(strata) ~
         modify_spanning_header(., gtsummary::all_stat_cols() ~ "**{strata}**, N = {n}"),
       TRUE ~ modify_spanning_header(., gtsummary::all_stat_cols() ~ "**N = {N}**")

R/tbl_ae_count.R

@@ -138,7 +138,7 @@ tbl_ae_count <- function(data,
     # add class
     structure(class = c("tbl_ae_count", "gtsummary")) %>%
     # add default spanning headers
-    purrr::when(
+    .when(
       !is.null(strata) ~
         modify_spanning_header(
           ., gtsummary::all_stat_cols() ~ "**{strata}**"),

R/tbl_ae_focus.R

@@ -179,7 +179,7 @@ tbl_ae_focus <- function(data,
     # add class
     structure(class = c("tbl_ae_focus", "gtsummary")) %>%
     # add default spanning headers
-    purrr::when(
+    .when(
       !is.null(strata) ~
         modify_spanning_header(., gtsummary::all_stat_cols() ~ "**{strata}**, N = {n}"),
       TRUE ~ modify_spanning_header(., gtsummary::all_stat_cols() ~ "**N = {N}**")

R/utils-tbl_ae.R

@@ -247,3 +247,82 @@
   tbl
 }
 
+# check_factor is not an exported function in forcats, copying here
+# for internal use
+.check_factor <- function(x) {
+  if (is.character(x)) {
+    factor(x)
+  } else if (is.factor(x)) {
+    x
+  } else {
+    cli::cli_abort(
+      "Input must be a factor or character vector."
+    )
+  }
+}
+
+# keeping deprecated forcats function in order
+# to not change default behavior with new functions
+.fct_explicit_na <- function(f, na_level = "(Missing)") {
+
+  f <- .check_factor(f)
+
+  is_missing <- is.na(f)
+  is_missing_level <- is.na(levels(f))
+
+  if (any(is_missing)) {
+    f <- forcats::fct_expand(f, na_level)
+    f[is_missing] <- na_level
+
+    f
+  } else if (any(is_missing_level)) {
+    levs <- levels(f)
+    levs[is.na(levs)] <- na_level
+
+    forcats::lvls_revalue(f, levs)
+  } else {
+    f
+  }
+}
+
+# internal version of purrr::when() due to deprecation
+.when <- function(., ...) {
+
+  dots   <- list(...)
+  names  <- names(dots)
+  named  <- if (is.null(names)) rep(FALSE, length(dots)) else names != ""
+
+  if (sum(!named) == 0)
+    cli::cli_abort("At least one matching condition is needed.")
+
+  is_formula <-
+    vapply(dots,
+           function(dot) identical(class(dot), "formula"),
+           logical(1L))
+
+  env <- new.env(parent = parent.frame())
+  env[["."]] <- .
+
+  if (sum(named) > 0)
+    for (i in which(named))
+      env[[names[i]]] <- dots[[i]]
+
+  result <- NULL
+  for (i in which(!named)) {
+    if (is_formula[i]) {
+      action <- length(dots[[i]])
+      if (action == 2 || rlang::is_true(eval(dots[[i]][[2]], env, env))) {
+        result <- eval(dots[[i]][[action]], env, env)
+        break
+      }
+    } else {
+      result <- dots[[i]]
+    }
+  }
+
+  result
+}
+
+
+
+

_pkgdown.yml

@@ -40,7 +40,7 @@ navbar:
     href: news/index.html
   right:
   - icon: fa-github fa-lg
-    href: https://shannonpileggi.github.io/gtreg/
+    href: https://github.com/shannonpileggi/gtreg
 
 reference:
   - title: Data Summaries