utils.R

#' @importFrom grDevices col2rgb
#' @importFrom utils getFromNamespace modifyList data packageVersion browseURL
#' @importFrom stats setNames

is.plotly <- function(x) inherits(x, "plotly")

"%||%" <- function(x, y) {
  if (length(x) > 0) x else y
}

is.discrete <- function(x) {
  is.factor(x) || is.character(x) || is.logical(x)
}

# special enviroment that tracks trace/layout information
plotlyEnv <- new.env(parent = emptyenv())

# hash plot info, assign it to the special plotly environment, & attach it to data
hash_plot <- function(df, p) {
  if (missing(df) || is.null(df)) df <- data.frame()
  hash <- digest::digest(p)
  # terrible hack to ensure we can always find the most recent hash
  hash <- paste(hash, length(ls(plotlyEnv)), sep = "#")
  assign(hash, p, envir = plotlyEnv)
  attr(df, "plotly_hash") <- hash
  # add plotly class mainly for printing method
  class(df) <- unique(c("plotly", class(df)))
  # return a data frame to be compatible with things like dplyr
  df
}

#' Obtain underlying data of plotly object
#' 
#' Given a data frame with a class of plotly, this function returns the arguments
#' and/or data used to create the plotly. If no data frame is provided, 
#' the last plotly object created in this R session is returned (if it exists).
#' 
#' @param data a data frame with a class of plotly (and a plotly_hash attribute).
#' @param last if no plotly attribute is found, return the last plot or NULL?
get_plot <- function(data = NULL, last = FALSE) {
  hash <- attr(data, "plotly_hash")
  if (!is.null(hash)) {
    get(hash, envir = plotlyEnv)
  } else if (last) {
    envs <- strsplit(ls(plotlyEnv), "#")
    last_env <- ls(plotlyEnv)[which.max(sapply(envs, "[[", 2))]
    get(last_env, envir = plotlyEnv)
  } else {
    data %||% list()
  }
}

#' Retrive and create the last plotly (or ggplot).
#' 
#' @seealso \link{plotly_build}
#' @param data (optional) a data frame with a class of plotly (and a plotly_hash attribute).
#' @export
last_plot <- function(data = NULL) {
  p <- try(get_plot(data, last = TRUE), silent = TRUE)
  if (inherits(p, "try-error")) p <- try(ggplotly(), silent = TRUE)
  if (inherits(p, "try-error")) stop("The last plot doesn't exist")
  structure(
    p, 
    class = unique(c("plotly", class(p)))
  )
}

# Check for credentials/configuration and throw warnings where appropriate
verify <- function(what = "username", warn = TRUE) {
  val <- grab(what)
  if (val == "" && warn) {
    switch(what,
           username = warning("You need a plotly username. See help(signup, package = 'plotly')", call. = FALSE),
           api_key = warning("You need an api_key. See help(signup, package = 'plotly')", call. = FALSE))
    warning("Couldn't find ", what, call. = FALSE)
  }
  as.character(val)
}

# Check whether a certain credential/configuration exists.
grab <- function(what = "username") {
  who <- paste0("plotly_", what)
  val <- Sys.getenv(who, "")
  # If the environment variable doesn't exist, try reading hidden files that may
  # have been created using other languages or earlier versions of this package
  if (val == "") {
    PLOTLY_DIR <- file.path(normalizePath("~", mustWork = TRUE), ".plotly")
    CREDENTIALS_FILE <- file.path(PLOTLY_DIR, ".credentials")
    CONFIG_FILE <- file.path(PLOTLY_DIR, ".config")
    # note: try_file can be 'succesful', yet return NULL
    val2 <- try_file(CREDENTIALS_FILE, what)
    val <- if (length(nchar(val2)) == 0) try_file(CONFIG_FILE, what) else val2
    val <- val %||% ""
  }
  # return true if value is non-trivial
  setNames(val, who)
}

# try to grab an object key from a JSON file (returns empty string on error)
try_file <- function(f, what) {
  tryCatch(jsonlite::fromJSON(f)[[what]], error = function(e) NULL)
}

