#' Replace character elements and convert to factor.
#'
#' @description
#' Replace the elements in a character and convert to a factor. The levels of the factor
#' are the same order as the replacement vector.
#'
#' @param x A character vector to replace.
#' @param replacement A named character vector with the original character elements as
#' elements and desired replacement elements as names.
#'
#' @importFrom stringr str_replace_all
#'
#' @export
#'
as_replaced_factor <- function(x, replacement) {
## Class check
stopifnot(inherits(x, "character"))
stopifnot(inherits(replacement, "character"))
# Make sure replacement has names
if (is.null(names(replacement))) stop("replacement must be a named vector.")
x_repl <- str_replace_all(string = x, pattern = replacement)
factor(x_repl, levels = replacement)
}
#' Setting factor contrasts
#'
#' @description
#' Functions for manipulating the contrasts of factors.
#'
#' A wrapper of \code{\link[stats]{contr.sum}}, but the resulting contrasts matrix included column names
#' and is easier for extracting coefficients from a fitted model object
#'
#' @param x A factor.
#' @param drop.levels Logical. Should unused levels be dropped?
#'
#' @export
#' @importFrom stats contr.sum contrasts
#'
fct_contr_sum <- function(x, drop.levels = FALSE) {
stopifnot(is.factor(x))
stopifnot(is.logical(drop.levels))
# Drop levels, if called for
x1 <- if (drop.levels) droplevels(x = x) else x
# Redefine contrasts as sum-to-zero
x1_contrasts <- contr.sum(levels(x1))
colnames(x1_contrasts) <- head(levels(x1), -1)
contrasts(x1) <- x1_contrasts
return(x1)
}
#' @describeIn fct_contr_sum
#'
#' @param checks Levels of the factor \code{x} corresponding to "checks"
#'
#' @export
#'
fct_contr_check_trt <- function(x, checks, drop.levels = FALSE) {
# Error
stopifnot(is.logical(drop.levels))
# Convert x to factor, if not
x1 <- as.factor(x)
# Check if checks are levels of x
checks1 <- intersect(levels(x1), checks)
# Find the non-check levels
non_checks <- setdiff(levels(x1), checks1)
## Create a base contrast matrix - diagonal
contr <- diag(x = nlevels(x1))
dimnames(contr) <- replicate(2, levels(x1), simplify = FALSE)
## Add check contrasts
## Contrasts must sum to 0
## Compare positive groups with negative groups
contr[checks1, non_checks] <- - (1 / length(checks1))
contr[non_checks, checks1] <- - (1 / length(non_checks))
# Add the contrast matrix to the factor vector
contrasts(x1) <- contr
# Return x1
return(x1)
}
#' Return the size of objects in the environment
#'
#' @import dplyr
#' @import purrr
#'
#' @export
#'
object_size <- function(unit = "auto") {
objects <- ls(envir = .GlobalEnv)
size <- map(objects, ~object.size(x = get(.)))
size_num <- as.numeric(unlist(size))
size2 <- map_chr(size, ~format(., unit = unit))
tibble(object = objects, size = size2)[order(size_num, decreasing = TRUE),]
}
#' Format numbers for printing
#'
#' @description
#' Formats numbers using specified significant digits for printing tables or graphs
#'
#' @param x A numeric vector.
#' @param signif.digits An integer specifying the number of significant digits
#'
#' @export
#'
format_numbers <- function(x, signif.digits = 3L) {
stopifnot(is.numeric(x))
stopifnot(is.numeric(signif.digits))
formatC(x = signif(x = x, digits = signif.digits), digits = signif.digits, format = "fg", flag = "#")
}
#' Search for a directory in a path
#'
#' @description
#' Find the full path of a directory in the path of the current working directory
#'
#' @param pattern A character pattern of the directory to search for
#'
#' @export
#'
#'
find_dir <- function(pattern) {
stopifnot(is.character(pattern))
cwd <- getwd()
cwd_split <- strsplit(cwd, "/")[[1]]
where_dir <- which(grepl(pattern = pattern, x = cwd_split))
paste0(cwd_split[seq_len(where_dir)], collapse = "/")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.