R/utils.R

In hemoshear/assayr2: Tools for analyzing assay data

#' 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