update with upstream

.github/workflows/R-CMD-check.yaml

@@ -8,6 +8,8 @@ on:
 
 name: R-CMD-check
 
+permissions: read-all
+
 jobs:
   R-CMD-check:
     runs-on: ${{ matrix.config.os }}
@@ -29,7 +31,7 @@ jobs:
       R_KEEP_PKG_SOURCE: yes
 
     steps:
-      - uses: actions/checkout@v3
+      - uses: actions/checkout@v4
 
       - uses: r-lib/actions/setup-pandoc@v2
 
@@ -49,3 +51,4 @@ jobs:
       - uses: r-lib/actions/check-r-package@v2
         with:
           upload-snapshots: true
+          build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")'

.github/workflows/pkgdown.yaml

@@ -11,6 +11,8 @@ on:
 
 name: pkgdown
 
+permissions: read-all
+
 jobs:
   pkgdown:
     runs-on: ubuntu-latest
@@ -19,8 +21,10 @@ jobs:
       group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }}
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+    permissions:
+      contents: write
     steps:
-      - uses: actions/checkout@v3
+      - uses: actions/checkout@v4
 
       - uses: r-lib/actions/setup-pandoc@v2
 
@@ -39,7 +43,7 @@ jobs:
 
       - name: Deploy to GitHub pages 🚀
         if: github.event_name != 'pull_request'
-        uses: JamesIves/github-pages-deploy-action@v4.4.1
+        uses: JamesIves/github-pages-deploy-action@v4.5.0
         with:
           clean: false
           branch: gh-pages

.github/workflows/style.yaml

@@ -6,14 +6,18 @@ on:
 
 name: Style
 
+permissions: read-all
+
 jobs:
   style:
     runs-on: ubuntu-latest
+    permissions:
+      contents: write
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
     steps:
       - name: Checkout repo
-        uses: actions/checkout@v3
+        uses: actions/checkout@v4
         with:
           fetch-depth: 0
 
@@ -46,7 +50,7 @@ jobs:
         shell: Rscript {0}
 
       - name: Cache styler
-        uses: actions/cache@v3
+        uses: actions/cache@v4
         with:
           path: ${{ steps.styler-location.outputs.location }}
           key: ${{ runner.os }}-styler-${{ github.sha }}

.github/workflows/test-coverage.yaml

@@ -8,14 +8,16 @@ on:
 
 name: test-coverage
 
+permissions: read-all
+
 jobs:
   test-coverage:
     runs-on: ubuntu-latest
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
 
     steps:
-      - uses: actions/checkout@v3
+      - uses: actions/checkout@v4
 
       - uses: r-lib/actions/setup-r@v2
         with:
@@ -26,27 +28,37 @@ jobs:
           extra-packages: |
             any::sf
             any::covr
+            any::xml2
           needs: coverage
 
       - name: Test coverage
         run: |
-          covr::codecov(
+          cov <- covr::package_coverage(
             quiet = FALSE,
             clean = FALSE,
-            install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package")
+            install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package")
           )
+          covr::to_cobertura(cov)
         shell: Rscript {0}
 
+      - uses: codecov/codecov-action@v4
+        with:
+          fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }}
+          file: ./cobertura.xml
+          plugin: noop
+          disable_search: true
+          token: ${{ secrets.CODECOV_TOKEN }}
+
       - name: Show testthat output
         if: always()
         run: |
           ## --------------------------------------------------------------------
-          find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true
+          find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true
         shell: bash
 
       - name: Upload test results
         if: failure()
-        uses: actions/upload-artifact@v3
+        uses: actions/upload-artifact@v4
         with:
           name: coverage-test-failures
           path: ${{ runner.temp }}/package

NAMESPACE

@@ -69,6 +69,7 @@ importFrom(lubridate,second)
 importFrom(lubridate,ymd)
 importFrom(lubridate,ymd_hms)
 importFrom(magrittr,"%>%")
+importFrom(rlang,"%||%")
 importFrom(rlang,dots_n)
 importFrom(rlang,expr)
 importFrom(rlang,syms)

NEWS.md

@@ -6,6 +6,9 @@ These are all minor breaking changes resulting from enhancements and are not exp
 
 * When using `row_to_names()`, when all input values in `row_number` for a column are `NA`, `row_to_names()` creates a column name of `"NA"`, a character, rather than `NA`. If code previously used relied on a column name of `NA`, it will now error. To fix this, rely on a column name of `"NA"`.
 
