test-DexiEvaluate.R
In DEXiR: 'DEXi' Library

test_that("evaluation_order() works", {
  evalord <- evaluation_order(CarDxi$root)
  expect_equal(evalord,
    c("BUY.PRICE", "MAINT.PRICE", "PRICE", "X.PERS", "X.DOORS", "LUGGAGE", "COMFORT", "SAFETY", "TECH.CHAR.", "CAR", "CAR_MODEL"))
  evalord <- evaluation_order(CarDxi$root, prune = "COMFORT")
  expect_equal(evalord,
    c("BUY.PRICE", "MAINT.PRICE", "PRICE", "COMFORT", "SAFETY", "TECH.CHAR.", "CAR", "CAR_MODEL"))
  evalord <- evaluation_order(CarDxi$root, prune = c("TECH.CHAR.", "PRICE"))
  expect_equal(evalord, c("PRICE", "TECH.CHAR.", "CAR", "CAR_MODEL"))
})

test_that("evaluate_as_set() works on CarDxi/CAR", {
  att <- CarDxi$attrib("CAR")
  fnc <- att$funct

  inps <- list(1, 1)
  eval <- evaluate_as_set(fnc, inps)
  expect_equal(eval, 1)

  inps <- list(2, 2)
  eval <- evaluate_as_set(fnc, inps)
  expect_equal(eval, 2)

  inps <- list(c(2, 1), 2)
  eval <- evaluate_as_set(fnc, inps)
  expect_equal(eval, c(1, 2))

  inps <- list(c(2, 1), c(2, 3))
  eval <- evaluate_as_set(fnc, inps)
  expect_equal(eval, c(1, 2, 3))
})

test_that("evaluate_as_set() works on set-expanded CarDxi/CAR", {
  att <- CarDxi$attrib("CAR")
  fnc <- DexiTabularFunction(att, values = att$funct$values)
  fnc$values[[1]] <- c(1,2)

  inps <- list(1, 1)
  eval <- evaluate_as_set(fnc, inps)
  expect_equal(eval, c(1, 2))

  inps <- list(2, 2)
  eval <- evaluate_as_set(fnc, inps)
  expect_equal(eval, 2)

  inps <- list(c(3, 1), c(4, 1))
  eval <- evaluate_as_set(fnc, inps)
  expect_equal(eval, c(1, 2, 4))
})

test_that("evaluate_as_distribution(method = 'prob') works on CarDxi/CAR", {
  att <- CarDxi$attrib("CAR")
  fnc <- att$funct
  eval_param <- evaluation_parameters("prob")

  inps <- list(distribution(1), c(1))
  eval <- evaluate_as_distribution(fnc, inps, eval_param)
  expect_equal(eval, distribution(1, 0, 0, 0))

  inps <- list(distribution(1, 0, 1), c(1))
  eval <- evaluate_as_distribution(fnc, inps, eval_param)
  expect_equal(eval, distribution(2, 0, 0, 0))

  inps <- list(distribution(0.1, 0.3, 0.6), c(0.1, 0.2, 0.3, 0.4))
  eval <- evaluate_as_distribution(fnc, inps, eval_param)
  expect_equal(eval, distribution(0.19, 0.06, 0.21, 0.54))
})

test_that("evaluate_as_distribution(method = 'fuzzy') works on CarDxi/CAR", {
  att <- CarDxi$attrib("CAR")
  fnc <- att$funct
  eval_param <- evaluation_parameters("fuzzy")

  inps <- list(distribution(1), c(1))
  eval <- evaluate_as_distribution(fnc, inps, eval_param)
  expect_equal(eval, distribution(1, 0, 0, 0))

  inps <- list(distribution(1, 0, 1), c(1))
  eval <- evaluate_as_distribution(fnc, inps, eval_param)
  expect_equal(eval, distribution(1, 0, 0, 0))

  inps <- list(distribution(0.1, 0.3, 0.6), c(0.1, 0.2, 0.3, 0.4))
  eval <- evaluate_as_distribution(fnc, inps, eval_param)
  expect_equal(eval, distribution(0.1, 0.2, 0.3, 0.4))

  inps <- list(distribution(0.2, 0.4, 1), c(0.1, 0.5, 0.7, 1))
  eval <- evaluate_as_distribution(fnc, inps, eval_param)
  expect_equal(eval, distribution(0.2, 0.4, 0.5, 1))
})

