从 Romain 代码中的想法开始,然后复制 RCNTXT 结构(加上它内部使用的几个其他结构),我设法让 C++ 代码返回 R_GlobalContext 的内容。
C++ 代码如下所示:
#include <Rcpp.h>
#include <Rinternals.h>
#include <setjmp.h>
extern void* R_GlobalContext ;
typedef struct {int tag, flags; union {int ival; double dval; SEXP sxpval;} u;
} R_bcstack_t;
typedef struct{jmp_buf jmpbuf; int mask_was_saved, saved_mask;} sigjmp_buf[1];
typedef struct RCNTXT {
struct RCNTXT *nextcontext;
int callflag;
sigjmp_buf cjmpbuf;
int cstacktop, evaldepth;
SEXP promargs, callfun, sysparent, call, cloenv, conexit;
void (*cend)(void *);
void *cenddata;
void *vmax;
int intsusp, gcenabled, bcintactive;
SEXP bcbody;
void* bcpc;
SEXP handlerstack, restartstack;
struct RPRSTACK *prstack;
R_bcstack_t *nodestack;
R_bcstack_t *bcprottop;
SEXP srcref;
int browserfinish;
SEXP returnValue;
struct RCNTXT *jumptarget;
int jumpmask;
} RCNTXT, *context;
// [[Rcpp::export]]
Rcpp::List get_RCNTXT(int level){
RCNTXT* res = (RCNTXT*)R_GlobalContext;
if (level > 1) res = res->nextcontext;
return Rcpp::List::create(Rcpp::Named("call_flag") = res->callflag,
Rcpp::Named("c_stack_top") = res->cstacktop,
Rcpp::Named("call_depth") = res->evaldepth,
Rcpp::Named("call_fun") = res->callfun,
Rcpp::Named("sys_parent") = res->sysparent,
Rcpp::Named("call") = res->call,
Rcpp::Named("cloenv") = res->cloenv,
Rcpp::Named("conexit") = res->conexit,
Rcpp::Named("promargs") = res->promargs,
Rcpp::Named("intsusp") = res->intsusp,
Rcpp::Named("gcenabled") = res->gcenabled,
Rcpp::Named("bcintactive") = res->bcintactive,
Rcpp::Named("handlerstack") = res->handlerstack,
Rcpp::Named("restartstack") = res->restartstack,
Rcpp::Named("srcref") = res->srcref,
Rcpp::Named("browserfinish") = res->browserfinish);
}
这让我们可以查看R_Globalcontext的内容:
get_RCNTXT(1)
#> $call_flag
#> [1] 12
#>
#> $c_stack_top
#> [1] 4
#>
#> $call_depth
#> [1] 1
#>
#> $call_fun
#> function (level)
#> .Call(<pointer: 0x0000000071282ff0>, level)
#> <bytecode: 0x00000174169448d0>
#>
#> $sys_parent
#> <environment: R_GlobalEnv>
#>
#> $call
#> get_RCNTXT(1)
#>
#> $cloenv
#> <environment: 0x0000017416c52a08>
#>
#> $conexit
#> NULL
#>
#> $promargs
#> $promargs[[1]]
#> NULL
#>
#>
#> $intsusp
#> [1] 0
#>
#> $gcenabled
#> [1] 1
#>
#> $bcintactive
#> [1] 0
#>
#> $handlerstack
#> NULL
#>
#> $restartstack
#> NULL
#>
#> $srcref
#> NULL
#>
#> $browserfinish
#> [1] 0
不幸的是,browserfinish 字段只返回一个 0,无论是否从 browser 调用。但是,如果从browser 提示符调用get_RCNTXT 函数,则restartstack 表明它是从browser 调用的。这允许在获取 C++ 代码后定义以下 R 函数:
is_browser <- function()
{
R <- get_RCNTXT(1)$restartstack
if(is.null(R)) return(FALSE)
class(R[[1]]) == "restart"
}
这允许从命令提示符查询浏览器状态:
is_browser()
#> [1] FALSE
> browser()
#> Called from: top level
Browse[1]> is_browser()
#> [1] TRUE
但是,这并不像看起来那么有用。首先,它与base R中的以下代码具有相同的效果:
is_browser <- function() {
!is.null(findRestart("browser"))
}
其次,当从函数内部调用 browser 时,它运行的代码会在其自己的上下文而不是 browser 上下文中进行评估,这意味着 is_browser 将返回 FALSE。 browser 的 C 代码(实际函数在 main.c 中称为 do_browser)写入了一个新上下文,该上下文在函数退出后被删除,并且在函数,因此很难看出如何编写 is_browser 以允许访问此上下文。
因此,您似乎需要编写browser 的新实现,以允许浏览的上下文知道它正在被浏览,而我们真的不想去那里。
另一方面,浏览器上下文可以完全访问浏览的上下文,并且由于您的最终目标是只在浏览器模式下才允许像绘图这样的条件代码运行,我认为最好的解决方案是使用浏览器本身告诉被浏览的上下文它正在被浏览。
例如,如果你这样做:
browser_on <- function() {
options(I_am_browsing = TRUE)
}
browser_off <- function() {
options(I_am_browsing = FALSE)
}
is_browser <- function() {
b <- getOption("I_am_browsing")
if(is.null(b)) FALSE else b
}
您现在可以在浏览时选择有条件地运行受if(is_browser()) 保护的代码。
如果你有这样的fun(browser() 被注释掉):
fun <- function() {
#browser()
if(is_browser()) plot(1:10)
if(!is_browser()) "I didn't plot anything"
}
你会得到:
fun()
#> [1] "I didn't plot anything"
但是,如果你在浏览器中运行fun(),你会得到:
browser()
Called from: top level
Browse[1]> browser_on()
Browse[1]> fun()
如果在fun 内部调用browser,它仍然有效:
fun <- function() {
browser()
if(is_browser()) plot(1:10)
if(!is_browser()) "I didn't plot anything"
}
fun()
#> Called from: fun()
Browse[1]> browser_on()
Browse[1]>
#> debug at #3: if (is_browser()) plot(1:10)
Browse[2]>
#> debug at #3: plot(1:10)
Browse[2]>
#> debug at #4: if (!is_browser()) "I didn't plot anything"
Browse[2]>
这不是一个完美的解决方案,因为它在浏览器中运行时需要额外的命令,并且它通过options 保存状态。如果您从同一范围内多次调用browser,则需要跟踪这一点。特别是,如果您从全局环境中调用browser,则在退出浏览器之前应小心调用browser_off()。