R/strings.R

In dipsaus: A Dipping Sauce for Data Analysis and Visualizations

# String manupulation

#' Convert file to 'base64' format
#' @param file file path
#' @param mime 'mime' type, default is blank
#' @return a 'base64' data string looks like \code{'data:;base64,AEF6986...'}
#' @export
to_datauri <- function(file, mime = "") {
  info <- file.info(file)
  ss <- jsonlite::base64_enc(input = readBin(file, what = "raw", n = info$size))
  ss <- sprintf("data:%s;base64,%s", mime, ss)
  ss
}


#' Convert color to Hex string
#' @param col character or integer indicating color
#' @param alpha \code{NULL} or numeric, transparency. See \code{grDevices::rgb}
#' @param prefix character, default is \code{"#"}
#' @param ... passing to  \code{\link[grDevices]{adjustcolor}}
#' @return characters containing the hex value of each color. See details
#' @details \code{col2hexStr} converts colors such as 1, 2, 3, "red", "blue", ... into
#' hex strings that can be easily recognized by `HTML`, `CSS` and `JavaScript`.
#' Internally this function uses \code{\link[grDevices]{adjustcolor}} with two differences:
#' \enumerate{
#' \item the returned hex string does not contain alpha value if \code{alpha} is \code{NULL};
#' \item the leading prefix "#" can be customized
#' }
#' @seealso  \code{\link[grDevices]{adjustcolor}}
#' @examples
#'
#' col2hexStr(1, prefix = '0x')      # "0x000000"
#' col2hexStr('blue')                # "#0000FF"
#'
#' # Change default palette, see "grDevices::colors()"
#' grDevices::palette(c('orange3', 'skyblue1'))
#' col2hexStr(1)                     # Instead of #000000, #CD8500
#'
#' @export
col2hexStr <- function(col, alpha = NULL, prefix = "#", ...) {
  if (is.null(alpha)) {
    alpha <- 1
    transparent <- FALSE
  } else {
    transparent <- TRUE
  }
  re <- grDevices::adjustcolor(col, alpha.f = alpha)
  if (!transparent) {
    re <- str_sub(re, end = 7L)
  }
  str_replace(re, "^[^0-9A-F]*", prefix)
}


#' @title Parse Text Into Numeric Vectors
#'
#' @param text string with chunks, e.g. \code{"1-10, 14, 16-20, 18-30"} has 4 chunks
#' @param sep default is ",", character used to separate chunks
#' @param connect characters defining connection links for example "1:10" is the same as "1-10"
#' @param sort sort the result
#' @param unique extract unique elements
#' @return a numeric vector. For example, "1-3" returns \code{c(1, 2, 3)}
#' @seealso \code{\link[dipsaus]{deparse_svec}}
#' @examples
#' parse_svec('1-10, 13:15,14-20')
#' @export
parse_svec <- function(text, sep = ",", connect = "-:|", sort = FALSE, unique = TRUE) {
  connect <- unique(unlist(strsplit(connect, "")))
  connect[connect %in% c("|", ":", "~")] <- paste0("\\", connect[connect %in% c("|", ":", "~")])
  if ("-" %in% connect) {
    connect <- c(connect[connect != "-"], "-")
  }
  connect <- paste(connect, collapse = "")

  if (length(text) != 1) {
    text <- paste(text, collapse = sep)
  }


  if (length(text) == 0 || !nzchar(trimws(text))) {
    return(NULL)
  }

  if (is.numeric(text)) {
    if (unique) {
      text <- unique(text)
    }
    if (sort) {
      text <- sort(text)
    }
    return(text)
  }
  s <- unlist(strsplit(text, sep, perl = TRUE))
  s <- trimws(s)
  s <- s[s != ""]

  s <- s[grepl(sprintf("^[0-9\\ %s]+$", connect), s)]
  # s <- s[str_detect(s, sprintf("^[0-9\\ %s]+$", connect))]

  re <- NULL
  for (ss in s) {
    if (grepl(sprintf("[%s]", connect), ss)) {
      ss <- unlist(strsplit(ss,  sprintf("[%s]", connect), perl = TRUE))
      # ss <- as.vector(stringr::str_split(ss, sprintf("[%s]", connect), simplify = TRUE))
      ss <- trimws(ss)
      ss <- ss[grepl("^[0-9]+$", ss)]
      ss <- as.numeric(ss)
      ss <- ss[!is.na(ss)]
      if (length(ss) >= 2) {
        re <- c(re, (ss[1]:ss[2]))
      }
    } else {
      re <- c(re, as.numeric(ss))
    }
  }

  if (unique) {
    re <- unique(re)
  }

  if (sort) {
    re <- sort(re)
  }

  return(re)
}