test_that("evaluate_as_distribution(method = 'prob') works on set-expanded CarDxi/CAR", {
  att <- CarDxi$attrib("CAR")
  fnc <- DexiTabularFunction(att, values = att$funct$values)
  fnc$values[[1]] <- c(1, 2)
  fnc$values[[2]] <- c(2, 3)

  eval_param <- evaluation_parameters("prob")

  inps <- list(distribution(1), c(1))
  eval <- evaluate_as_distribution(fnc, inps, eval_param)
  expect_equal(eval, distribution(0.5, 0.5, 0, 0))

  inps <- list(distribution(1, 0, 1), c(1))
  eval <- evaluate_as_distribution(fnc, inps, eval_param)
  expect_equal(eval, distribution(1.5, 0.5, 0, 0))

  inps <- list(distribution(0.1, 0.3, 0.6), c(0.1, 0.2, 0.3, 0.4))
  eval <- evaluate_as_distribution(fnc, inps, eval_param)
  expect_equal(eval, distribution(0.155, 0.08, 0.225, 0.54))
})

test_that("Plain evaluation of CarDxi", {
  alts0 <- CarDxi$alternatives
  alts <- alts0
  alts[, CarDxi$aggregate_ids] <- NA
  eval <- evaluate(CarDxi, alts)
  expect_equal(unlist(alts0[1,]), unlist(eval[1,]))
  expect_equal(unlist(alts0[2,]), unlist(eval[2,]))
  expect_true(all(unlist(alts0[1,]) == unlist(eval[1,])))
  expect_false(all(unlist(alts0[1,]) == unlist(eval[2,])))
})

test_that("Plain pruned evaluation of CarDxi", {
  alts0 <- CarDxi$alternatives
  alts <- alts0
  eval <- evaluate(CarDxi, alts, prune = "PRICE")
  unchanged <- c("name", "CAR", "PRICE", "TECH.CHAR.", "COMFORT", "X.PERS", "X.DOORS", "LUGGAGE", "SAFETY")
  expect_equal(unlist(alts0[1, unchanged]), unlist(eval[1, unchanged]))
  expect_equal(unlist(alts0[2, unchanged]), unlist(eval[2, unchanged]))
  expect_true(all(is.na(eval[(c("BUY.PRICE","MAINT.PRICE"))])))
})

test_that("Set evaluation of CarDxi", {
  alt0 <- CarDxi$alternatives[1,]
  alt <- set_alternative(CarDxi, alt0, BUY.PRICE="*")
  alt[, CarDxi$aggregate_ids] <- NA
  eval <- evaluate(CarDxi, alt)
  unchanged <- c("MAINT.PRICE", "TECH.CHAR.", "COMFORT", "X.PERS", "X.DOORS", "LUGGAGE", "SAFETY")
  expect_equal(unlist(alt0[1, unchanged]), unlist(eval[1, unchanged]))
  expect_equal(eval[1, "BUY.PRICE"], list(c(1,2,3)))
  expect_equal(unname(unlist(eval[1, "PRICE"])), c(1,3))
  expect_equal(unname(unlist(eval[1, "CAR"])), c(1,4))

  alt0 <- CarDxi$alternatives[2,]
  alt <- set_alternative(CarDxi, alt0, SAFETY="*")
  alt[, CarDxi$aggregate_ids] <- NA
  eval <- evaluate(CarDxi, alt)
  unchanged <- c("PRICE", "BUY.PRICE", "MAINT.PRICE", "COMFORT", "X.PERS", "X.DOORS", "LUGGAGE")
  expect_equal(unlist(alt0[1, unchanged]), unlist(eval[1, unchanged]))
  expect_equal(eval[1, "SAFETY"], list(c(1,2,3)))
  expect_equal(unname(unlist(eval[1, "TECH.CHAR."])), c(1,3,4))
  expect_equal(unname(unlist(eval[1, "CAR"])), c(1,3,4))

  alt0 <- CarDxi$alternatives[2,]
  alt <- set_alternative(CarDxi, alt0, SAFETY=c(2,3))
  alt[, CarDxi$aggregate_ids] <- NA
  eval <- evaluate(CarDxi, alt)
  unchanged <- c("PRICE", "BUY.PRICE", "MAINT.PRICE", "COMFORT", "X.PERS", "X.DOORS", "LUGGAGE")
  expect_equal(unlist(alt0[1, unchanged]), unlist(eval[1, unchanged]))
  expect_equal(eval[1, "SAFETY"], list(c(2,3)))
  expect_equal(unname(unlist(eval[1, "TECH.CHAR."])), c(3,4))
  expect_equal(unname(unlist(eval[1, "CAR"])), c(3,4))
})

