rmarkdown render NSE function fails only inside callr - r

I seem to have a weird combination of NSE, rmarkdown and callr, similar in flavor to Is it possible to disable `callr` for RMarkdown?.
When I set a value to a variable to use it in something similar to a filter call implemented using NSE via nested evals and list calls, it fails horribly, but only in callr.
---
title: "Test CC2 Failure Reproducibly"
author: "Robert M Flight"
output: rmarkdown::md_document
editor_options:
chunk_output_type: console
---
```{r run_enrichments}
set.seed(1234)
create_go_annotation = function(db, ontology = NULL){
all_genes = keys(db)
go_all_gene = AnnotationDbi::select(db, keys = all_genes, columns = c("GOALL", "ONTOLOGYALL"))
if (!is.null(ontology)) {
go_all_gene = go_all_gene[go_all_gene$ONTOLOGYALL == ontology, ]
ontology_type = paste0("GO.", ontology)
} else {
ontology_type = "GO.all"
}
go_2_gene = split(go_all_gene$ENTREZID, go_all_gene$GOALL)
go_2_gene = lapply(go_2_gene, unique)
go_desc = AnnotationDbi::select(GO.db::GO.db, keys = names(go_2_gene), columns = "TERM", keytype = "GOID")$TERM
names(go_desc) = names(go_2_gene)
go_annotation = categoryCompare2::annotation(annotation_features = go_2_gene,
description = go_desc,
annotation_type = ontology_type,
feature_type = "ENTREZID")
go_annotation
}
library(org.Hs.eg.db)
library(GO.db)
library(categoryCompare2)
library(methods)
go_mf = create_go_annotation(org.Hs.eg.db, "MF")
all_features = unique(unlist(go_mf#annotation_features))
sig_features = sample(all_features, 500)
enrich = hypergeometric_feature_enrichment(
new("hypergeom_features", significant = sig_features,
universe = all_features,
annotation = go_mf),
p_adjust = "BH"
)
comb_enrich = combine_enrichments(sig1 = enrich)
sig_cutoff = 0.1
filter_enrich = get_significant_annotations(comb_enrich, padjust <= sig_cutoff)
```
Run it via callr:
r(function() rmarkdown::render(here::here("categoryCompare2_failure.Rmd"), output_file = "cc2_fails_1.md"), show = TRUE)
# Quitting from lines 13-57 (categoryCompare2_failure.Rmd)
#
# Error in FUN(X[[i]], ...) : object 'sig_cutoff' not found
# Error: callr subprocess failed: object 'sig_cutoff' not found
# > .Last.error.trace
# Stack trace:
# Process 221313:
# 1. callr:::r(function() rmarkdown::render(here::he ...
# 2. callr:::get_result(output = out, options)
# 3. throw(newerr, parent = remerr[[2]])
# x callr subprocess failed: object 'sig_cutoff' not found
# Process 221619:
# 15. (function () ...
# 16. rmarkdown::render(here::here("categoryCompare2_failure.Rmd"))
# 17. knitr::knit(knit_input, knit_output, envir = envir, quiet ...
# 18. knitr:::process_file(text, output)
# 19. base:::withCallingHandlers(if (tangle) process_tangle(gro ...
# 20. knitr:::process_group(group)
# 21. knitr:::process_group.block(group)
# 22. knitr:::call_block(x)
# 23. knitr:::block_exec(params)
# 24. knitr:::eng_r(options)
# 25. knitr:::in_dir(input_dir(), evaluate(code, envir = env, n ...
# 26. knitr:::evaluate(code, envir = env, new_device = FALSE, k ...
# 27. evaluate::evaluate(...)
# 28. evaluate:::evaluate_call(expr, parsed$src[[i]], envir = e ...
# 29. evaluate:::timing_fn(handle(ev <- withCallingHandlers(wit ...
# 30. base:::handle(ev <- withCallingHandlers(withVisible(eval( ...
# 31. base:::withCallingHandlers(withVisible(eval(expr, envir, ...
# 32. base:::withVisible(eval(expr, envir, enclos))
# 33. base:::eval(expr, envir, enclos)
# 34. base:::eval(expr, envir, enclos)
# 35. categoryCompare2:::get_significant_annotations(comb_enric ...
# 36. categoryCompare2:::get_significant_annotations(comb_enric ...
# 37. categoryCompare2:::.get_significant_combined_enrichment(i ...
# 38. base:::lapply(in_results#enriched, function(x) { ...
# 39. categoryCompare2:::FUN(X[[i]], ...)
# 40. categoryCompare2:::get_significant_annotations(x#statisti ...
# 41. categoryCompare2:::get_significant_annotations(x#statisti ...
# 42. categoryCompare2:::.get_significant_stat_results(in_resul ...
# 43. categoryCompare2:::multi_query_list(in_results#statistic_ ...
# 44. base:::lapply(queries, eval, list_to_query)
# 45. base:::FUN(X[[i]], ...)
# 46. base:::FUN(X[[i]], ...)
# 47. base:::.handleSimpleError(function (e) ...
# 48. h(simpleError(msg, call))
# x object 'sig_cutoff' not found
You can see that it complains that sig_cutoff is not found, but it exists in the environment, but does not seem to get passed down.
If I instead run it directly, it works:
rmarkdown::render(here::here("categoryCompare2_failure.Rmd"), output_file = "cc2_works.md")
I've put all the code in a github repo.
Interestingly, it's definitely a callr issue, because targets has the same issue.
callr v 1.0.7, rmarkdown v 2.11, R 4.1.0
Other package versions are in the renv.lock file.

