InterpretationEngine v0.1.2

.gitignore

@@ -5,6 +5,6 @@ interpretation-engine.Rproj
 .Rhistory
 *.Rproj
 cached-NASIS-data.Rda
-
 *.Rproj
 docs
+InterpretationEngine.Rproj

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: InterpretationEngine
 Title: Stand-alone NASIS Interpretation Engine
-Version: 0.1.1
+Version: 0.1.2
 Authors@R: 
     c(person(given = "Dylan",
            family = "Beaudette",

R/EvaluationCurves.R

@@ -256,9 +256,9 @@ extractCrispExpression <- function(x, invert = FALSE, asString = FALSE) {
 #' @export
 extractIsNull <- function(invert = FALSE) {
   if (invert) {
-    function(x) .NULL_HEDGE(x, null.value = 1)
-  } else {
     function(x) .NULL_HEDGE(x, null.value = 0)
+  } else {
+    function(x) .NULL_HEDGE(x, null.value = 1)
   }
 }
 
@@ -594,7 +594,7 @@ extractIsNull <- function(invert = FALSE) {
   if (grepl("^i?matches", step0, ignore.case = TRUE)) {
     step0.5 <- gsub("\" *or *i?matches *\"|\" *or *\"|\", \"", "$|^", step0, ignore.case = TRUE)
   } else {
-    step0.5 <- gsub("\" *or *i?matches *\"|\", \"", "$|^", step0, ignore.case = TRUE)
+    step0.5 <- step0 #gsub("\" *or *i?matches *\"|\", \"", "$|^", step0, ignore.case = TRUE)
   }  
 
   # wildcards matches/imatches
@@ -643,7 +643,11 @@ extractIsNull <- function(invert = FALSE) {
 
   # logical expression, possibly inverted, then converted to numeric (0/1)
   # TODO: handle NA via na.rm/na.omit, returning attribute of offending indices
-  res <- sprintf("function(x) { as.numeric(%s(%s)) }", 
+  res <- sprintf("function(x) { 
+                    y <- as.numeric(%s(%s)) 
+                    y[is.na(y)] <- 0
+                    y
+                  }", 
                  ifelse(invert, "!", ""), expr)
   if (asString) return(res)
   res <- try(eval(parse(text = res)))

R/hedge.R

@@ -1,33 +1,33 @@
 # hedge and operator functions
 
-# NULL hedge: if NULL data in `x` then `null.value`, else `x`
+# NULL hedge: if NULL data in `x` then `null.value`, else `0`
 #' @importFrom stats na.omit
-.NULL_HEDGE <- function(x, null.value = NULL, na.rm = FALSE) {
+.NULL_HEDGE <- function(x, null.value = NULL, not.null.value = 0, na.rm = FALSE) {
   if (na.rm) x <- na.omit(x)
   if (!is.list(x)) {
-    x[is.null(x) | (is.na(x) & !is.nan(x))] <- null.value
+    x <- ifelse(is.null(x) | (is.na(x) & !is.nan(x)), null.value, not.null.value)
   }
   x
 }
 
 .NULL_NOT_RATED <- function(x, na.rm = FALSE) {
-  # NULL NOT RATED hedge: if NULL data in `x` then `NaN`, else `x`
+  # NULL NOT RATED hedge: if NULL data in `x` then `NaN`, else `0`
   .NULL_HEDGE(x, null.value = NaN, na.rm = na.rm)
 }
 
 .NULL_NA <- function(x, na.rm = FALSE) {
-  # NULL NA hedge: if NULL data in `x` then `NA`, else `x`
+  # NULL NA hedge: if NULL data in `x` then `NA`, else `0`
   # does not exist in NASIS
   .NULL_HEDGE(x, null.value = NA, na.rm = na.rm)
 }
 
 .NOT_NULL_AND <- function(x, na.rm = FALSE) {
-  # NOT NULL AND hedge: if NULL data in `x` then `0`, else `x`
-  .NULL_HEDGE(x, null.value = 0L, na.rm = na.rm)
+  # NOT NULL AND hedge: if NULL data in `x` then `0`, else `1`
+  .NULL_HEDGE(x, null.value = 0L, not.null.value = 1L, na.rm = na.rm)
 }
 
 .NULL_OR <- function(x, na.rm = FALSE) {
-  # NULL OR hedge: if NULL data in `x` then `1`, else `x`
+  # NULL OR hedge: if NULL data in `x` then `1`, else `0`
   .NULL_HEDGE(x, null.value = 1L, na.rm = na.rm)
 }
 
@@ -40,7 +40,12 @@
 }
 
 .NOT <- function(x, a, na.rm = FALSE) {
-  1 - matrix(as.numeric(x), ncol = ncol(x))
+  if (!is.matrix(x)) {
+    nc <- 1
+  } else {
+    nc <- ncol(x)
+  }
+  1 - matrix(as.numeric(x), ncol = nc)
 }
 
 .PROD <- function(x, na.rm = FALSE) {
@@ -50,10 +55,10 @@
     }
     x <- do.call('cbind', x)
   }
-  nc <- ncol(x)
-  if (nc == 1) { 
-    return(as.numeric(x))
+  if (ncol(x) == 1) { 
+    x <- t(x)
   }
+  nc <- ncol(x)
   m <- matrix(as.numeric(x), ncol = nc)
   res <- m[, 1]
   for (i in 2:ncol(m)) {
@@ -72,11 +77,11 @@
     }
     x <- do.call('cbind', x)
   }
-  nc <- ncol(x)
-  if (nc == 1) { 
-    return(as.numeric(x))
+  if (ncol(x) == 1) { 
+    x <- t(x)
   }
-  matrixStats::rowMaxs(matrix(as.numeric(x), ncol = ncol(x)), na.rm = na.rm)
+  nc <- ncol(x)
+  matrixStats::rowMaxs(matrix(as.numeric(x), ncol = nc), na.rm = na.rm)
   # apply(matrix(as.numeric(x), ncol = ncol(x)), 1, max, na.rm = na.rm)
 }
 
@@ -88,10 +93,10 @@
     }
     x <- do.call('cbind', x)
   }
-  nc <- ncol(x)
-  if (nc == 1) { 
-    return(as.numeric(x))
+  if (ncol(x) == 1) { 
+    x <- t(x)
   }
+  nc <- ncol(x)
   matrixStats::rowMins(matrix(as.numeric(x), ncol = ncol(x)), na.rm = na.rm)
   # apply(matrix(as.numeric(x), ncol = ncol(x)), 1, min, na.rm = na.rm)
 }
@@ -104,14 +109,18 @@
     }
     x <- do.call('cbind', x)
   }