+* When `tabyl()` is called on a data.frame containing labels, it now displays the label attribute as the name of the first column in the the resulting `tabyl` object (@olivroy, #394). This may break subsequent code that refers to the output of such a `tabyl` by column name. To maintain the previous behavior of ignoring variable labels, you can remove the labels with a function like `haven::zap_labels()` or `labelled::remove_labels()` before calling `tabyl()`.
+
+
 ## New features
 
 * A new function `paste_skip_na()` pastes without including NA values (#537).
@@ -24,6 +27,8 @@ These are all minor breaking changes resulting from enhancements and are not exp
 
 * `get_one_to_one()` no longer errors with near-equal values that become identical factor levels (fix #543, thanks to @olivroy for reporting)
 
+* `clean_names()` for sf objects now works in cases when the sf_column is not the last column name (fix #578, thanks to @ar-puuk for reporting and @billdenney for fixing)
+
 ## Refactoring
 
 * Remove dplyr verbs superseded in dplyr 1.0.0 (#547, @olivroy)

R/clean_names.R

@@ -106,10 +106,10 @@ clean_names.sf <- function(dat, ..., set_labels = FALSE) {
   } # nocov end
   # get old names
   sf_names <- names(dat)
-  # identify ending column index to clean
-  n_cols <- length(dat) - 1
+  # Clean the names except for the "sf_column" which is used internally by sf
+  cols_to_rename <- which(!(sf_names %in% attr(dat, "sf_column")))
   # clean all but last column
-  sf_cleaned <- make_clean_names(sf_names[1:n_cols], ...)
+  sf_cleaned <- make_clean_names(sf_names[cols_to_rename], ...)
   # rename original df
   names(dat)[1:n_cols] <- sf_cleaned
 
@@ -119,7 +119,7 @@ clean_names.sf <- function(dat, ..., set_labels = FALSE) {
     }
   }
 
-  return(dat)
+  dat
 }
 
 #' @rdname clean_names

R/get_dupes.R

@@ -22,7 +22,7 @@
 #' mtcars %>% get_dupes(-c(wt, qsec))
 #' mtcars %>% get_dupes(starts_with("cy"))
 #' @importFrom tidyselect eval_select
-#' @importFrom rlang expr dots_n syms
+#' @importFrom rlang expr dots_n syms %||%
 get_dupes <- function(dat, ...) {
   expr <- rlang::expr(c(...))
   pos <- tidyselect::eval_select(expr, data = dat)

R/print_tabyl.R

@@ -1,5 +1,4 @@
 #' @export
-
 print.tabyl <- function(x, ...) {
   print.data.frame(x, row.names = FALSE)
 }

R/tabyl.R

@@ -66,7 +66,6 @@ tabyl.default <- function(dat, show_na = TRUE, show_missing_levels = TRUE, ...)
     var_name <- names(dat)
   }
 
-
   # useful error message if input vector doesn't exist
   if (is.null(dat)) {
     stop(paste0("object ", var_name, " not found"))
@@ -76,6 +75,13 @@ tabyl.default <- function(dat, show_na = TRUE, show_missing_levels = TRUE, ...)
     var_name <- paste(var_name, collapse = "")
   }
 
+  # Try to retrieve label
+  if (is.data.frame(dat)) {
+    var_label <- attr(dat[, var_name], "label", exact = TRUE) %||% var_name
+  } else {
+    var_label <- attr(dat, "label", exact = TRUE) %||% var_name
+  }
+
   # if show_na is not length-1 logical, error helpfully (#377)
   if (length(show_na) > 1 || !inherits(show_na, "logical")) {
     stop("The value supplied to the \"show_na\" argument must be TRUE or FALSE.\n\nDid you try to call tabyl on two vectors, like tabyl(data$var1, data$var2) ? To create a two-way tabyl, the two vectors must be in the same data.frame, and the function should be called like this: \n
@@ -133,8 +139,8 @@ tabyl.default <- function(dat, show_na = TRUE, show_missing_levels = TRUE, ...)
       dplyr::mutate(percent = n / sum(n, na.rm = TRUE)) # recalculate % without NAs
   }
 
-  # reassign correct variable name
-  names(result)[1] <- var_name
+  # reassign correct variable name (or label if it exists)
+  names(result)[1] <- var_label
 
   # in case input var name was "n" or "percent", call helper function to set unique names
   result <- handle_if_special_names_used(result)
@@ -238,10 +244,11 @@ tabyl_2way <- function(dat, var1, var2, show_na = TRUE, show_missing_levels = TR
     result <- result[c(setdiff(names(result), "NA_"), "NA_")]
   }
 
-
-  result %>%
-    data.frame(., check.names = FALSE) %>%
-    as_tabyl(axes = 2, row_var_name = names(dat)[1], col_var_name = names(dat)[2])
+  row_var_name <- names(dat)[1]
+  col_var_name <- names(dat)[2]
+  names(result)[1] <- attr(dat[, 1], "label", exact = TRUE) %||% names(result)[1]
+  data.frame(result, check.names = FALSE) %>%
+    as_tabyl(axes = 2, row_var_name = row_var_name, col_var_name = col_var_name)
 }
 
 
@@ -250,6 +257,10 @@ tabyl_3way <- function(dat, var1, var2, var3, show_na = TRUE, show_missing_level
   dat <- dplyr::select(dat, !!var1, !!var2, !!var3)
   var3_numeric <- is.numeric(dat[[3]])
 
+  # Preserve labels, as attributes are sometimes dropped during transformations.
+  var1_label <- attr(dat[, 1], "label", exact = TRUE)
+  var2_label <- attr(dat[, 2], "label", exact = TRUE)
+
   # Keep factor levels for ordering the list at the end
   if (is.factor(dat[[3]])) {
     third_levels_for_sorting <- levels(dat[[3]])
@@ -277,7 +288,14 @@ tabyl_3way <- function(dat, var1, var2, var3, show_na = TRUE, show_missing_level
     dat[[2]] <- as.factor(dat[[2]])
   }
 
-  result <- split(dat, dat[[rlang::quo_name(var3)]]) %>%
+  result <- split(dat, dat[[rlang::quo_name(var3)]])
+  # split() drops attributes, so we manually add back the label attributes.
+  result <- lapply(result, function(x) {
+    attr(x[[1]], "label") <- var1_label
+    attr(x[[2]], "label") <- var2_label
+    x
+  })
+  result <- result %>%
     purrr::map(tabyl_2way, var1, var2, show_na = show_na, show_missing_levels = show_missing_levels) %>%
     purrr::map(reset_1st_col_status, col1_class, col1_levels) # reset class of var in 1st col to its input class, #168
 

tests/testthat/test-clean-names.R

@@ -477,6 +477,15 @@ test_that("Names are cleaned appropriately without attaching sf", {
 
   expect_equal(names(clean)[4], "cnty_id")
   expect_s3_class(clean, "sf")
+
+  # Issue #578, sf_column attribute needs to be untouched, it may not be the
+  # last column name
+  issue_578_sf <- readRDS("testdata/issue-578-sf.rds")
+  issue_578_sf_clean <- clean_names(issue_578_sf)
+  expect_error(
+    print(issue_578_sf_clean),
+    NA
+  )
 })
 
 test_that("Names are cleaned appropriately", {

tests/testthat/test-tabyl.R

@@ -395,6 +395,17 @@ test_that("3-way tabyl with 3rd var factor is listed in right order, #250", {
   expect_equal(names(tabyl(z, am, gear, cyl)), c("8", "6", "NA_"))
 })
 
+test_that("tabyl works with label attributes (#394)", {
+  mt_label <- mtcars
+  attr(mt_label$cyl, "label") <- "Number of cyl"
+  tab <- tabyl(mt_label, cyl)
+  expect_named(tab, c("Number of cyl", "n", "percent"))
+  tab2 <- tabyl(mt_label, cyl, am)
+  expect_named(tab2, c("Number of cyl", "0", "1"))
+  tab3 <- tabyl(mt_label, cyl, am, vs)
+  expect_equal(names(tab3[[1]])[1], "Number of cyl")
+})
+
 test_that("tabyl works with ordered 1st variable, #386", {
   mt_ordered <- mtcars
   mt_ordered$cyl <- ordered(mt_ordered$cyl, levels = c("4", "8", "6"))