R/utils.R

In shinytest2: Testing for Shiny Applications

# testthat on_cran
on_cran <- function() {
  !identical(Sys.getenv("NOT_CRAN"), "true")
}

# nolint start
ckm8_assert_single_string <- function(x, .var.name = checkmate::vname(x)) {
  checkmate::assert_character(
    x,
    len = 1,
    any.missing = FALSE,
    .var.name = .var.name,
    null.ok = FALSE
  )
}
ckm8_assert_single_integer <- function(
  x,
  ...,
  len = 1,
  any.missing = FALSE,
  .var.name = checkmate::vname(x)
) {
  checkmate::assert_integer(
    x,
    len = len,
    any.missing = any.missing,
    .var.name = .var.name,
    ...
  )
}
ckm8_assert_single_number <- function(x, ..., .var.name = checkmate::vname(x)) {
  checkmate::assert_number(x, .var.name = .var.name, ...)
}
ckm8_assert_app_driver <- function(
  self,
  private,
  self.var.name = checkmate::vname(self),
  private.var.name = checkmate::vname(private)
) {
  checkmate::assert_r6(self, "AppDriver", .var.name = self.var.name)
  checkmate::assert_environment(private, .var.name = private.var.name)
}
# nolint end

# Cache a value given output of `fn`
cache_fn_val <- function(fn) {
  val <- NULL
  function() {
    if (!is.null(val)) {
      return(val)
    }

    val <<- fn()
    val
  }
}

on_ci <- function() {
  isTRUE(as.logical(Sys.getenv("CI")))
}

raw_to_utf8 <- function(data) {
  res <- rawToChar(data)
  Encoding(res) <- "UTF-8"
  res
}

read_raw <- function(file) {
  readBin(file, "raw", n = file.info(file)$size)
}

read_utf8 <- function(file) {
  res <- read_raw(file)
  raw_to_utf8(res)
}

# write text as UTF-8
write_utf8 <- function(text, ...) {
  writeBin(charToRaw(enc2utf8(text)), ...)
}


# nolint start
# https://github.com/rstudio/shiny/blob/2360bde13efac1fe501efee447a8f3dde0136722/R/shiny.R#L35-L49
toJSON <- function(
  x,
  ...,
  dataframe = "columns",
  null = "null",
  na = "null",
  auto_unbox = TRUE,
  digits = getOption("shiny.json.digits", 16),
  use_signif = TRUE,
  force = TRUE,
  POSIXt = "ISO8601",
  UTC = TRUE,
  rownames = FALSE,
  keep_vec_names = TRUE,
  strict_atomic = TRUE
) {
  if (strict_atomic) {
    x <- I(x)
  }

  # I(x) is so that length-1 atomic vectors get put in [].
  jsonlite::toJSON(
    x,
    dataframe = dataframe,
    null = null,
    na = na,
    auto_unbox = auto_unbox,
    digits = digits,
    use_signif = use_signif,
    force = force,
    POSIXt = POSIXt,
    UTC = UTC,
    rownames = rownames,
    keep_vec_names = keep_vec_names,
    json_verbatim = TRUE,
    ...
  )
}
toJSON_atomic <- function(x, ...) {
  toJSON(x, ..., strict_atomic = FALSE)
}
# nolint end

# For PhantomJS on Windows, the pHYs (Physical pixel dimensions) header enbeds
# the computer screen's actual resolution, even though the screenshots are
# done on a headless browser, and the actual screen resolution has no effect
# on the pixel-for-pixel content of the screenshot.
#
# The header can differ when expected results are generated on one computer
# and compared to results from another computer, and this causes shinytest to
# report false positives in changes to screenshots. In order to avoid this
# problem, this function rewrites the pHYs header to always report a 72 ppi
# resolution.
#
# https://github.com/ariya/phantomjs/issues/10659#issuecomment-14993827
normalize_png_res_header <- function(self, private, file) {
  data <- readBin(file, raw(), n = 512)
  header_offset <- grepRaw("pHYs", data)

  if (length(header_offset) == 0) {
    # app_warn(self, private, paste0("Cannot find pHYs header in ", fs::path_file(file)))
    return(FALSE)
  }

  # Replace with header specifying 2835 pixels per meter (equivalent to 72
  # ppi).
  con <- file(file, open = "r+b")
  seek(con, header_offset - 1, rw = "write")
  writeBin(png_res_header_data, con)
  close(con)

  return(TRUE)
}

png_res_header_data <- as.raw(c(
  0x70,
  0x48,
  0x59,
  0x73, # "pHYs"
  0x00,
  0x00,
  0x0b,
  0x13, # Pixels per unit, X: 2835
  0x00,
  0x00,
  0x0b,
  0x13, # Pixels per unit, Y: 2835
  0x01, # Unit specifier: meters
  0x00,
  0x9a,
  0x9c,
  0x18 # Checksum
))

app_inform_where <- function(self, private, message) {
  ckm8_assert_app_driver(self, private)

  bt <- rlang::trace_back(bottom = parent.frame())
  bt_string <- paste0(format(bt), collapse = "\n")

  app_inform(self, private, paste0(message, "\n", bt_string))
}


# Sort items using the C locale, which is used with `method = "radix"`
sort_c <- function(x) {
  if (length(x)) {
    sort(x, method = "radix")
  } else {
    x
  }
}

st2_temp_file <- function(fileext = "", pattern = "") {
  tempfile(pattern = paste0("st2-", pattern), fileext = fileext)
}


is_false <- function(x) {
  is.logical(x) && length(x) == 1L && !is.na(x) && !x
}


# If `lines` does not exist in `path` file, also add `comments` before `lines` into `path` file
write_union <- function(path, lines, comments = NULL, quiet = FALSE) {
  stopifnot(is.character(lines))

  path <- fs::path_expand(path)
  if (fs::file_exists(path)) {
    existing_lines <- strsplit(read_utf8(path), "\n")[[1]]
  } else {
    existing_lines <- character()
  }
  new <- setdiff(lines, existing_lines)
  if (length(new) == 0) {
    return(invisible(FALSE))
  }
  if (!quiet) {
    # Try to not depend on usethis if possible
    if (rlang::is_installed("usethis")) {
      usethis::ui_done(
        "Adding {usethis::ui_value(new)} to {usethis::ui_path(path)}"
      )
    } else {
      rlang::inform(c(
        "*" = paste0(
          "Adding ",
          new,
          " to ",
          path
        )
      ))
    }
  }
  all_txt <- paste0(c(existing_lines, comments, new), collapse = "\n")
  if (!grepl("\n$", all_txt)) {
    all_txt <- paste0(all_txt, "\n")
  }
  write_utf8(all_txt, path)

  return(invisible(TRUE))
}