diff --git a/R/row_to_names.R b/R/row_to_names.R index 14c25a90..606af988 100644 --- a/R/row_to_names.R +++ b/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 -} +} \ No newline at end of file diff --git a/man/row_to_names.Rd b/man/row_to_names.Rd index b2f240cb..001d061d 100644 --- a/man/row_to_names.Rd +++ b/man/row_to_names.Rd @@ -4,7 +4,14 @@ \alias{row_to_names} \title{Elevate a row to be the column names of a data.frame.} \usage{ -row_to_names(dat, row_number, ..., remove_row = TRUE, remove_rows_above = TRUE) +row_to_names( + dat, + row_number, + ..., + remove_row = TRUE, + remove_rows_above = TRUE, + sep = "_" +) } \arguments{ \item{dat}{The input data.frame} @@ -22,6 +29,9 @@ resulting data.frame?} \item{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?} + +\item{sep}{A character string to separate the values in the case of multiple +rows input to `row_number`.} } \value{ A data.frame with new names (and some rows removed, if specified) diff --git a/tests/testthat/test-row-to-names.R b/tests/testthat/test-row-to-names.R index 523e735e..4fbcc1f6 100644 --- a/tests/testthat/test-row-to-names.R +++ b/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") + ) + +})