R - Проверка, является ли строка допустимым математическим выражением, используя нестандартную оценку - PullRequest
Новая
       45

R - Проверка, является ли строка допустимым математическим выражением, используя нестандартную оценку

1 голос
/ 01 ноября 2019

Я хотел бы проверить, являются ли приведенные ниже строки действительными математическими выражениями: 

s1 = 'sin(x)'
s2 = 'sin(x*m)'
s3 = 'sin'
s4 = 'sin(xm)'

Под словом "действительный" я имею в виду выражение, представляющее собой комбинацию операторов

  1. (должен использоваться вместе с переменными или константами)
  2. переменные x и / или m
  3. константы.

По этому определению s1 и s2 действительны, в то время как s3 и s4 не действительны.

Чтобы определить, является ли строка допустимой, я написал функциюcheckFxn, который сначала пытается преобразовать строку в вызов или одну из ее частей. В случае успеха он затем рекурсивно просматривает дерево вызовов и проверяет вышеуказанные условия. Если условия выполнены, то звонок возвращается как есть. Если нет, выдается ошибка. 

checkFxn <- function(x) {

  lang <- str2lang(x)

  checkFxn2 <- function(y) {

    if(is.name(y)) {

      stopifnot(deparse(y) %in% c('x', 'm'))

    } else if(is.call(y)) {

      stopifnot(is.function(eval(y[[1]])) | is.primitive(eval(y[[1]])))

      lapply(y[-1], checkFxn2)

    } else {

      stopifnot(is.logical(y) | is.numeric(y) | is.complex(y))

    }

    return(y)

  }

  checkFxn2(lang)

}


#Applying checkFxn to s1-4
lapply(list(s1,s2,s3,s4), function(x) {try(checkFxn(x), silent = T)})
[[1]]
sin(x)

[[2]]
sin(x * m)

[[3]]
[1] "Error in checkFxn2(lang) : deparse(y) %in% c(\"x\", \"m\") is not TRUE\n"
attr(,"class")
[1] "try-error"
attr(,"condition")
<simpleError in checkFxn2(lang): deparse(y) %in% c("x", "m") is not TRUE>

[[4]]
[1] "Error in FUN(X[[i]], ...) : deparse(y) %in% c(\"x\", \"m\") is not TRUE\n"
attr(,"class")
[1] "try-error"
attr(,"condition")
<simpleError in FUN(X[[i]], ...): deparse(y) %in% c("x", "m") is not TRUE>

Кажется, она работает, как и ожидалось, но я опасаюсь моего использования eval и задавался вопросом, может ли кто-нибудь предложить альтернативу его использованию? Я знаю, что он следует обычным лексическим правилам, поэтому меня беспокоит оценка переменных в глобальной среде - есть ли способ ограничить его область? Я прочитал главу о нестандартной оценке , но я не могу понять это.

Кроме того, есть ли способ определить, является ли базовая функция или примитив математическим оператором? Я хотел бы использовать что-то более конкретное, чем is.function и is.primitive.

1 Ответ

1 голос
/ 01 ноября 2019

Шаг 1: Решите, что составляет «математический оператор». Одним из вариантов является получение соответствующих групп из S4 generics . Например, 

mathOps <- unlist(lapply( c("Arith","Compare","Math"), getGroupMembers ))
#  [1] "+"        "-"        "*"        "^"        "%%"       "%/%"     
#  [7] "/"        "=="       ">"        "<"        "!="       "<="      
# [13] ">="       "abs"      "sign"     "sqrt"     "ceiling"  "floor"   
# [19] "trunc"    "cummax"   "cummin"   "cumprod"  "cumsum"   "exp"     
# [25] "expm1"    "log"      "log10"    "log2"     "log1p"    "cos"     
# [31] "cosh"     "sin"      "sinh"     "tan"      "tanh"     "acos"    
# [37] "acosh"    "asin"     "asinh"    "atan"     "atanh"    "cospi"   
# [43] "sinpi"    "tanpi"    "gamma"    "lgamma"   "digamma"  "trigamma"

Шаг 2: Разложить ваши выражения на абстрактные синтаксические деревья . 

getAST <- function( ee ) 
    lapply( as.list(ee), function(x) `if`(is.call(x), getAST(x), x) )

# Example usage
getAST( quote(sin(x+5)) )
# [[1]]
# sin
# 
# [[2]]
# [[2]][[1]]
# `+`
# 
# [[2]][[2]]
# x
# 
# [[2]][[3]]
# [1] 5

Шаг 3: Пройдите AST на основе вашего определения «достоверности» 

checkFxn <- function( ast, validOps )
{
  ## Terminal nodes of an AST will not be lists
  ## Wrap them into a list of length 1 to keep the recursion flow
  if( !is.list(ast) ) ast <- list(ast)

  ## Operators must be called with one or more arguments
  if( as.character(ast[[1]]) %in% validOps )
    return( `if`(length(ast) < 2, FALSE,
                 all(sapply(ast[-1], checkFxn, validOps))) )

  ## Variables x and m are OK
  if( identical(ast[[1]], quote(x)) || identical(ast[[1]], quote(m)) )
    return(TRUE)

  ## Constants are OK
  if( is.numeric(ast[[1]]) ) return(TRUE)

  ## Everything else is invalid
  FALSE
}

Соберите все вместе 

exprs <- lapply( list(s1,s2,s3,s4), str2lang )   # Convert strings to expressions
asts <- lapply( exprs, getAST )                  # Build ASTs
sapply( asts, checkFxn, mathOps )                # Evaluate validity
# [1]  TRUE  TRUE FALSE FALSE
...