#' Convert from anybase to decimal
#'
#' @param value The starting value
#' @param symbols A vector containing all of the symbols used in the origin place
#' value system listed in sequential order.
#' @param zero_indexed Logical. Set to TRUE if the first value in \code{symbols}
#' represents 1, FALSE if 0.
#' @return \code{value} converted to decimal
#' @examples
#' library(magrittr)
#' anyBaseToDecimal("A")
#' anyBaseToDecimal("ABC")
#' anyBaseToDecimal("FF", symbols = c(0:9, LETTERS[1:6]), zero_indexed=TRUE) #hex to decimal
#' @export
anyBaseToDecimal <- function(value, symbols = LETTERS, zero_indexed = FALSE) {
symbols %<>% as.character()
value %<>% as.character() %>%
strsplit(split = "") %>%
`[[`(1) %>%
rev() %>%
match(symbols)
if (zero_indexed) {
value %<>% `-`(1)
}
res <- value %*% (length(symbols)^(seq_along(value) - 1)) %>% drop()
return(res)
}
#' Convert characters to integers
#'
#' A wrapper around `any_base_to_decimal`, useful for converting characters into integers for indexing
#' Excel documents.
#' @param string A character string.
#' @export
chr_to_int <- function(string) {
if (!is.character(string)) stop("string is not of class character")
index_func <- function(s) {
if (grepl(":", s)) {
tmp <- stringr::str_split(s, ":", simplify = T) %>%
unlist() %>%
purrr::map_dbl(anyBaseToDecimal)
col_idx <- seq(tmp[1], tmp[2])
}
else {
col_idx <- sapply(s, anyBaseToDecimal)
}
}
purrr::map(string, index_func) %>%
purrr::reduce(c) %>%
unique()
}
#' Export a plot list as PNGs
#'
#' @description Takes a list of plot objects and builds a folder with those plots as individual png files
#' @param plot_list List containing plot objects
#' @param dir_path Path for output directory that will be created
#' @param overwrite Logical indicating whether to overwrite an existing directory with the same path. Defaults to \code{TRUE} for easy analysis interation. Adjust to \code{FALSE} to add individual images to existing directory, may throw errors about existing files.
#' @param height Numeric object describing height of graphics device. Default unit is inches.
#' @param width Numeric object describing width of graphics device. Default unit is inches.
#' @param units Character object, for unit used in height and width, "in" (inches by default). Can be "px", "mm", or "cm".
#' @return A directory with the elements of \code{plot_list} as png files
#' @examples
#' \dontrun{
#' plots <- mtcars %>% split(.$cyl) %>%
#' purrr::map(~ ggplot(., aes(mpg, disp)) +
#' geom_point())
#' export_pngs(plots, "~/Desktop/mtcars_plots_by_cyl.pdf")
#' }
#' @importFrom grDevices dev.cur dev.off png
#' @export
export_pngs <- function(plot_list, dir_path, overwrite = TRUE,
height = 8.5, width = 11, units = "in") {
while (dev.cur() != "1") {
dev.off()
}
if (overwrite) {
if (file.exists(dir_path)) {
system(paste("rm -r", dir_path))
}
}
if (!file.exists(dir_path)) {
system(paste("mkdir", dir_path))
}
for (i in 1:length(plot_list)) {
png_title <- NULL
if (class(plot_list[[i]])[1] == "gg") {
png_title <- plot_list[[i]]$labels$title
}
if (length(png_title) < 1) {
png_title <- names(plot_list)[i]
}
png_title %<>% gsub(" |\\:|/", "_", .)
png(
filename = paste0(
dir_path, "/", i, "_", png_title,
".png"
), units = units, height = height, width = width,
res = 300
)
print(plot_list[[i]])
dev.off()
}
}
#' @title Export a plot list as a PDF
#'
#' @description Takes a list of plot objects and builds a pdf document with those plots.
#' @param plot_list List containing plot objects.
#' @param pdf_path Path for output pdf that will be created. Should end in ".pdf".
#' @param overwrite Logical indicating whether to overwrite an existing directory with the same path. Defaults to \code{TRUE} for easy analysis interation. Adjust to \code{FALSE} to add individual images to existing directory, may throw errors about existing files.
#' @param height Numeric object describing height of graphics device. Default unit is inches.
#' @param width Numeric object describing width of graphics device. Default unit is inches.
#' @return A directory with the elements of \code{plot_list} as png files
#' @examples
#' \dontrun{
#' plots <- mtcars %>% split(.$cyl) %>%
#' purrr::map(~ ggplot(., aes(mpg, disp)) +
#' geom_point())
#' export_pdf(plots, "~/Desktop/mtcars_plots_by_cyl.pdf")
#' }
#' @importFrom grDevices dev.cur dev.off pdf
#' @export
export_pdf <- function(plot_list, pdf_path, overwrite = TRUE,
height = 8.5, width = 11) {
while (dev.cur() != "1") {
dev.off()
}
if (overwrite) {
if (file.exists(pdf_path)) {
system(paste("rm", pdf_path))
}
}
pdf(pdf_path, height = height, width = width)
purrr::walk(plot_list, print)
dev.off()
}
#' Concatenate a set of PDFs
#'
#' @param outfile Character vector of length 1 indicating path for
#' output PDF file
#' @param pdf_paths Character vector of length n representing
#' paths to PDF files to be merged (order matters)
#' @export
compileReport <- function(outfile, pdf_paths) {
cmd <- paste(
shQuote("/System/Library/Automator/Combine PDF Pages.action/Contents/Resources/join.py"),
"-o", outfile
)
for (i in 1:length(pdf_paths)) {
cmd <- paste(cmd, shQuote(pdf_paths[i]))
}
system(cmd)
}
#' Make a vector of serially halved values.
#'
#' @param starting_concentration The highest value in the geometric progression.
#' @param number The number of additional values in the sequence.
#' @return A vector containing the geometric progression
#' @examples
#' serial_dilution(10, 5)
#' @export
serial_dilution <- function(starting_concentration, number) {
dils <- 2^(-1 * seq(0, number, 1))
dils * starting_concentration
}
#' Geometric mean
#'
#' Calculate the geometric mean.
#' @param x A numeric vector.
#' @return The geometric mean of \code{x}.
#' @examples
#' x <- rpois(10, lambda = 10)
#' geom_mean(x)
#' @importFrom stats na.omit
#' @export
geom_mean <- function(x) {
x <- stats::na.omit(x)
res <- mean(log(x))
res <- exp(res)
return(res)
}
#' Geometric standard error of the mean
#'
#' Calculate the geometric standard error of the mean.
#' @param x A numeric vector.
#' @param mult A numeric value, the time to multiply se by.
#' @return The geometric standard error of the mean of \code{x}.
#' @examples
#' x <- rpois(10, lambda = 10)
#' geom_mean_se(x)
#' @importFrom stats na.omit var
#' @export
geom_mean_se <- function(x, mult = 1) {
x <- stats::na.omit(x)
x <- log(x)
se <- mult * sqrt(stats::var(x) / length(x))
mean <- mean(x)
res <- data.frame(y = exp(mean), ymin = exp(mean - se), ymax = exp(mean + se))
return(res)
}
#' Convert concentrations of zero to non-zero values in a dose range.
#'
#' Selects a small non-zero value to represent zero in a dose range. New value is calculated relative to the
#' smallest non-zero dose based on the dosing interval.
#' @param vec A numeric vector with the concentrations in dose range.
#' @param steps Number of intervals below the smallest non-zero dose.
#' @param is_log Default is `FALSE`. Are the concentration values in `vec` log transformed?
#' @return A numeric value to represent zero in dose range.
#' @examples
#' drc_concs <- c(0, .3, 1, 3, 10, 30, 100)
#' drc_concs[drc_concs == 0] <- new_zeros(drc_concs)
#' drc_concs
#' @export
new_zeros <- function(vec, steps = 2, is_log = FALSE) {
vec %<>% unique() %>% sort()
vec <- vec[vec != 0]
if (!is_log) {
vec %<>% log10()
}
avg_gap <- (vec - dplyr::lead(vec)) %>%
mean(na.rm = T) %>%
abs()
nz <- min(vec) - steps * avg_gap
if (!is_log) {
nz %<>% 10^.
}
return(nz)
}
#' Make factor levels sync with those of a reference data.frame.
#'
#' Useful when plotting with multiple data sources.Often summary data.frames can
#' lose the original data levels during manipulation and when you return to plot
#' them facet, axis order is controlled by `as.factor()`'s sort order if the levels
#' in the objects don't match. As of forcats_v0.4.0 there is function `forcats::fct_match()`,
#' so the assayr2 function has been renamed to `fct_sync()`.
#'
#' @param datf The data.frame needing to be factor leveled.
#' @param ref_datf The reference data.frame with the ideal factor levels.
#' @return A tibble.
#' @examples
#' library(dplyr)
#' library(purrr)
#' library(tidyr)
#' library(ggplot2)
#'
#' data(mtcars)
#' mt1 <- mtcars %>% mutate(cyl = factor(cyl, levels = c(6,8,4)),
#' am = factor(am, levels = c(1,0)))
#' mt2 <- mtcars %>% split(list(.$cyl, .$am)) %>%
#' map_df(~ lm(mpg ~ hp, data = .) %>% coef() %>% bind_rows() %>%
#' set_names(c("b", "m")), .id = "splitt") %>%
#' separate(splitt, c("cyl", "am"), sep = "\\.")
#'
#' mt1$cyl
#' mt2$cyl
#' mt1$am
#' mt2$am
#'
#' # panel order is controlled by as.factor()
#' ggplot(mt1, aes(x = hp, y = mpg)) +
#' geom_point() +
#' geom_abline(data = mt2, aes(slope = m, intercept = b)) +
#' facet_grid(am~cyl)
#'
#' # fix the panel order
#' mt2 <- fct_sync(mt2, mt1)
#' ggplot(mt1, aes(x = hp, y = mpg)) +
#' geom_point() +
#' geom_abline(data = mt2, aes(slope = m, intercept = b)) +
#' facet_grid(am~cyl)
#' @md
#' @importFrom utils data
#' @export
fct_sync <- function(datf, ref_datf) {
fcts <- which(purrr::map_lgl(ref_datf, is.factor)) %>% names()
for (f in fcts) {
if (f %in% names(datf)) {
datf[[f]] %<>% factor(levels = levels(ref_datf[[f]]))
}
}
datf
}
#' @rdname fct_sync
#' @export
fct_match <- function(datf, ref_datf) {
.Deprecated("fct_sync",
package = "asssayr2",
"forcats_v0.4.0 released fct_match(), so the function in assayr2 was renamed fct_sync()")
fcts <- which(purrr::map_lgl(ref_datf, is.factor)) %>% names()
for (f in fcts) {
if (f %in% names(datf)) {
datf[[f]] %<>% factor(levels = levels(ref_datf[[f]]))
}
}
datf
}
#' Alternate version of `table`, with `useNA = "ifany"`
#'
#' Useful for data cleaning checks.
#'
#' @param ... Arguments passed to table.
#' @examples
#' x <- c(rep(1:3,3), rep(NA, 3))
#' table(x)
#' tabla(x)
#' y <- na.omit(x)
#' tabla(y)
#' @export
tabla <- function(...) {
table(..., useNA = "ifany")
}
#' An abbreviation for position_dodge()
#'
#' Takes width as the first argument for conveience
#' @param width Numeric. Passed to `position_dodge(width = )`.
#' @param ... Other arguments passed on to `position_dodge()`.
#' @export
pd <- function(width, ...) {
position_dodge(width = width, ...)
}
#' Wrapper around `dir()`
#'
#' Useful for working with Excel files, because it does not list the temporary
#' files starting with '~'
#'
#' @md
#' @param ... Arguments passed on to `dir(...)`
#' @export
der <- function(...) {
files <- dir(...)
files[!grepl("~", files)]
}
#' Complete theme for assayr2.
#'
#' Built on top of `ggplot2::theme_classic()` with some minor tweaks.
#' @md
#' @param base_size Font size in pts for labels
#' @param base_family Font family to used for labels
#' @examples
#' library(ggplot2)
#' ggplot(mtcars, aes(mpg, hp, color = as.factor(cyl))) +
#' geom_point() +
#' theme_assayr()
#' @export
theme_assayr <- function(base_size = 18, base_family = "") {
ggplot2::theme_classic(base_size = base_size, base_family = base_family) +
ggplot2::theme(
panel.border = ggplot2::element_rect(colour = "black", fill = NA, size = 1),
strip.background = ggplot2::element_rect(linetype = "blank"),
plot.title = ggplot2::element_text(size = ggplot2::rel(1)),
axis.text = ggplot2::element_text(size = ggplot2::rel(0.75)),
panel.grid.minor = ggplot2::element_line(colour = "grey90", size = 0.5),
panel.grid.major = ggplot2::element_line(colour = "grey90", size = 0.5),
legend.position = "top",
legend.direction = "horizontal",
legend.box = "vertical",
complete = TRUE
)
}
#' @importFrom snakecase to_snake_case
#' @export
snakecase::to_snake_case
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.