R/utils.R

In dipsaus: A Dipping Sauce for Data Analysis and Visualizations

safe_urlencode <- function(x) {
  re <- base64_urlencode(as.character(x))
  paste0("==", re)
}
safe_urldecode <- function(x) {
  x <- str_replace(as.character(x), pattern = "^==", "")
  base64_urldecode(x)
}


stopifnot2 <- function(..., msg = "Condition not satisfied") {
  if (!all(c(...))) {
    cat2(msg, level = "FATAL")
  }
}

# Unclassified utility functions

#' Calculate time difference and return a number
#' @param t1 time start
#' @param t2 time end
#' @param units character, choices are \code{'secs'}, \code{'mins'}, \code{'hours'}, and \code{'days'}
#' @return numeric difference of time in units specified
#' @examples
#' a = Sys.time()
#' Sys.sleep(0.3)
#' b = Sys.time()
#'
#' time_delta(a, b) # In seconds, around 0.3
#' time_delta(a, b, 'mins') # in minutes, around 0.005
#'
#' @export
time_delta <- function(t1, t2, units = "secs") {
  as.numeric(t2 - t1, units = units)
}

is_invalid <- function(x, any = FALSE, .invalids = list("is.null", "is.na"), ...) {
  .invalids <- c(.invalids, list(...))
  if ("is.null" %in% .invalids) {
    if (is.null(x) || !length(x)) {
      return(TRUE)
    }
  }
  for ( func in .invalids ) {
    res <- do.call(func, args = list(x))
    if (length(res) > 1) {
      if (any) {
        res <- any(res)
      } else {
        res <- all(res)
      }
    }
    if (res) {
      return(TRUE)
    }
  }

  return(FALSE)
}


#' Drop \code{NULL} values from list or vectors
#'
#' @param x list to check
#' @param .invalids a list of functions, or function name. Default is 'is.null'.
#'
#' @return list or vector containing no invalid values
#' @examples
#'
#' x <- list(NULL,NULL,1,2)
#' drop_nulls(x)  # length of 2
#'
#' @export
drop_nulls <- function(x, .invalids = list("is.null")) {
  x[!vapply(x, is_invalid, FUN.VALUE = logical(1), .invalids = .invalids)]
}


#' Function to clear all elements within environment
#'
#' @param env environment to clean, can be an R environment, or a
#' \code{\link{fastmap2}} instance
#' @param ... ignored
#'
#' @return \code{env} with variables removed
#'
#' @examples
#'
#' env = new.env()
#' env$a = 1
#' print(as.list(env))
#'
#' clear_env(env)
#' print(as.list(env))
#'
#' @export
clear_env <- function(env, ...) {
  if (is.environment(env)) {
    if (environmentIsLocked(env)) {
      warning("Environment is locked, cannot clear environment")
      return(invisible(env))
    }
    nms <- names(env)
    nms <- nms[!str_detect(nms, "^\\.__rave")]
    if (isNamespace(env)) {
      nms <- nms[!nms %in% c(".__NAMESPACE__.", ".__S3MethodsTable__.")]
    }
    rm(list = nms, envir = env)
  } else if (inherits(env, "fastmap2")) {
    .subset2(env, "remove")(names(env))
  } else if (inherits(env, "fastmap")) {
    .subset2(env, "remove")(names(env))
  } else {
    stop("env can only be environment or fastmap2 instances")
  }
  return(invisible(env))
}

#' A dummy function that literally does nothing
#' @param ... ignored
#' @return Nothing
#' @export
do_nothing <- function(...) {

}





SEXP_TYPES <- list(
  "0" =  c("NILSXP",     "0 NILSXP      NULL"),
  "1" =  c("SYMSXP",     "1 SYMSXP      symbols"),
  "2" =  c("LISTSXP",    "2 LISTSXP     pairlists"),
  "3" =  c("CLOSXP",     "3 CLOSXP      closures"),
  "4" =  c("ENVSXP",     "4 ENVSXP      environments"),
  "5" =  c("PROMSXP",    "5 PROMSXP     promises"),
  "6" =  c("LANGSXP",    "6 LANGSXP     language objects"),
  "7" =  c("SPECIALSXP", "7 SPECIALSXP  special functions"),
  "8" =  c("BUILTINSXP", "8 BUILTINSXP  builtin functions"),
  "9" =  c("CHARSXP",    "9 CHARSXP     internal character strings"),
  "10" = c("LGLSXP",     "10 LGLSXP     logical vectors"),
  "13" = c("INTSXP",     "13 INTSXP     integer vectors"),
  "14" = c("REALSXP",    "14 REALSXP    numeric vectors"),
  "15" = c("CPLXSXP",    "15 CPLXSXP    complex vectors"),
  "16" = c("STRSXP",     "16 STRSXP     character vectors"),
  "17" = c("DOTSXP",     "17 DOTSXP     dot-dot-dot object"),
  "18" = c("ANYSXP",     "18 ANYSXP     make \"any\" args work"),
  "19" = c("VECSXP",     "19 VECSXP     list (generic vector)"),
  "20" = c("EXPRSXP",    "20 EXPRSXP    expression vector"),
  "21" = c("BCODESXP",   "21 BCODESXP   byte code"),
  "22" = c("EXTPTRSXP",  "22 EXTPTRSXP  external pointer"),
  "23" = c("WEAKREFSXP", "23 WEAKREFSXP weak reference"),
  "24" = c("RAWSXP",     "24 RAWSXP     raw vector"),
  "25" = c("S4SXP",      "25 S4SXP      S4 classes not of simple type")
)

#' @title Get Internal Storage Type
#' @description Get internal (\code{C}) data types; See
#' \url{https://cran.r-project.org/doc/manuals/r-release/R-ints.pdf} Page 1
#' for more different \code{SEXPTYPE}s.
#' @param x any \pkg{R} object
#' @param ... ignored
#' @return An integer of class \code{"sexp_type2"}
#' @seealso \code{\link{storage.mode}}
#'
#' @examples
#'
#' # 1 vs 1L
#'
#' # Integer case
#' sexp_type2(1L)
#'
#' # double
#' sexp_type2(1)
#'
#' # Built-in function
#' sexp_type2(`+`)
#'
#' # normal functions
#' sexp_type2(sexp_type2)
#'
#' # symbols (quoted names)
#' sexp_type2(quote(`+`))
#'
#' # Calls (quoted expressions)
#' sexp_type2(quote({`+`}))
#'
#'
#' @export
sexp_type2 <- function(x) {
  re <- get_sexp_type(x)
  class(re) <- "sexp_type2"
  re
}

#' @rdname sexp_type2
#' @export
as.character.sexp_type2 <- function(x, ...) {
  x <- unclass(x)
  x <- SEXP_TYPES[[as.character(x)]]
  if (is.null(x)) {
    return("Unknown")
  }
  x[[1]]
}

#' @rdname sexp_type2
#' @export
print.sexp_type2 <- function(x, ...) {
  y <- unclass(x)
  y <- SEXP_TYPES[[as.character(y)]]
  if (is.null(y)) {
    return(sprintf("%d Unknown type", x))
  }
  cat(y[[2]], "\n")
  invisible(x)
}