test_that("Prob evaluation of CarDxi", {
  alt0 <- CarDxi$alternatives[1,]
  alt <- set_alternative(CarDxi, alt0, BUY.PRICE="*")
  alt[, CarDxi$aggregate_ids] <- NA
  eval <- evaluate(CarDxi, alt, method = "prob")
  unchanged <- c("MAINT.PRICE", "X.PERS", "X.DOORS", "LUGGAGE", "SAFETY")
  expect_equal(unlist(alt0[1, unchanged]), unlist(eval[1, unchanged]))
  expect_equal(eval[[1, "BUY.PRICE"]], c(1,2,3))
  expect_equal(eval[[1, "TECH.CHAR."]], distribution(0, 0, 0, 1))
  expect_equal(eval[[1, "COMFORT"]], distribution(0, 0, 1))
  expect_equal(eval[[1, "PRICE"]], distribution(1/3, 0, 2/3))
  expect_equal(eval[[1, "CAR"]], distribution(1/3, 0, 0, 2/3))

  alt0 <- CarDxi$alternatives[2,]
  alt <- set_alternative(CarDxi, alt0, SAFETY="*")
  alt[, CarDxi$aggregate_ids] <- NA
  eval <- evaluate(CarDxi, alt, method = "prob")
  unchanged <- c("BUY.PRICE", "MAINT.PRICE", "X.PERS", "X.DOORS", "LUGGAGE")
  expect_equal(unlist(alt0[1, unchanged]), unlist(eval[1, unchanged]))
  expect_equal(eval[[1, "SAFETY"]], c(1,2,3))
  expect_equal(eval[[1, "COMFORT"]], distribution(0, 0, 1))
  expect_equal(eval[[1, "TECH.CHAR."]], distribution(1/3, 0, 1/3, 1/3))
  expect_equal(eval[[1, "CAR"]], distribution(1/3, 0, 1/3, 1/3))

  alt0 <- CarDxi$alternatives[2,]
  alt <- set_alternative(CarDxi, alt0, SAFETY=c(2,3))
  alt[, CarDxi$aggregate_ids] <- NA
  eval <- evaluate(CarDxi, alt, method = "prob")
  unchanged <- c("BUY.PRICE", "MAINT.PRICE", "X.PERS", "X.DOORS", "LUGGAGE")
  expect_equal(unlist(alt0[1, unchanged]), unlist(eval[1, unchanged]))
  expect_equal(eval[[1, "SAFETY"]], c(2,3))
  expect_equal(eval[[1, "COMFORT"]], distribution(0, 0, 1))
  expect_equal(eval[[1, "TECH.CHAR."]], distribution(0, 0, 1/2, 1/2))
  expect_equal(eval[[1, "CAR"]], distribution(0, 0, 1/2, 1/2))
})