#' @title Convert Integer Vectors To String
#'
#' @param nums integer vector
#' @param connect character used to connect consecutive numbers
#' @param concatenate connect strings if there are multiples
#' @param collapse if concatenate, character used to connect strings
#' @param max_lag defines "consecutive", min = 1
#' @return strings representing the input vector. For example, \code{c(1, 2, 3)} returns "1-3".
#' @seealso \code{\link[dipsaus]{parse_svec}}
#' @examples
#' deparse_svec(c(1:10, 15:18))
#' @export
deparse_svec <- function(nums, connect = "-", concatenate = TRUE, collapse = ",", max_lag = 1) {
  nums <- nums[is.finite(nums)]
  if (length(nums) == 0) {
    return("")
  }
  alag <- seq_len(max(1, max_lag))
  nums <- sort(unique(nums))
  lg <- c(NA, nums)[seq_along(nums)]
  ind <- nums - lg
  ind[1] <- 0
  ind2 <- c(ind[-1], -1)
  re <- apply(cbind(nums[!ind %in% alag], nums[!ind2 %in% alag]), 1, function(x) {
    if (x[1] == x[2]) {
      as.character(x[1])
    } else {
      paste(x, collapse = connect)
    }
  })
  if (concatenate) {
    re <- paste(re, collapse = collapse)
  }
  re
}




#' @title Color Output
#' @param ... to be printed
#' @param level 'DEBUG', 'INFO', 'WARNING', 'ERROR', or 'FATAL' (total 5 levels)
#' @param print_level if true, prepend levels before messages
#' @param file,sep,fill,labels,append pass to \code{base::cat}
#' @param pal a named list defining colors see details
#' @param end character to append to the string
#' @param use_cli logical, whether to use package 'cli'
#' @param bullet character, if use 'cli', which symbol to show. see
#' \code{\link[cli]{symbol}}
#'
#' @return none.
#'
#' @details
#' There are five levels of colors by default: 'DEBUG', 'INFO', 'WARNING', 'ERROR',
#' or FATAL. Default colors are: 'DEBUG' (\code{grey60}), 'INFO' (\code{#1d9f34}), 'WARNING'
#' (\code{#ec942c}), 'ERROR' (\code{#f02c2c}), 'FATAL' (\code{#763053}) and
#' 'DEFAULT' (\code{#000000}, black). If level is not in preset five levels,
#' the color will be "default"-black color.
#' @export
cat2 <- function(
  ..., level = "DEBUG", print_level = FALSE,
  file = "", sep = " ", fill = FALSE, labels = NULL,
  append = FALSE, end = "\n", pal = list(
    "DEBUG" = "grey60",
    "INFO" = "#1d9f34",
    "WARNING" = "#ec942c",
    "ERROR" = "#f02c2c",
    "FATAL" = "#763053",
    "DEFAULT" = "grey60"
  ), use_cli = TRUE, bullet = "auto"
) {
  if (!level %in% names(pal)) {
    level <- "DEFAULT"
  }
  bullet_list <- list(
    "DEBUG" = "tick",
    "INFO" = "heart",
    "WARNING" = "warning",
    "ERROR" = "cross",
    "FATAL" = "cross",
    "DEFAULT" = "arrow_right"
  )

  .col <- pal[[level]]
  if (is.null(.col)) { .col <- "#000000" }
  if ( bullet == "auto" ) {
    bullet <- bullet_list[[level]]
    if (is.null(bullet)) { bullet <- "arrow_right" }
  }

  # check if interactive
  if (interactive()) {

    if ( use_cli ) {

      cli::cat_bullet(..., col = .col, bullet = bullet)
    } else {
      # use colored console
      col <- cli::make_ansi_style(.col)
      if (print_level) {
        base::cat("[", level, "]: ", sep = "")
      }
      base::cat(col(..., sep = sep), end = end, file = file, fill = fill,
                labels = labels, append = append)
    }

    # Update: not print anything
  } else {
    # Whether running in the future session
    base::cat(..., end)
  }

  if (level == "FATAL") {
    # stop!
    err <- simpleError(paste(..., collapse = "", sep = ""), call = NULL)
    trace <- rlang::trace_back()
    trace <- as.list(utils::capture.output(print(trace)))
    if (length(trace) > 1) {
      trace <- c("Full call trees:", trace)
      err$trace <- trace
      class(err) <- c("dipsausError", "simpleError", "error", "condition")
    }

    # logger(sprintf("[FATAL] %s", utils::capture.output(traceback(trace))), flush = TRUE)

    stop(err)
  # } else {
  #   logger(sprintf("%s %s", level, paste(..., collapse = "", sep = "")), flush = FALSE)
  }

  invisible()
}



