Как перечислить только переменные, которые были оценены?

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
}