test_that("Fuzzy~norm evaluation of CarDxi", {
  alt0 <- CarDxi$alternatives[1,]
  alt <- set_alternative(CarDxi, alt0, BUY.PRICE="*")
  alt[, CarDxi$aggregate_ids] <- NA
  eval <- evaluate(CarDxi, alt, method = "fuzzy")
  unchanged <- c("MAINT.PRICE", "X.PERS", "X.DOORS", "LUGGAGE", "SAFETY")
  expect_equal(unlist(alt0[1, unchanged]), unlist(eval[1, unchanged]))
  expect_equal(eval[[1, "BUY.PRICE"]], c(1,2,3))
  expect_equal(eval[[1, "TECH.CHAR."]], distribution(0, 0, 0, 1))
  expect_equal(eval[[1, "COMFORT"]], distribution(0, 0, 1))
  expect_equal(eval[[1, "PRICE"]], distribution(1, 0, 1))
  expect_equal(eval[[1, "CAR"]], distribution(1, 0, 0, 1))

  alt0 <- CarDxi$alternatives[2,]
  alt <- set_alternative(CarDxi, alt0, SAFETY="*")
  alt[, CarDxi$aggregate_ids] <- NA
  eval <- evaluate(CarDxi, alt, method = "fuzzy")
  unchanged <- c("BUY.PRICE", "MAINT.PRICE", "X.PERS", "X.DOORS", "LUGGAGE")
  expect_equal(unlist(alt0[1, unchanged]), unlist(eval[1, unchanged]))
  expect_equal(eval[[1, "SAFETY"]], c(1,2,3))
  expect_equal(eval[[1, "COMFORT"]], distribution(0, 0, 1))
  expect_equal(eval[[1, "TECH.CHAR."]], distribution(1, 0, 1, 1))
  expect_equal(eval[[1, "CAR"]], distribution(1, 0, 1, 1))

  alt0 <- CarDxi$alternatives[2,]
  alt <- set_alternative(CarDxi, alt0, SAFETY=c(2,3))
  alt[, CarDxi$aggregate_ids] <- NA
  eval <- evaluate(CarDxi, alt, method = "fuzzy")
  unchanged <- c("BUY.PRICE", "MAINT.PRICE", "X.PERS", "X.DOORS", "LUGGAGE")
  expect_equal(unlist(alt0[1, unchanged]), unlist(eval[1, unchanged]))
  expect_equal(eval[[1, "SAFETY"]], c(2,3))
  expect_equal(eval[[1, "COMFORT"]], distribution(0, 0, 1))
  expect_equal(eval[[1, "TECH.CHAR."]], distribution(0, 0, 1, 1))
  expect_equal(eval[[1, "CAR"]], distribution(0, 0, 1, 1))

  alt0 <- CarDxi$alternatives[2,]
  alt <- set_alternative(CarDxi, alt0, SAFETY=distribution(0, 0.2, 0.5))
  alt[, CarDxi$aggregate_ids] <- NA
  eval <- evaluate(CarDxi, alt, method = "fuzzy")
  unchanged <- c("BUY.PRICE", "MAINT.PRICE", "X.PERS", "X.DOORS", "LUGGAGE")
  expect_equal(unlist(alt0[1, unchanged]), unlist(eval[1, unchanged]))
  expect_equal(eval[[1, "SAFETY"]], distribution(0, 0.2, 0.5))
  expect_equal(eval[[1, "COMFORT"]], distribution(0, 0, 1))
  expect_equal(eval[[1, "TECH.CHAR."]], distribution(0, 0, 0.2, 0.5))
  expect_equal(eval[[1, "CAR"]], distribution(0, 0, 0.2, 0.5))

  alt0 <- CarDxi$alternatives[2,]
  alt <- set_alternative(CarDxi, alt0, SAFETY=distribution(0, 0.2, 0.5))
  alt[, CarDxi$aggregate_ids] <- NA
  eval <- evaluate(CarDxi, alt, method = "fuzzynorm")
  unchanged <- c("BUY.PRICE", "MAINT.PRICE", "X.PERS", "X.DOORS", "LUGGAGE")
  expect_equal(unlist(alt0[1, unchanged]), unlist(eval[1, unchanged]))
  expect_equal(eval[[1, "SAFETY"]], distribution(0, 0.4, 1))
  expect_equal(eval[[1, "COMFORT"]], distribution(0, 0, 1))
  expect_equal(eval[[1, "TECH.CHAR."]], distribution(0, 0, 0.4, 1))
  expect_equal(eval[[1, "CAR"]], distribution(0, 0, 0.4, 1))
})

test_that("evaluate_attribute works on discrete scales", {
  alt <- CarDxi$alternative("MyCar", BUY.PRICE="low", MAINT.PRICE=2, X.PERS="more", X.DOORS="4", LUGGAGE=2, SAFETY="medium")
  rootid <- CarDxi$attrib("CAR")$id
  safety <- CarDxi$attrib("SAFETY")
  eval <- evaluate_attribute(CarDxi, safety, alt)
  expect_equal(length(eval), 3)
  expect_equal(names(eval), c("small", "medium", "high"))
  expect_equal(eval[[1]][[1, rootid]], 1)
  expect_equal(eval[[2]][[1, rootid]], 4)
  expect_equal(eval[[3]][[1, rootid]], 4)

  maint <- CarDxi$attrib("MAINT.PRICE")
  eval <- evaluate_attribute(CarDxi, maint, alt)
  expect_equal(length(eval), 3)
  expect_equal(names(eval), c("high", "medium", "low"))
  expect_equal(eval[[1]][[1, rootid]], 1)
  expect_equal(eval[[2]][[1, rootid]], 4)
  expect_equal(eval[[3]][[1, rootid]], 4)
})