#' Convert bytes to KB, MB, GB,...
#'
#' @param s size
#' @param kb_to_b how many bytes counts one KB, 1000 by default
#' @return numeric equaling to \code{s} but formatted
#' @export
to_ram_size <- function(s, kb_to_b = 1000) {
  base <- floor(log(max(abs(s), 1), kb_to_b))
  s <- s / (kb_to_b ^ (base))
  if (is.na(base)) {
    base <- 0
  }
  attr(s, "unit") <- c("B", "KB", "MB", "GB", "TB", "PB", "EB", "ZB", "YB")[base + 1]
  class(s) <- c("dipsaus_bytes", class(s))
  s
}


#' @export
as.character.dipsaus_bytes <- function(x, digit = 1, ...) {
  sprintf(sprintf("%%.%df %s", digit, attr(x, "unit")), x)
}

#' @export
print.dipsaus_bytes <- function(x, digit = 1, ...) {
  re <- as.character(x, digit = digit, ...)
  cat(re)
  invisible(re)
}

#' Get max RAM size
#' This is an experimental function that is designed for non-windows systems
#' @return a list of total free memory.
#' @export
mem_limit2 <- function() {

  total <- get_ram()


  bytes <- 8 * .Machine$sizeof.pointer
  bytes <- bytes - (bytes > 32) * 4 - 4
  free <- sum(gc()[, 1] * c(bytes, 8))

  list(
    total = total,
    free = total - free
  )


}


#' @title Ask and Return True or False from the Terminal
#' @description Ask a question and read from the terminal in interactive scenario
#' @param ...,end,level passed to \code{\link[dipsaus]{cat2}}
#' @param error_if_canceled raise error if canceled
#' @param use_rs whether to use \code{rstudioapi} if possible
#' @param ok button label for yes
#' @param cancel button label for no
#' @param rs_title message title if 'RStudio' question box pops up.
#' @seealso \code{\link[dipsaus]{cat2}}, \code{\link[base]{readline}},
#' \code{\link[dipsaus]{ask_or_default}}
#'
#' @details The prompt string will ask for an yes or no question. Users need to
#' enter "y", "yes" for yes, "n", "no" or no, and "c" for cancel
#' (case-insensitive).
#'
#' This can only be used in an \code{\link{interactive}} session.
#'
#' @return logical or \code{NULL} or raise an error. If "yes" is entered,
#' returns \code{TRUE}; if "no" is entered, returns \code{FALSE}; if "c" is
#' entered, \code{error_if_canceled=TRUE} will result in an error, otherwise
#' return \code{NULL}
#'
#' @examples
#' if(interactive()) {
#' ask_yesno('Do you know how hard it is to submit an R package and ',
#'           'pass the CRAN checks?')
#' ask_yesno('Can I pass the CRAN check this time?')
#' }
#' @export
ask_yesno <- function(..., end = "", level = "INFO", error_if_canceled = TRUE,
                      use_rs = TRUE, ok = "Yes", cancel = "No",
                      rs_title = "Yes or No:") {

  if (use_rs && rs_avail()) {
    s <- paste(..., sep = "\n")
    res <- rstudioapi::showQuestion(rs_title, s, ok = ok, cancel = cancel)
    return(isTRUE(res))
  } else {
    cat2(..., " (Yes/no): ", end = end, level = level)
    answer <- readline()
    answer <- trimws(toupper(answer))
    if ( answer %in% c("Y", "YES") ) { return(TRUE) }
    if ( answer %in% c("N", "NO") ) { return(FALSE) }
    if ( answer %in% c("C") ) {
      if ( error_if_canceled ) {
        cat2("Canceled.", level = "FATAL")
      } else {
        return(NULL)
      }
    }
    Recall("Please answer Y/yes, N/no, or c to cancel.", end = "", level = "WARNING", error_if_canceled = error_if_canceled)
  }


}