# preferred defaults for toJSON mapping
to_JSON <- function(x, ...) {
  jsonlite::toJSON(x, digits = 50, auto_unbox = TRUE, force = TRUE,
                   null = "null", na = "null", ...)
}

# preferred defaults for toJSON mapping
from_JSON <- function(x, ...) {
  jsonlite::fromJSON(x, simplifyDataFrame = FALSE, simplifyMatrix = FALSE, ...)
}

# plotlyjs properties that must _always_ be an array (even if length 1)
get_boxed <- function() {
  c("x", "y", "lat", "lon", "text")
}

add_boxed <- function(x) {
  for (i in seq_along(x$data)) {
    # some object keys require an array, even if length one
    # one way to ensure atomic vectors of length 1 are not automatically unboxed,
    # by to_JSON(), is to attach a class of AsIs (via I())
    d <- x$data[[i]]
    idx <- names(d) %in% get_boxed() & sapply(d, length) == 1
    if (any(idx)) x$data[[i]][idx] <- lapply(d[idx], I)
  }
  x
}

rm_asis <- function(x) {
  # jsonlite converts NULL to {} and NA to null (plotly prefers null to {})
  # https://github.com/jeroenooms/jsonlite/issues/29
  if (is.null(x)) return(NA)
  if (is.list(x)) lapply(x, rm_asis) 
  # strip any existing 'AsIs' list elements of their 'AsIs' status.
  # this is necessary since ggplot_build(qplot(1:10, fill = I("red"))) 
  # returns list element with their 'AsIs' class, 
  # which conflicts with our JSON unboxing strategy.
  else if (inherits(x, "AsIs")) class(x) <- setdiff(class(x), "AsIs")
  else x
}


# add a class to an object only if it is new, and keep any existing classes of 
# that object
struct <- function(x, y, ...) {
  structure(x, class = unique(c(class(x), y)), ...)
} 

# TODO: what are some other common configuration options we want to support??
get_domain <- function(type = "main") {
  if (type == "stream") {
    Sys.getenv("plotly_streaming_domain", "http://stream.plot.ly")
  } else if (type == "v2") {
    Sys.getenv("plotly_domain", "https://api.plot.ly/v2/")
  } else {
    Sys.getenv("plotly_domain", "https://plot.ly")
  }
}

# plotly's special keyword arguments in POST body
get_kwargs <- function() {
  c("filename", "fileopt", "style", "traces", "layout", "world_readable")
}

# POST header fields
#' @importFrom base64enc base64encode
plotly_headers <- function(type = "main") {
  usr <- verify("username")
  key <- verify("api_key")
  v <- as.character(packageVersion("plotly"))
  h <- if (type == "v2") {
    auth <- base64enc::base64encode(charToRaw(paste(usr, key, sep = ":")))
    c(
      "authorization" = paste("Basic", auth),
      "plotly-client-platform" = paste("R", v),
      "plotly_version" = v,
      "content-type" = "application/json"
    )
  } else {
    c(
      "plotly-username" = usr,
      "plotly-apikey" = key,
      "plotly-version" = v,
      "plotly-platform" = "R"
    )
  }
  httr::add_headers(.headers = h)
}


perform_eval <- function(x) {
  if (should_eval(x)) do_eval(x) else x
}

# env/enclos are special properties specific to the R API 
# if they appear _and_ are environments, then evaluate arguments
# (sometimes figures return these properties but evaluation doesn't make sense)
should_eval <- function(x) { 
  any(vapply(x[c("env", "enclos")], is.environment, logical(1))) 
}

# perform evaluation of arguments, keeping other list elements
do_eval <- function(x) {
  y <- c(x, eval(x$args, as.list(x$env, all.names = TRUE), x$enclos))
  y[c("args", "env", "enclos")] <- NULL
  y
}