Related

devtools::check fails with cpp_object_initializer

I run devtools::test and it works:
$ RScript -e "devtools::test()"
...
OK: 24
But devtools::check fails at a test:
$ RScript -e "devtools::check()"
...
> test_check("package")
Error in cpp_object_initializer(.self, .refClassDef, ...) :
could not find function "cpp_object_initializer"
Stan model 'bayes_logit' does not contain samples.
── 1. Error: Mixture of Dirichlet Processes stick-breaking works and returns (#t
'data' must be of a vector type, was 'NULL'
1: mdp_logit_mvn_stickbreaking(n_samp = n_samp, mix_mean = NULL, mix_cov = NULL, posterior_sample = stan_sample,
prior_sample_size = 1, dataset = german, tol = 1e-08) at testthat/test_stick_breaking.R:35
2: MASS::mvrnorm(n = n_samp, mu = mix_mean, Sigma = mix_cov)
3: eigen(Sigma, symmetric = TRUE)
4: unname(as.matrix(x))
5: as.matrix(x)
6: as.matrix.default(x)
7: array(x, c(length(x), 1L), if (!is.null(names(x))) list(names(x), NULL) else NULL)
How can I fix it?
This is due to the difference between loading and attaching. I took the solution from this GitHub issue.
Add this in NAMESPACE to tell R where to find cpp_object_initialiser:
Depends:
Rcpp
This works, but it gives you a note. To avoid the note, add an Roxygen export around the function that uses the Rstan call:
#' #importFrom Rcpp cpp_object_initializer
function_name <- function(...) {...}

How to add a reporter to testthat?

I'm trying to add a JUnit reporter to testthat. While I can do it inside the package (https://github.com/hadley/testthat/pull/481) I cannot make it pass the same set of tests when in a separate package (https://github.com/lbartnik/testthatJUnit).
My main problem is that tests designed for reporters and present in testthat do not pass if I pull JUnit reporter code to a separate package. I'm guessing that there is something in those tests that "sets the scene" for testing reporters but I'm unable to identify this "something".
Any help much appreciated.
Details follow.
> library(devtools)
> test("testthatJUnit")
Loading testthatJUnit
Testing testthatJUnit
JUnitReporter:
DONE ==========================================================================
> test("testthat")
Loading testthat
unloadNamespace("testthat") not successful, probably because another loaded package depends on it.Forcing unload. If you encounter problems, please restart R.
Testing testthat
Bare expectations:
Colours: ..
compare.character: .................
compare.numeric: .....................
compare.time: .......
# ... lines cut ...
DONE ===========================================================================
> test("testthatJUnit")
Loading testthatJUnit
Testing testthatJUnit
JUnitReporter: .............
If I modify the test to see why the first test("testthatJUnit") is silent I see this:
> test("testthatJUnit")
Loading testthatJUnit
Testing testthatJUnit
JUnitReporter: Bare: .1
Failed -------------------------------------------------------------------------
1. Error: Junit reporter regression (#test-reporter-junit.R#13) ----------------
attempt to apply non-function
1: test_dir("test_dir") at /mnt/storage-a/lukaszb/src/third-party/testthatJUnit/tests/testthat/test-reporter-junit.R:13
2: test_files(paths, reporter = reporter, env = env, ...)
3: with_reporter(reporter = current_reporter, results <- lapply(paths, test_file, env = env,
reporter = current_reporter, start_end_reporter = FALSE, load_helpers = FALSE))
4: force(code)
5: lapply(paths, test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE)
6: FUN(X[[i]], ...)
7: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter, {
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE)
end_context()
})
8: force(code)
9: source_file(path, new.env(parent = env), chdir = TRUE)
10: eval(exprs, env)
11: eval(expr, envir, enclos)
12: expect_that(1, equals(1)) at test_dir/test-bare-expectations.R:3
13: condition(object)
14: expect_equal(x, expected, ..., expected.label = label)
15: expect(comp$equal, sprintf("%s not equal to %s.\n%s", lab_act, lab_exp, comp$message),
info = info)
16: withRestarts(if (expectation_broken(exp)) {
stop(exp)
} else {
signalCondition(exp)
}, continue_test = function(e) NULL)
17: withOneRestart(expr, restarts[[1L]])
18: doWithOneRestart(return(expr), restart)
19: signalCondition(exp)
20: (function (e)
{
register_expectation(e, frame + 11, sys.nframe() - 6)
invokeRestart("continue_test")
})(structure(list(message = "1 not equal to 1.\nEqual\n", srcref = NULL), .Names = c("message",
"srcref"), class = c("expectation_success", "expectation", "condition")))
21: register_expectation(e, frame + 11, sys.nframe() - 6)
22: get_reporter()$add_result(context = get_reporter()$.context, test = test, result = e)
23: o_apply(self$reporters, "add_result", context = context, test = test, result = result)
24: lapply(objects, function(x) x[[method]](...))
25: FUN(X[[i]], ...)
26: x[[method]](...)
But if I run test("testthat") and again test("testthatJUnit") everything comes back to normal:
> test("testthatJUnit")
Loading testthatJUnit
Testing testthatJUnit
JUnitReporter: Bare: ..
Basic: .......
empty: 1
error: 2.3456.
failures: 7.8..
helper: .
skip: S
My guess is that there is something in testthat's tests that sets up the scene for testing reporters but so far I haven't been able to identify it. Any help?
Actually, it turned out there is a bug in testthat 1.0.2 that is already fixed in the github sources (https://github.com/hadley/testthat/commit/99c25fc4efefa012a36d8fc912210ba3452a978d). With this version of testthat all tests in my package pass with no errors.

Roxygenize fails with... is.call(call) is not TRUE

Every time I try to roxygenize a package I get this error:
Error: is.call(call) is not TRUE
The results of a traceback():
11: stop(sprintf(ngettext(length(r), "%s is not TRUE", "%s are not all TRUE"),
ch), call. = FALSE, domain = NA)
10: stopifnot(is.call(call))
9: standardise_call(call, env)
8: object_from_call(call, env, preref)
7: (function (call, ref, comment_ref)
{
preref <- parse.preref(as.character(comment_ref))
if (is.null(preref))
return()
preref$object <- object_from_call(call, env, preref)
preref$srcref <- list(filename = file, lloc = as.vector(ref))
add_defaults(preref)
})(dots[[1L]][[1L]], dots[[2L]][[1L]], dots[[3L]][[1L]])
6: mapply(FUN = f, ..., SIMPLIFY = FALSE)
5: Map(extract, parsed, refs, comment_refs)
4: FUN(c("/home/path/to/package/file1.r",
"/home/path/to/package/file2.r",
.... # list of files truncated
"/home/path/to/package/doc.file.r")[[25L]],
...)
3: lapply(r_files(base_path), parse_file, env = env)
2: parse_package(base_path, load_code)
1: roxygenize("~/Current/r/path/to/package/")
Has anyone experienced this problem before? I'm not even sure how to debug it further.
This error occurs if, instead of the typical NULL value that one puts at the end of the documentation for the package, one uses NA. Simply updating to NULL will remove the error.

gWidgets + tcltk - creating a simple window returns a error

I'm trying to make a small GUI to make it easier for other people to run a script.
I'm using gWidgets with tcltk on a Windows machine.
I create a simple window like this:
require(gWidgets)
require(gWidgetstcltk)
options(guiToolkit="tcltk")
win <- gwindow(title="This is a window!")
grp <- ggroup(container=win)
lbl <- glabel("Here you can write stuff:", container=grp)
txt <- gedit(text="Stuff", container=grp)
When I run it on a new session i get the error message:
Error in envRefInferField(x, what, getClass(class(x)), selfEnv) :
‘no_items’ is not a valid field or method name for reference class “Entry”
If i rerun after the error i get this:
<simpleError in envRefInferField(x, what, getClass(class(x)), selfEnv): ‘no_items’ is
not a valid field or method name for reference class “Entry”>
Anyone can explain what is going on?
EDIT:
The problem seems to only show up on RStudio and not on RGui.exe.
I'm not such an expert programmer, but I guess it is somehow related with the way RStudio manages the environments.
I guess the question now is more: How do i make this work normally in RStudio?
Traceback:
> traceback()
11: stop(gettextf("%s is not a valid field or method name for reference class %s",
sQuote(field), dQuote(thisClass#className)), domain = NA)
10: envRefInferField(x, what, getClass(class(x)), selfEnv)
9: r5_widget$no_items
8: r5_widget$no_items
7: .length(x#widget, x#toolkit)
6: .length(x#widget, x#toolkit)
5: FUN(X[[3L]], ...)
4: FUN(X[[3L]], ...)
3: lapply(X = X, FUN = FUN, ...)
2: sapply(globalValues, length, USE.NAMES = FALSE) at SessionWorkspace.R#166
1: (function ()
{
globals = ls(envir = globalenv())
globalValues = lapply(globals, function(name) {
get(name, envir = globalenv(), inherits = FALSE)
})
types = sapply(globalValues, .rs.getSingleClass, USE.NAMES = FALSE)
lengths = sapply(globalValues, length, USE.NAMES = FALSE)
values = sapply(globalValues, .rs.valueAsString, USE.NAMES = FALSE)
extra = sapply(globalValues, .rs.valueDescription, USE.NAMES = FALSE)
result = list(name = globals, type = types, len = lengths,
value = values, extra = extra)
result
})()

Error in do.call(): unused arguments

Reproducible code:
op <- par(no.readonly = TRUE)
Sys.setenv(TZ = 'UTC')
# *********************************
# 1. Installing packages
# *********************************
install.packages('quantmod')
# *********************************
# 2. Loading packages
# *********************************
require(compiler)
require(quantmod)
# *********************************
# 3. Downloading and preparing data
# *********************************
env <- new.env()
Symbols <- c('SPY', 'QQQ', 'XLF', 'GLD')
getSymbols(Symbols = Symbols, env = env, from = '1950-01-01')
args <- eapply(env = env, FUN = function(x){na.omit(merge(OpCl(x)))})
do.call(what = function(x){x}, args = args)
Last command returns
Error in (function (x) :
unused arguments (GLD = c(-0.00112536574386668, 0.00651831872330866, 0.00446927374301676, -0.00289661319073087, 0.00267082127754281, 0.000883977900552502, 0.00665188470066513, -0.0055102490632577, 0.00220848056537104, -0.0131723380900108, 0.0124333925399644, -0.00484688257325394, -0.00419426048565119, 0.00479452054794516, 0.000685714285714401, 0.00161401890707857, 0.00687915615684465, -0.00479890310786113, -0.00249433106575958, -0.00704705614912482, 0.00591850671522876, 0.000225580870742315, 0.00203942895989107,
-0.00407239819004523, 0.00226398007697526, 0.00428990742831337, -0.00112561909049991, -0.00591985428051012, 0.00758620689655176, -0.00114025085518821, 0.000930665425779686, -0.00140186915887841, -0.00187134502923969, -0.00776836158192085, -0.00593965312425759, -0.000952607763753277, 0, 0.00188146754468477, 0.00495399858457191, 0.00308129888599207, 0.00236854571293232, -0.00914419695193436, 0.00308641975308643, 0.00992438563327047, 0.00070191857744506, -0.006818716200
I would need to coerce args, which is a list, in a matrix-like object.
Since you have xts objects , I guess you need something like :
do.call(merge,args)
This will create a single time series for the 4 symbols:
tail(do.call(merge,args))
OpCl.x OpCl.x.1 OpCl.x.2 OpCl.x.3
2013-07-01 9.921627e-03 -0.0040837162 -0.0005574913 0.0006201166
2013-07-02 -1.063128e-02 0.0005122951 0.0008370536 0.0005585899
2013-07-03 3.314002e-04 0.0036082474 0.0076944600 0.0049850449
2013-07-05 8.468835e-05 0.0066023362 0.0019326339 0.0033852404
2013-07-08 3.526744e-03 0.0010025063 -0.0039758706 0.0005492494
2013-07-09 -1.820589e-03 0.0024888004 0.0015072623 0.0009092011

Resources