#' @title Read a Line from the Terminal, but with Default Values
#' @description Ask a question and read from the terminal in interactive scenario
#' @param ...,end,level passed to \code{\link[dipsaus]{cat2}}
#' @param default default value to return in case of blank input
#' @seealso \code{\link[dipsaus]{cat2}}, \code{\link[base]{readline}},
#' \code{\link[dipsaus]{ask_yesno}}
#'
#' @details The prompt string will ask a question, providing defaults. Users
#' need to enter the answer. If the answer is blank (no space), then returns the
#' default, otherwise returns the user input.
#'
#' This can only be used in an \code{\link{interactive}} session.
#'
#' @return A character from the user's input, or the default value. See details.
#'
#' @examples
#' if(interactive()) {
#' ask_or_default('What is the best programming language?',
#'                default = 'PHP')
#' }
#' @export
ask_or_default <- function(..., default = "", end = "", level = "INFO") {

  if (rs_avail()) {
    answer <- rstudioapi::showPrompt("Question", paste(..., sep = "\n"), default = default)
    if (!length(answer) || answer == "") {
      answer <- default
    }
  } else {
    cat2(..., sprintf("\n  [default is %s] ", sQuote(default)),
         end = end, level = level)
    answer <- trimws(readline())
    if ( answer == "" ) {
      answer <- default
    }
  }
  answer

}




#' Print Directory Tree
#' @param target target directory path, relative to \code{root}
#' @param root root directory, default is \code{'~'}
#' @param child child files in target; is missing, then list all files
#' @param dir_only whether to display directory children only
#' @param collapse whether to concatenate results as one single string
#' @param ... pass to \code{\link[base]{list.files}} when list all files
#' @return Characters, print-friendly directory tree.
#' @export
print_directory_tree <- function(target, root = "~", child, dir_only = FALSE,
                                 collapse = NULL, ...) {
  root <- normalizePath(root, winslash = "/", mustWork = FALSE)
  target <- file.path(root, target)
  target <- str_replace_all(target, "\\\\", "/")
  target <- normalizePath(target, mustWork = FALSE, winslash = "/")

  paths <- stringr::str_split(target, "\\\\|/", simplify = TRUE)
  rpath <- stringr::str_split(root, "\\\\|/", simplify = TRUE)

  tree_id <- cbind(paste(rpath, collapse = "/"), paths[, -seq_along(rpath)])

  df <- list("..." = character(0))

  for (i in seq_len(nrow(tree_id))) {

    if (i == 1) {
      if ( missing(child) ) {
        # child is only for the first target
        dir <- target[[i]]
        if ( dir.exists(dir) ) {
          child <- list.dirs(dir, full.names = FALSE, recursive = FALSE)
          if (!dir_only) {
            child <- c(child, list.files(dir, full.names = FALSE, include.dirs = FALSE, ...))
          }
          df[child] <- lapply(child, function(o) { character(0) })
        } else {
          child <- "..."
        }
      } else if (!length(child)) {
        child <- character(0)
      } else {
        df[child] <- lapply(child, function(o) { character(0) })
      }
    } else {
      child <- "..."
    }

    x <- c(as.list(tree_id[i, ]), list(child), list(""))
    Reduce(function(a, b) {
      if (length(a) == 1 && a != "") {
        df[[a]] <<- c(df[[a]], b)
      }
      b
    }, x)
  }

  res <- cli::tree(data.frame(names(df), I(unname(lapply(df, function(x) {
    x <- x[x != ""]
    if (!length(x)) {
      x <- character(0)
    } else {
      x <- unique(x)
    }
    x
  })))), root = root)
  if (length(collapse) == 1) {
    res <- paste(res, collapse = collapse)
  }
  res
}

#' Captures Evaluation Output of Expressions as One Single String
#' @description Evaluate expression and captures output as characters, then
#' concatenate as one single string.
#' @param expr R expression
#' @param collapse character to concatenate outputs
#' @param type,... passed to \code{\link[utils]{capture.output}}
#' @return Character of length 1: output captured by
#' \code{\link[utils]{capture.output}}
#'
#' @examples
#'
#' x <- data.frame(a=1:10)
#' x_str <- capture_expr({
#'   print(x)
#' })
#'
#' x_str
#'
#' cat(x_str)
#'
#'
#' @export
capture_expr <- function(expr, collapse = "\n",
                         type = c("output", "message"), ...) {
  invisible(paste(utils::capture.output(expr, type = type, ...),
                  collapse = collapse))
}