-  nc <- ncol(x)
-  if (nc == 1) { 
-    return(as.numeric(x))
+  if (ncol(x) == 1) { 
+    x <- t(x)
   }
+  nc <- ncol(x)
   matrixStats::rowSums2(matrix(as.numeric(x), ncol = ncol(x)), na.rm = na.rm)
   # apply(matrix(as.numeric(x), ncol = ncol(x)), 1, sum, na.rm = na.rm)
 }
 
+.LIMIT <- function(x, val, na.rm = FALSE) {
+  pmin(x, val, na.rm = na.rm)
+}
+
 # return a function to apply hedge_type to the values in x
 functionHedgeOp <- function(hedge_type) {
   switch(toupper(gsub(" ", "_", hedge_type)),
@@ -126,5 +135,6 @@ functionHedgeOp <- function(hedge_type) {
          "OR" = .OR_MAX,
          "AND" = .AND_MIN,
          "SUM" = .SUM,
-         "POWER" = .POWER)
+         "POWER" = .POWER,
+         "LIMIT" = .LIMIT)
 }

misc/apex-scratch.R

@@ -0,0 +1,46 @@
+library(InterpretationEngine)
+
+r0 <- initRuleset("Similar Soil Grouping for APEX Modeling")
+r <- r0#r0$children$RuleOperator_3886708d$children[[8]]
+p <- getPropertySet(r)
+p2 <- unique(p[,2:3])
+coiid <- 667033:667036
+
+prop <- lookupProperties(coiid, p2$propiid)
+
+# my_data <- as.data.frame(lapply(seq(nrow(p2)), function(x) 25))# c(25, 50, 100)))
+# my_data <- as.data.frame(as.list(prop$rv))
+
+my_data <- reshape(
+  prop,
+  v.names = "rv",
+  idvar = "coiid",
+  timevar = "propiid",
+  direction = "wide"
+)
+colnames(my_data) <- c("coiid", "comp_name", "comp_pct", make.names(p2$propname))
+
+# # handle missing values (TODO: this shouldnt be needed)
+# my_data$FRAGMENTS...250MM.ON.SURFACE <- ifelse(
+#   is.na(my_data$FRAGMENTS...250MM.ON.SURFACE),
+#   0,
+#   my_data$FRAGMENTS...250MM.ON.SURFACE
+# )
+# 
+# my_data$GRL.USDA.TEXTURE.MODIFIER.SURFACE.LAYER <- ifelse(
+#   is.na(my_data$GRL.USDA.TEXTURE.MODIFIER.SURFACE.LAYER),
+#   NA,
+#   my_data$GRL.USDA.TEXTURE.MODIFIER.SURFACE.LAYER
+# )
+
+rsub <- r0$RuleOperator_3886708d$
+  `Similar Soils Surface Rock Fragment Subrule`$
+  RuleOperator_c5e1ae36$children[[1]]$RuleOperator_1257f912$`Surface Layer Fragment Modifier = "none" (is null)`
+psub <- getPropertySet(rsub)
+interpret(rsub, my_data[unique(make.names(psub$propname))])
+
+# rt <- initRuleset("Similar Soil Grouping Flood Frequency Sub-rule")
+interpret(r, my_data)
+r2 <- r$RuleOperator_3886708d$children[[7]]
+r2 |> interpret(my_data, cache = TRUE)
+r2$RuleOperator_c5e1ae36$children[[1]]$RuleOperator_1257f912$children[[1]] |> interpret(my_data)