Question

在函数中使用ls()时，即使未对其求值（即使没有默认值的调用中缺少它们），它也会列出该函数的参数。

fun <- function(x,y,z,m){
  a <- 1
  y <- 1
  force(z)
  print(ls())
  mget(ls())
}
fun(i,j,42)
# [1] "a" "m" "x" "y" "z"
Error in mget(ls()) : object 'i' not found

如何仅列出评估的变量？

在那种情况下，我会满意于给出以下任何一个的修改列表：

# [1] "a" "y" "z"
# [1] "a" "y"

或者（或另外），一个逻辑列表告诉我是否对参数进行了评估（或覆盖）是很好的：在这种情况下，list(x = FALSE, y = TRUE, z = TRUE, m = FALSE)

Answer 1

好吧，这很接近，is_promise中有一个pryr函数。它需要一个符号，但未导出的版本is_promise2可以使用名称。所以像这样的东西

fun <- function(x,y,z,m){
  a <- 1
  y <- 1
  force(z)
  mget(ls()[!sapply(ls(), pryr:::is_promise2, environment())])
}
fun(i, j, 42)

至少消除了关于i的消息。但似乎无法捕获x。但是，就像is_promise2一样，我认为您将不得不深入c / c ++领域才能找到有关评估/承诺状态的信息，因为我认为R试图向用户隐藏大部分信息。

Answer 2

MrFlick的答案就是我所寻找的，可以使用下面的函数收集其他相关信息，该函数包装在trace周围，以方便使用。

更好的样本数据

defined_in_global <- 1
enclosing_fun <- function(){
  defined_in_enclos <- quote(qux)
  function(not_evaluated,
           overridden = "bar",
           forced = "baz",
           defined_in_global,
           defined_in_enclos,
           missing_with_default = 1,
           missing_overriden,
           missing_absent){
    overridden <- TRUE
    missing_overridden <- "a"
    new_var <- 1
  }
}

如何使用而不尝试评估

fun <- enclosing_fun()
diagnose_vars(fun)
fun(not_evaluated = foo)
#> Tracing fun(not_evaluated = foo) on exit 
#>                    name evaluable      type is_formal missing absent_from_call is_promise has_default_value default_value called_with_value exists_in_parent exists_in_enclos
#> 1         not_evaluated     FALSE      <NA>      TRUE   FALSE            FALSE       TRUE             FALSE            NA               foo            FALSE            FALSE
#> 2            overridden      TRUE   logical      TRUE   FALSE             TRUE      FALSE              TRUE         "bar"              <NA>            FALSE            FALSE
#> 3                forced     FALSE      <NA>      TRUE    TRUE             TRUE       TRUE              TRUE         "baz"              <NA>            FALSE            FALSE
#> 4     defined_in_global     FALSE      <NA>      TRUE    TRUE             TRUE      FALSE             FALSE            NA              <NA>             TRUE             TRUE
#> 5     defined_in_enclos     FALSE      <NA>      TRUE    TRUE             TRUE      FALSE             FALSE            NA              <NA>            FALSE             TRUE
#> 6  missing_with_default     FALSE      <NA>      TRUE    TRUE             TRUE       TRUE              TRUE             1              <NA>            FALSE            FALSE
#> 7     missing_overriden     FALSE      <NA>      TRUE    TRUE             TRUE      FALSE             FALSE            NA              <NA>            FALSE            FALSE
#> 8        missing_absent     FALSE      <NA>      TRUE    TRUE             TRUE      FALSE             FALSE            NA              <NA>            FALSE            FALSE
#> 9    missing_overridden      TRUE character     FALSE      NA               NA         NA                NA            NA              <NA>            FALSE            FALSE
#> 10              new_var      TRUE    double     FALSE      NA               NA         NA                NA            NA              <NA>            FALSE            FALSE

如何使用，尝试进行评估

