tests/testthat/helper-callr.r

In klmr/box: Write Reusable, Composable and Modular R Code

# FIXME: Make the following more robust, and make it work on Windows.
# This would probably require something like `withr::local_envvar`, deferred to
# the caller, which is incredibly tedious to reimplement (requires native code).

r_cmdline = function (cmd, ...) {
    skip_on_os('windows')
    # Some of the script tests fail on CRAN and, lacking stack traces, it’s
    # simply impossible to debug this. So we disable them.
    skip_on_cran()

    rprofile = normalizePath(test_path('support/rprofile.r'))
    args = c('--no-save', '--no-restore', ...)
    # Unset `TESTTHAT` since otherwise ‘box’ thinks that tests are being run
    # from inside ‘testthat’, and fudges the local search path.
    sprintf(
        'TESTTHAT= R_ORIGINAL_PROFILE_USER="$R_PROFILE_USER" R_PROFILE_USER=%s %s %s',
        shQuote(rprofile),
        shQuote(file.path(R.home('bin'), cmd)),
        paste(shQuote(args), collapse = ' ')
    )
}

rcmd = function (script_path) {
    output_file = tempfile(fileext = '.rout')
    on.exit(unlink(output_file))
    cmd = r_cmdline(
        'R', 'CMD', 'BATCH',
        '--slave',
        '--no-timing',
        script_path,
        output_file
    )
    system(cmd)
    readLines(output_file)
}

rscript = function (script_path, wd = NULL) {
    cmd = r_cmdline('Rscript', '--slave', script_path)
    if (! is.null(wd)) {
        old_wd = setwd(wd)
        on.exit(setwd(old_wd))
    }
    p = pipe(cmd)
    on.exit(close(p), add = TRUE)
    readLines(p)
}

interactive_r = function (script_path, text, code) {
    cmd = r_cmdline('R', '--interactive')
    output_file = tempfile(fileext = '.rout')
    on.exit(unlink(output_file))

    text = if (! missing(script_path)) {
        readLines(script_path)
    } else if (! missing(code)) {
        deparse(substitute(code), backtick = TRUE)
    } else if (! missing(text)) {
        text
    } else {
        stop('Missing argument')
    }

    local({
        p = pipe(paste(cmd, '>', output_file), 'w')
        on.exit(close(p))
        writeLines(text, p)
        writeLines('interactive()', p)
    })

    result = readLines(output_file)

    strip_ansi_escapes = function (str) {
        # Only support CSI Select Graphic Rendition for now. This is necessary
        # to guard against R packages such as ‹colorout›.
        gsub('\033\\[(\\d+(;\\d+)*)?m', '', str)
    }

    check_line = function (which, expected) {
        # Separate check to generate only one assertion, and only if needed.
        if (! identical(strip_ansi_escapes(result[which]), expected)) {
            expect_identical(
                strip_ansi_escapes(result[which]), expected,
                label = sprintf('"%s"', result[which]),
                info = 'interactive_r'
            )
        }
    }

    # Ensure that code was actually run interactively.
    end = length(result)
    check_line(end - 2L, '> interactive()')
    check_line(end - 1L, '[1] TRUE')
    check_line(end, '> ')
    result[1 : (end - 3L)]
}

local({
    in_tests = grepl('tests/testthat$', getwd())
    basedir = if (in_tests) dirname(dirname((getwd()))) else getwd()
    Sys.setenv(BOX_TESTING_BASEDIR = basedir)
})