Merge pull request #542 from matanhakim/main

Allow multiple rows input to row_to_names()

R/row_to_names.R

@@ -11,6 +11,8 @@
 #' @param remove_rows_above If \code{row_number != 1}, should the rows above
 #'   \code{row_number} - that is, between \code{1:(row_number-1)} - be removed
 #'   from the resulting data.frame?
+#' @param sep A character string to separate the values in the case of multiple
+#'   rows input to `row_number`.
 #' @return A data.frame with new names (and some rows removed, if specified)
 #' @family Set names
 #' @examples
@@ -22,16 +24,14 @@
 #' x %>%
 #'   row_to_names(row_number = "find_header")
 #' @export
-row_to_names <- function(dat, row_number, ..., remove_row = TRUE, remove_rows_above = TRUE) {
+row_to_names <- function(dat, row_number, ..., remove_row = TRUE, remove_rows_above = TRUE, sep = "_") {
   # Check inputs
   if (!(is.logical(remove_row) & length(remove_row) == 1)) {
     stop("remove_row must be either TRUE or FALSE, not ", as.character(remove_row))
   } else if (!(is.logical(remove_rows_above) & length(remove_rows_above) == 1)) {
     stop("remove_rows_above must be either TRUE or FALSE, not ", as.character(remove_rows_above))
-  } else if (length(row_number) != 1) {
-    stop("row_number must be a scalar")
   }
-  if (row_number %in% "find_header") {
+  if (identical(row_number, "find_header")) {
     # no need to check if it is a character string, %in% will do that for us
     # (and will handle the odd-ball cases like someone sending in
     # factor("find_header")).
@@ -44,7 +44,18 @@ row_to_names <- function(dat, row_number, ..., remove_row = TRUE, remove_rows_ab
   } else {
     stop("row_number must be a numeric value or 'find_header'")
   }
-  new_names <- as.character(unlist(dat[row_number, ], use.names = FALSE))
+  if (!is.character(sep)) {
+    stop("`sep` must be of type `character`.")
+  }
+  if (length(sep) != 1){
+    stop("`sep` must be of length 1.")
+  }
+  if (is.na(sep)) {
+    stop("`sep` can't be of type `NA_character_`.")
+  }
+  new_names <- sapply(dat[row_number, ], paste_skip_na, collapse = sep) %>% 
+    stringr::str_replace_na()
+
   if (any(duplicated(new_names))) {
     rlang::warn(
       message=paste("Row", row_number, "does not provide unique names. Consider running clean_names() after row_to_names()."),
@@ -59,7 +70,7 @@ row_to_names <- function(dat, row_number, ..., remove_row = TRUE, remove_rows_ab
       c()
     },
     if (remove_rows_above) {
-      seq_len(row_number - 1)
+      seq_len(max(row_number) - 1)
     } else {
       c()
     }
@@ -138,4 +149,4 @@ find_header <- function(dat, ...) {
     stop("Either zero or one arguments other than 'dat' may be provided.")
   }
   ret
-}
+}

tests/testthat/test-row-to-names.R

@@ -18,12 +18,6 @@ example_data_row_to_names[[3]] <- tibble::as_tibble(example_data_row_to_names[[1
 names(example_data_row_to_names)[3] <- "tibble"
 
 test_that("row_to_names invalid and semi-valid input checking", {
-  expect_error(
-    example_data_row_to_names[[1]] %>%
-      row_to_names(row_number = 1:2),
-    regexp="row_number must be a scalar"
-  )
-
   expect_error(
     row_to_names(example_data_row_to_names[[1]], row_number=1, remove_row="A"),
     regexp="remove_row must be either TRUE or FALSE, not A",
@@ -71,6 +65,37 @@ test_that("row_to_names invalid and semi-valid input checking", {
     regexp="Extra arguments (...) may only be given if row_number = 'find_header'.",
     fixed=TRUE
   )
+
+  expect_error(
+    row_to_names(
+      example_data_row_to_names[[1]],
+      row_number=1, remove_row=TRUE, remove_rows_above=TRUE,
+      sep=8
+    ),
+    regexp="`sep` must be of type `character`.",
+    fixed=TRUE
+  )
+
+  expect_error(
+    row_to_names(
+      example_data_row_to_names[[1]],
+      row_number=1, remove_row=TRUE, remove_rows_above=TRUE,
+      sep=c("_", "-")
+    ),
+    regexp="`sep` must be of length 1.",
+    fixed=TRUE
+  )
+
+  expect_error(
+    row_to_names(
+      example_data_row_to_names[[1]],
+      row_number=1, remove_row=TRUE, remove_rows_above=TRUE,
+      sep=NA_character_
+    ),
+    regexp="`sep` can't be of type `NA_character_`.",
+    fixed=TRUE
+  )
+
 })
 
 test_that("row_to_names works on factor columns", {
@@ -223,3 +248,46 @@ test_that("find_header works within row_to_names", {
     setNames(find_correct[4:nrow(find_correct),], c("D", "E"))
   )
 })
+
+test_that("multiple rows input works", {
+
+  df_multiple_na <- example_data_row_to_names[[1]]
+  df_multiple_na[6:7, ] <- NA
+
+  expect_equal(
+    suppressWarnings(
+      row_to_names(example_data_row_to_names[[1]], row_number=1) %>% 
+        names()
+    ),
+    c("NA", "NA")
+  )
+
+  expect_equal(
+    suppressWarnings(
+      row_to_names(example_data_row_to_names[[1]], row_number=c(1,1)) %>% 
+        names()
+    ),
+    c("NA", "NA")
+  )
+
+  expect_equal(
+    row_to_names(example_data_row_to_names[[1]], row_number=1:2) %>% 
+      names(),
+    c("Title", "Title2")
+  )
+
+  expect_equal(
+    row_to_names(example_data_row_to_names[[1]], row_number=1:5) %>% 
+      names(),
+    c("Title_1_2_3", "Title2_4_5_6")
+  )
+
+  expect_equal(
+    suppressWarnings(
+      row_to_names(df_multiple_na, row_number=c(1,6,7), remove_rows_above = FALSE) %>% 
+        names()
+    ),
+    c("NA", "NA")
+  )
+
+})