test_that("evaluate_attribute works on continuous scales", {
  alt <- ContinuousNewDxi$alternatives[ContinuousNewDxi$alternatives$name == "Test3",]
  cat("Alt\n")
  rootid <- ContinuousNewDxi$attrib("OneLevel")$id
  n2 <- ContinuousNewDxi$attrib("N2")
  eval <- evaluate_attribute(ContinuousNewDxi, n2, alt, seq=seq(-2, 2, 0.5))
  expect_equal(length(eval), 9)
  expect_equal(names(eval), c("-2", "-1.5", "-1", "-0.5", "0", "0.5", "1", "1.5", "2"))
  expect_equal(eval[[1]][[1, rootid]], 1)
  expect_equal(eval[[2]][[1, rootid]], 1)
  expect_equal(eval[[3]][[1, rootid]], c(1,2))
  expect_equal(eval[[4]][[1, rootid]], c(1,2))
  expect_equal(eval[[5]][[1, rootid]], c(1,2))
  expect_equal(eval[[6]][[1, rootid]], c(1,2))
  expect_equal(eval[[7]][[1, rootid]], c(1,2))
  expect_equal(eval[[8]][[1, rootid]], 3)
  expect_equal(eval[[9]][[1, rootid]], 3)
})

test_that("attribute_effect works", {
  alt <- CarDxi$alternative("MyCar", BUY.PRICE="low", MAINT.PRICE=2, X.PERS="more", X.DOORS="4", LUGGAGE=2, SAFETY=c("medium", "high"))
  eval <- attribute_effect(CarDxi, "LUGGAGE", alt)
  expect_equal(length(eval), 3)
  expect_equal(eval[[1]], 1)
  expect_equal(eval[[2]], 4)
  expect_equal(eval[[3]], 4)

  eval <- attribute_effect(CarDxi, "LUGGAGE", alt, "TECH.CHAR.")
  expect_equal(length(eval), 3)
  expect_equal(eval[[1]], 1)
  expect_equal(eval[[2]], c(3,4))
  expect_equal(eval[[3]], c(3,4))
})

#' # Load "Car.dxi"
#' CarDxi <- system.file("extdata", "Car.dxi", package = "DEXiR")
#' Car <- read_dexi(CarDxi)
#'
# # Define some decision alternative (a car in this case) and evaluate it using default parameters
#' alt <- Car$alternative("MyCar",
#'          BUY.PRICE="low", MAINT.PRICE=2, X.PERS="more", X.DOORS="4", LUGGAGE=2, SAFETY="medium")
#' # Determine the effect of changing "SAFETY" balues on "CAR.1"
#' attribute_effect(Car, "SAFETY", alt)
#' # Returns a list of "CAR.1" values corresponding to consecutive values of "SAFETY"
#' attribute_effect(Car, "LUGGAGE", alt, "TECH.CHAR.")
#' # Returns a list of "TECH.CHAR." values corresponding to consecutive values of "LUGGAGE"

test_that("evaluate_attributes works", {
  alt <- CarDxi$alternative("MyCar", BUY.PRICE="low", MAINT.PRICE=2, X.PERS="more", X.DOORS="4", LUGGAGE=2, SAFETY="medium")
  eval <- evaluate_attributes(CarDxi, alt)
  expect_equal(length(eval), length(CarDxi$basic))
})

test_that("Plain evaluation of LinkedDxi", {
  alts0 <- LinkedDxi$alternatives
  alts <- alts0
  alts[, LinkedDxi$aggregate_ids] <- NA
  eval <- evaluate(LinkedDxi, alts)
  for (i in 1:nrow(alts0)) {
    expect_equal(unlist(alts0[i,]), unlist(eval[i,]))
  }
})

test_that("Plain evaluation of ContinuousNewDxi", {
  alts0 <- ContinuousNewDxi$alternatives
  alts <- alts0
  alts[, ContinuousNewDxi$aggregate_ids] <- NA
  eval <- evaluate(ContinuousNewDxi, alts)
  expect_identical(eval,
    structure(list(name = list("Null/Null", "Null/All", "Test1",
      "Test2", "Test3", "Test4", "Test5", "Test6", "Test7"),
      OneLevel = list(NA, NA, 1L, 1:2, 3L, 2:3, 3L, 3L, 1:2),
      X1 = list(NA, NA,  1, 1, 1, 2, 2, 2, 1),
      N1 = list(NA, NA, -2, -2, -2, 2, 2, 2, 0),
      X2 = list(NA, NA, 1, 2, 3, 1, 2, 3, 2),
      N2 = list(NA, NA, -2, 0, 2, -2, 0, 2, 0)),
      row.names = c(NA, -9L), class = "data.frame"))
})

test_that("Plain evaluation of DozenDxi", {
  alts0 <- DozenDxi$alternatives
  alts <- alts0
  alts[, DozenDxi$aggregate_ids] <- NA
  alts[is.na(alts)] <- "*"
  eval <- evaluate(DozenDxi, alts)
  expect_equal(alts0[, DozenDxi$aggregate_ids], eval[, DozenDxi$aggregate_ids])
})