diagnose_vars(fun, eval = TRUE)
fun(not_evaluated = foo)
#> Tracing fun(not_evaluated = foo) on exit 
#>                    name evaluable      type is_formal missing absent_from_call is_promise has_default_value default_value called_with_value exists_in_parent exists_in_enclos
#> 1         not_evaluated      TRUE      <NA>      TRUE   FALSE            FALSE       TRUE             FALSE            NA               foo            FALSE            FALSE
#> 2            overridden     FALSE   logical      TRUE   FALSE             TRUE      FALSE              TRUE         "bar"              <NA>            FALSE            FALSE
#> 3                forced     FALSE character      TRUE    TRUE             TRUE       TRUE              TRUE         "baz"              <NA>            FALSE            FALSE
#> 4     defined_in_global      TRUE      <NA>      TRUE    TRUE             TRUE      FALSE             FALSE            NA              <NA>             TRUE             TRUE
#> 5     defined_in_enclos      TRUE      <NA>      TRUE    TRUE             TRUE      FALSE             FALSE            NA              <NA>            FALSE             TRUE
#> 6  missing_with_default     FALSE    double      TRUE    TRUE             TRUE       TRUE              TRUE             1              <NA>            FALSE            FALSE
#> 7     missing_overriden      TRUE      <NA>      TRUE    TRUE             TRUE      FALSE             FALSE            NA              <NA>            FALSE            FALSE
#> 8        missing_absent      TRUE      <NA>      TRUE    TRUE             TRUE      FALSE             FALSE            NA              <NA>            FALSE            FALSE
#> 9    missing_overridden     FALSE character     FALSE      NA               NA         NA                NA            NA              <NA>            FALSE            FALSE
#> 10              new_var     FALSE    double     FALSE      NA               NA         NA                NA            NA              <NA>            FALSE            FALSE

代码

diagnose_vars <- function(f, eval = FALSE, on.exit = TRUE, ...) {
  eval(substitute(
    if(on.exit) trace(..., what =f, exit = quote({
      diagnose_vars0(eval, print = TRUE)
      untrace(f)}))
    else trace(..., what =f, tracer = diagnose_vars0(eval, print = TRUE),
               exit = substitute(untrace(f)), ...)
  ))
  invisible(NULL)
}

diagnose_vars0 <- function(eval = FALSE, print = FALSE){
  f_env        <- parent.frame()
  mc           <- eval(quote(match.call()), f_env)
  f            <- eval.parent(mc[[1]],2)
  f_parent_env <- parent.frame(2)
  f_enclos     <- rlang::fn_env(f)

  vars     <- ls(f_env)
  fmls     <- eval(quote(formals()), f_env)
  fml_nms  <- names(fmls)
  fml_syms <- rlang::syms(fml_nms)
  mc_args  <- as.list(mc)[-1]



  # compute complete df cols when possible

  is_formal   <- vars %in% fml_nms

  # build raw df, with NA cols when necessary to initiate
  data <- data.frame(row.names = vars,
                     name = vars,
                     evaluable = NA,
                     type = NA,
                     is_formal,
                     missing = NA,
                     absent_from_call = NA,
                     is_promise = NA,
                     has_default_value = NA)

  # absent_from_call : different from missing when variable is overriden
  data[fml_nms, "absent_from_call"]  <- ! fml_nms %in% names(mc_args)

  # promise
  data[fml_nms, "is_promise"]  <- sapply(fml_nms, pryr:::is_promise2, f_env)

  # missing
  data[fml_nms, "missing"] <- sapply(fml_syms, function(x)
    eval(substitute(missing(VAR), list(VAR = x)), f_env))

  # has default values
  formal_has_default_value <- !sapply(fmls,identical, alist(x=)[[1]])
  data[fml_nms, "has_default_value"] <- formal_has_default_value

  # default values
  data$default_value <- 
    vector("list",length(vars))
  data$default_value[] <- NA
  data[fml_nms[formal_has_default_value], "default_value"] <- 
    sapply(fmls[formal_has_default_value], deparse)

  # called_with_value
  data[names(mc_args), "called_with_value"] <- 
    sapply(mc_args, deparse)

  # exists
  data$exists_in_parent <- sapply(vars, exists, envir= f_parent_env)
  data$exists_in_enclos <- sapply(vars, exists, envir= f_enclos)

  # types
  if(eval){
     types <- sapply(vars, function(x) 
      try(eval(bquote(typeof(.(as.symbol(x)))), f_env),silent = TRUE))
    data$type      <- ifelse(startsWith(types,"Error"), NA, types)
    data$evaluable <- is.na(data$type)
  } else {
    data$evaluable <-
      with(data,!is_formal | (!is_promise & !missing))
    data$type[data$evaluable] <- 
      sapply(mget(vars[data$evaluable], f_env), typeof)
  }

  # arrange
  data <- rbind(data[fml_nms,],data[!data$name %in% fml_nms,])
  row.names(data) <- NULL
  if (print) print(data) else data
}

如何仅列出已评估的变量？

2 个答案: