rule_class <- function(x) {
structure(x, class = c("cli_rule", "rule", "cli_ansi_string", "ansi_string", "character"))
}
capture_msgs <- function(expr) {
msgs <- character()
i <- 0
suppressMessages(withCallingHandlers(
expr,
message = function(e) msgs[[i <<- i + 1]] <<- conditionMessage(e)))
paste0(msgs, collapse = "")
}
capture_cli_messages <- function(expr) {
msgs <- character()
withCallingHandlers(
expr,
cliMessage = function(e) {
msgs <<- c(msgs, conditionMessage(e))
invokeRestart("muffleMessage")
}
)
msgs
}
capt <- function(expr, print_it = TRUE) {
pr <- if (print_it) print else identity
paste(capture.output(pr(expr)), collapse = "\n")
}
capt0 <- function(expr, strip_style = FALSE) {
out <- capture_msgs(expr)
if (strip_style) ansi_strip(out) else out
}
local_cli_config <- function(unicode = FALSE, dynamic = FALSE,
ansi = FALSE, num_colors = 1,
.local_envir = parent.frame()) {
withr::local_options(
cli.dynamic = dynamic,
cli.ansi = ansi,
cli.unicode = unicode,
crayon.enabled = num_colors > 1,
crayon.colors = num_colors,
.local_envir = .local_envir
)
withr::local_envvar(
PKG_OMIT_TIMES = "true",
PKG_OMIT_SIZES = "true",
.local_envir = .local_envir
)
}
test_style <- function() {
list(
".testcli h1" = list(
"font-weight" = "bold",
"font-style" = "italic",
"margin-top" = 1,
"margin-bottom" = 1),
".testcli h2" = list(
"font-weight" = "bold",
"margin-top" = 1,
"margin-bottom" = 1),
".testcli h3" = list(
"text-decoration" = "underline",
"margin-top" = 1)
)
}
fix_times <- function(out) {
out <- sub("[(][ ]*[.0-9]+ [Mk]B/s[)]", "(8.5 MB/s)", out)
out <- sub("[(][.0-9]+/s[)]", "(100/s)", out)
out <- sub(" [.0-9]+(ms|s|m)", " 3ms", out)
out <- sub("ETA:[ ]*[.0-9]+m?s", "ETA: 1s", out)
out <- gsub("\\[[.0-9]+m?s\\]", "[1s]", out)
out
}
fix_logger_output <- function(lines) {
sub(
paste0(
"^[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]T",
"[0-9][0-9]:[0-9][0-9]:[0-9][0-9]\\+00:00 ",
"cli-[0-9]+-[0-9]+ "
),
"2021-06-18T00:09:14+00:00 cli-36434-1 ",
lines
)
}
make_c_function <- function(file = NULL,
code = NULL,
args = character(),
type = c(".c", ".cpp"),
header = NULL,
linkingto = packageName(),
quiet = Sys.getenv("TESTTHAT") == "true") {
type <- match.arg(type)
# Create source file
dir.create(dir <- tempfile())
if (is.null(file)) {
lines <- create_c_function_call(code, args, header = header)
} else {
lines <- readLines(file)
}
src <- basename(tempfile(fileext = type))
writeLines(lines, file.path(dir, src))
# Compile
cflags <- ""
for (pkg in linkingto) {
pkgdir <- file.path(find.package(pkg), "include")
lcldir <- file.path(find.package(pkg), "inst", "include")
cflags <- paste(cflags, "-I", pkgdir, "-I", lcldir)
}
env <- c(PKG_CFLAGS = cflags)
callr::rcmd(
"SHLIB",
src,
wd = file.path(dir),
env = env,
echo = !quiet,
show = !quiet
)
# Load DLL
dllfile <- file.path(dir, sub("[.]c(pp)?$", .Platform$dynlib.ext, src))
dll <- dyn.load(dllfile, local = TRUE, now = TRUE)
# TODO: finalizer to unload/delete
dll
}
create_c_function_call <- function(code, args, header = NULL) {
c(
"#include <Rinternals.h>",
header,
"SEXP tmp_c_function(",
if (length(args) > 0) paste0("SEXP ", args, collapse = ", "),
") {",
code,
"}\n"
)
}
win2unix <- function (str) {
gsub("\r\n", "\n", str, fixed = TRUE, useBytes = TRUE)
}
st_from_bel <- function(x) {
gsub("\007", "\033\\", x, fixed = TRUE)
}
st_to_bel <- function(x) {
gsub("\033\\", "\007", x, fixed = TRUE)
}
test_package_root <- function() {
x <- tryCatch(
rprojroot::find_package_root_file(),
error = function(e) NULL)
if (!is.null(x)) return(x)
pkg <- testthat::testing_package()
x <- tryCatch(
rprojroot::find_package_root_file(
path = file.path("..", "..", "00_pkg_src", pkg)),
error = function(e) NULL)
if (!is.null(x)) return(x)
stop("Cannot find package root")
}
sanitize_wd <- function(x) {
wd <- paste0("file://", getwd())
gsub(wd, "file:///testthat/home", x, fixed = TRUE)
}
sanitize_home <- function(x) {
home <- paste0("file://", path.expand("~"))
gsub(home, "file:///my/home", x, fixed = TRUE)
}
sanitize_srcref <- function(x) {
gsub(" at .*.R:[0-9]+:[0-9]+", "", x)
}
sanitize_call <- function(x) {
gsub(" in `.*`", "", x)
}
r_pty <- function(.envir = parent.frame()) {
skip_on_cran()
# TODO: why does this fail on the CI, in covr
if (Sys.getenv("R_COVR") == "true" &&
isTRUE(as.logical(Sys.getenv("CI")))) {
skip("fails on CI in covr")
}
if (!Sys.info()[["sysname"]] %in% c("Darwin", "Linux")) skip("Needs Linux or macOS")
r <- file.path(R.home("bin"), "R")
p <- processx::process$new(
r,
c("-q", "--slave", "--vanilla"),
pty = TRUE,
env = c("current", R_CLI_HIDE_CURSOR = "false", R_LIBS = .libPaths()[1])
)
defer({
close(p$get_input_connection())
p$wait(1000)
p$kill()
}, envir = .envir)
p$poll_io(1000)
p$read_output()
p
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.