diff --git a/.gitignore b/.gitignore index 47c9a3e..880863b 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,6 @@ interpretation-engine.Rproj .Rhistory *.Rproj cached-NASIS-data.Rda - *.Rproj docs +InterpretationEngine.Rproj diff --git a/DESCRIPTION b/DESCRIPTION index d847c3d..b2936d7 100644 --- a/DESCRIPTION +++ b/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", diff --git a/R/EvaluationCurves.R b/R/EvaluationCurves.R index 9ff0070..b858004 100644 --- a/R/EvaluationCurves.R +++ b/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))) diff --git a/R/hedge.R b/R/hedge.R index 8302235..312cb71 100644 --- a/R/hedge.R +++ b/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) } diff --git a/misc/apex-scratch.R b/misc/apex-scratch.R new file mode 100644 index 0000000..ca4a79c --- /dev/null +++ b/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)