R/set_names.R

In RobbyLankford/lankford: Random Functions I Use Frequently

#' Set data types of the columns in a data frame
#'
#' Set the data type of all columns in a data frame at the same time. This is
#' similar to the `set_names()` function from the purrr and rlang packages and
#' is meant to work in a similar way. Instead of passing a vector of names,
#' pass a vector of data types.
#'
#' @param data a data frame whose columns will potentially have their data types altered
#' @param types a vector of data types aligning, in order, to the columns of the data frame. Currently supported data types are \itemize{
#'     \item character
#'     \item integer
#'     \item numeric
#'     \item logical
#'     \item date (from `lubridate::as_date`)
#' }
#'
#' @return If 'types' is NULL, the sama data frame is returned; otherwise, if 'types' is a vector of valid data types, the data frame is returned with the columns coerced to those data types.
#' @export
#'
#' @examples
#' library(dplyr)
#' library(purrr)
#' library(lubridate)
#'
#' char_vec  <- c("abcd", "1234", "hello", "world")
#' int_vec   <- c(1L, 2L, 3L, 4L)
#' num_vec   <- c(3.14, 10, 5.5, 0.12345)
#' logic_vec <- c(TRUE, FALSE, FALSE, NA)
#' date_vec  <- c(
#'     as_date("2020-01-01"),
#'     as_date("2000-01-01"),
#'     as_date("2005-08-31"),
#'     as_date("1969-07-04")
#' )
#'
#' test_data <- tibble(
#'     char_col  = char_vec,
#'     int_col   = int_vec,
#'     num_col   = num_vec,
#'     logic_col = logic_vec,
#'     date_col  = date_vec
#' ) %>% mutate_all(as.character)
#'
#' test_data %>%
#'     set_names(c("characters", "integers", "numerics", "logicals", "dates")) %>%
#'     set_types(c("character", "integer", "numeric", "logical", "date"))
set_types <- function(data, types = NULL) {

  if (is.null(types)) {

    return(data)

  } else if (ncol(data) != length(types)) {

    stop("Argument 'types' must be a vector with the same length as the number of columns in argument 'data'")

  } else if (typeof(types) != "character") {

    stop("Argumnet 'types' must be a character vector")

  } else {

    valid_types <- c("character", "integer", "numeric", "logical", "date")
    types_sub   <- purrr::map_chr(types, substr, start = 1, stop = 1)

    type_functions <- purrr::map(
      .x = types_sub,
      .f = ~ switch(.x,
                    "c" = as.character,
                    "i" = as.integer,
                    "n" = as.numeric,
                    "l" = as.logical,
                    "d" = lubridate::as_date
      )
    )

    check_nulls <- sum(purrr::map_lgl(type_functions, is.null))

    if (check_nulls != 0) {

      type_message <- paste(purrr::map_chr(valid_types, ~ paste0("'", .x, "'")), collapse = ", ")

      stop(paste0("Argument 'types' currently only supports: ", type_message))

    }

    for (i in 1:ncol(data)) {

      data[i] <- lapply(data[i], type_functions[[i]])

    }

    return(data)

  }

}