R/utilities_base.R

In ggpubr: 'ggplot2' Based Publication Ready Plots

#::::::::::::::::::::::::::::::::::::::::::::::::::::
# General helper functions
#::::::::::::::::::::::::::::::::::::::::::::::::::::

# Get random string
.random_string <-function(.length = 7){
  index <- sample(1:26, .length)
  paste(letters[index], collapse = "")
}

# get file extension
.file_ext <- function(x){
  pos <- regexpr("\\.([[:alnum:]]+)$", x)
  ifelse(pos > -1L, substring(x, pos + 1L), "")
}


# extract device name from file name
.device <- function (filename) {

  device <- .file_ext(filename)
  devices <- list(eps = grDevices::postscript, ps = grDevices::postscript,
                  pdf = grDevices::pdf,
                  svg = grDevices::svg,
                  png = grDevices::png,
                  jpg = grDevices::jpeg,
                  jpeg = grDevices::jpeg,
                  bmp = grDevices::bmp,
                  tiff = grDevices::tiff)

  dev <- devices[[device]]
  if (is.null(dev)) {
    stop("Unknown graphics device '", device, "'", call. = FALSE)
  }

  dev
}


# Grouping data by variables
#:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
.group_by <- function(data, grouping.vars){

  . <- NULL # used in pipes

  # Grouping the data ==> list of data sets
  grouped.d <- data %>%
    df_nest_by(vars = grouping.vars)

  # Defining names for the list of data sets.
  # names = combination of the levels of the grouping variables
  .names.df <- grouped.d[, grouping.vars, drop = FALSE]
  .names <- .paste_colnames(.names.df, sep = ":") %>%
    apply(1, paste, collapse = ", ")
  names(grouped.d$data) <- .names
  return(grouped.d)
}


# Pasting the column name to each value of a dataframe
#:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
.paste_colnames <- function(data, sep = "."){

  data <- as.data.frame(data)

  if(ncol(data) == 1){

    res <- paste0(colnames(data), ".", data[[1]])
    res <- data.frame(x = res, stringsAsFactors = FALSE)
    colnames(res) <- colnames(data)
    return(res)
  }

  res <- apply(data, 1,
               function(row, cname){paste(cname, row, sep = sep)},
               colnames(data)
  ) %>%
    t() %>%
    as.data.frame(stringsAsFactors = FALSE)
  colnames(res) <- colnames(data)
  res
}


# Setting seed with possibility to restore initial random state
#:::::::::::::::::::::::::::::::::::::::::::::::
# Ref: https://github.com/florianhartig/DHARMa/blob/master/DHARMa/R/random.R
# seed numeric value to be used for setting seed
# return a function named restore_random_state()
# for restoring intitial random state
#
# Examples:
# seed <- set_seed(123)
# Restore back initial state
# seed$restore_random_state()
 set_seed  <- function(seed){
    # Record current random state
    current  <- mget(".Random.seed", envir = .GlobalEnv, ifnotfound = list(NULL))[[1]]
    restore_random_state <- function(){
      if(is.null(current)) rm(".Random.seed", envir = .GlobalEnv)
      else assign(".Random.seed", current , envir = .GlobalEnv)
    }

    # Setting seed
    if(is.numeric(seed)) set.seed(seed)
    # ensuring that RNG has been initialized
    if (is.null(current)) stats::runif(1)

    # Returning function for restoring state
    invisible(list(restore_random_state = restore_random_state))
  }