# try to write environment variables to an .Rprofile
cat_profile <- function(key, value, path = "~") {
  r_profile <- file.path(normalizePath(path, mustWork = TRUE),
                         ".Rprofile")
  snippet <- sprintf('\nSys.setenv("plotly_%s" = "%s")', key, value)
  if (!file.exists(r_profile)) {
    message("Creating", r_profile)
    r_profile_con <- file(r_profile)
  }
  if (file.access(r_profile, 2) != 0) {
    stop("R doesn't have permission to write to this file: ", path, "\n",
         "You should consider putting this in an .Rprofile ", "\n",
         "(or sourcing it when you use plotly): ", snippet)
  }
  if (file.access(r_profile, 4) != 0) {
    stop("R doesn't have permission to read this file: ", path)
  }
  message("Adding plotly_", key, " environment variable to ", r_profile)
  cat(snippet, file = r_profile, append = TRUE)
}


# Needed since we can't control the order of conditional dependencies
plotly_dependencies <- function(p) {
  deps <- list(
    html_dependency_mathjax(p),
    html_dependency_geo(p),
    # TODO: build plotlyjs without d3/topojson and include separately?
    html_dependency_plotly()
  )
  # mathjax/geo dependencies may return NULL which can cause problems
  Filter(Negate(is.null), deps)
}

html_dependency_mathjax <- function(p) {
  if (isTRUE(p$config$mathjax == "local")) {
    path <- Sys.getenv("plotly_jsdir", unset = NA)
    if (is.na(path)) {
      stop("Local mathjax requires a local clone of the plotly.js repo \n",
           "https://github.com/plotly/plotly.js \n",
           "Once you have plotly.js locally, set the plotly_jsdir \n",
           "environment variable with the path to plotly.js")
    } else {
      mj <- file.path(path, "dist", "extras", "mathjax", "MathJax.js")
      if (!file.exists(mj)) stop("Couldn't locate MathJax.js")
      # parse the version
      mathjax <- readLines(mj)
      pat <- 'MathJax.fileversion="[0-9]+.[0-9]+.[0-9]+'
      ver <- regmatches(mathjax, regexpr(pat, mathjax))
      ver <- sub('"', '', strsplit(ver, "=")[[1]][2])
      dep <- htmltools::htmlDependency(
        name = "mathjax", 
        version = ver, 
        src = dirname(mj),
        script = c(basename(mj), "config/TeX-AMS-MML_SVG.js")
      )
      return(dep)
    }
  }
  if (isTRUE(p$config$mathjax == "cdn")) {
    dep <- htmltools::htmlDependency(
      name = "mathjax-cdn", 
      version = "1.0",
      src = system.file("htmlwidgets", "lib", "mathjax", package = "plotly"),
      script = "mathjax-cdn.js"
    )
    return(dep)
  }
  return(NULL)
}

html_dependency_geo <- function(p) {
  types <- unlist(lapply(p$data, "[[", "type"))
  # if there are any geo trace(s), add the geo assets dependency
  if (any(grepl("geo|choropleth", types))) {
    path <- Sys.getenv("plotly_jsdir", unset = NA)
    if (is.na(path)) {
      warning("Rendering 'geo' traces without an internet connection \n",
              "requires a local clone of the plotly.js repo \n",
              "https://github.com/plotly/plotly.js \n",
              "Once you have plotly.js locally, set the plotly_jsdir \n",
              "environment variable with the path to plotly.js")
      return(NULL)
    } else {
      geo <- file.path(path, "dist", "plotly-geo-assets.js")
      if (!file.exists(geo)) stop("Couldn't locate plotly-geo-assets.js")
      dep <- htmltools::htmlDependency(
        name = "plotly-geo-assets",
        src = dirname(geo),
        version = plotly_version(),
        script = basename(geo)
      )
    }
  }
}

html_dependency_plotly <- function() {
  htmltools::htmlDependency(
    name = "plotly.js",
    src = system.file("htmlwidgets", "lib", "plotlyjs", package = "plotly"),
    version = plotly_version(),
    script = "plotly-latest.min.js"
  )
}

plotly_version <- function() {
  pkg <- system.file("htmlwidgets", "lib", "plotlyjs", "package.json", package = "plotly")
  jsonlite::fromJSON(pkg)$version
}