R/refactor.R

In graggsd/sgcleanup: Useful Functions to Clean and Reshape Data

#' Create a factor based on specified level:index pairs
#'
#' \code{refactor_by_idx} changes \code{x} to a factor, and specifies level
#' order based the 1:1 pairing of \code{levs} and \code{idx}
#'
#' @param x A vector that will be converted to a factor based with level order
#' specified by \code{levs}:\code{idx} pairing
#' \code{from}.
#' @param levs The levels contained in \code{x}
#' @param idx The order in which \code{levs} will be incorporated into the
#' new factor
#' @return A factor with levels ordered according to \code{levs}:\code{idx}
#' pairing
#' @export
refactor_by_idx <- function(x, levs, idx) {

    stopifnot(length(levs) == length(idx),
              sum(duplicated(levs)) == 0,
              sum(duplicated(idx)) == 0)

    idx <- order(idx)
    x <- factor(x, levels = levs[idx])
    return(x)
}

#' Combine the levels or unique values of multiple columns into a vector
#'
#' A function designed to collect the factor levels
#' and unique values within a series of columns and combine them into one
#' vector. This may be useful when trying to construct a table using
#' \code{htmlTable_td}.
#'
#' @param x A dataframe
#' @param cols The columns from which to grab unique values and factor levels
#' @param rev Specifies which columns will have a reversed order
#' @return Returns a vector of unique values and levels ordered in a manner
#' consistent with the columns from which they were derived.
#' @export
get_factor_levels <- function(x, cols, rev = FALSE) {

    stopifnot(is.numeric(rev) | is.logical(rev))

    # Create a vector of logicals based on the input into rev
    if (is.logical(rev)) {
        if (length(rev) == 1) {
            rev <- rep(rev, length(cols))
        } else if (length(rev) != length(cols)) {
            stop(paste0("If rev is logical, it must be of length 1 or the same",
                        " lengths as cols"))
        }
    } else {
        tmp_rev <- rep(FALSE, length(cols))
        tmp_rev[rev] <- TRUE
        rev <- tmp_rev
    }

    names(rev) <- cols

    # Create a vector of levels (revered order of specific columns based on
    # rev argument)
    levs <- NULL
    for (col in cols) {
        if (is.factor(x[, col])) {
            tmp_lev <- levels(x[, col])
        } else {
            tmp_lev <- sort(unique(x[, col]))
        }

        if (rev[names(rev) == col]) {tmp_lev <- rev(tmp_lev)}
        levs <- c(levs, tmp_lev)
    }

    return(unique(levs))
}

#' Function to retrieve the first level from one or more columns in a data.frame
#'
#' \code{get_first_levels} is a function that may be used to retrieve the first
#' level from one or more columns in a data.frame
#'
#' @param x A dataframe
#' @param cols The columns from which to retrieve first levels
#' @return Returns a vector of first levels
#' @export
get_first_levels <- function(x, cols) {

    # Create a vector of levels (revered order of specific columns based on
    # rev argument)
    levs <- NULL
    for (col in cols) {
        if (is.factor(x[, col])) {
            levs <- c(levs, levels(x[, col])[1])
        } else {
            levs <- c(levs, sort(unique(x[, col]))[1])
        }
    }

    names(levs) <- cols
    return(levs)
}