tests/testthat/test_utils.R

In pmml: Generate PMML for Various Models

rn <- .pmmlRootNode()

test_that("version attribute in PMML root node has value 4.4.1", {
  expect_equal(xmlGetAttr(rn, name = "version"), "4.4.1")
})

test_that("xsi:schemaLocation in PMML root node points to pmml-4-4", {
  expect_equal(
    xmlGetAttr(rn, name = "xsi:schemaLocation"),
    "http://www.dmg.org/PMML-4_4 http://www.dmg.org/pmml/v4-4/pmml-4-4.xsd"
  )
})

test_that(".pmmlLocalTransformations sets dataType and optype provided in transforms", {
  iris_box_1 <- xform_wrap(iris)
  iris_box_1 <- xform_function(
    wrap_object = iris_box_1,
    orig_field_name = "Sepal.Length",
    new_field_name = "Sepal.Length.Transformed",
    new_field_data_type = "factor",
    expression = "Sepal.Length * 0.1"
  )

  iris_box_1 <- xform_function(
    wrap_object = iris_box_1,
    orig_field_name = "Sepal.Width",
    new_field_name = "Sepal.Width.Transformed",
    new_field_data_type = "numeric",
    expression = "Sepal.Width + 3.5"
  )

  fit_1 <- lm(Petal.Length ~ Sepal.Length.Transformed + Sepal.Width.Transformed,
    data = iris_box_1$data
  )
  fit_pmml_1 <- pmml(fit_1, transforms = iris_box_1)

  expect_equal(xmlGetAttr(fit_pmml_1[[3]][[3]][[1]], name = "dataType"), "string")
  expect_equal(xmlGetAttr(fit_pmml_1[[3]][[3]][[1]], name = "optype"), "categorical")
  expect_equal(xmlGetAttr(fit_pmml_1[[3]][[3]][[2]], name = "dataType"), "double")
  expect_equal(xmlGetAttr(fit_pmml_1[[3]][[3]][[2]], name = "optype"), "continuous")
})

test_that(".pmmlLocalTransformationsAD sets dataType and optype provided in transforms", {
  # .pmmlLocalTransformationsAD is only used by pmml.svm(). e1071::svm()
  # requires training data to be numeric.

  skip_if_not_installed("e1071")
  library(e1071)
  iris_box_1 <- xform_wrap(iris[, 1:4])
  iris_box_1 <- xform_function(
    wrap_object = iris_box_1,
    orig_field_name = "Sepal.Length",
    new_field_name = "Sepal.Length.Transformed",
    new_field_data_type = "numeric",
    expression = "Sepal.Length * 0.1"
  )

  iris_box_1 <- xform_function(
    wrap_object = iris_box_1,
    orig_field_name = "Sepal.Width",
    new_field_name = "Sepal.Width.Transformed",
    new_field_data_type = "numeric",
    expression = "Sepal.Width + 3.5"
  )

  fit_1 <- svm(x = iris_box_1$data[, 5:6], y = NULL, type = "one-classification")

  fit_pmml_1 <- pmml(fit_1, dataset = iris_box_1$data[, 5:6], transforms = iris_box_1)

  expect_equal(xmlGetAttr(fit_pmml_1[[3]][[3]][[3]][[1]], name = "dataType"), "double")
  expect_equal(xmlGetAttr(fit_pmml_1[[3]][[3]][[3]][[1]], name = "optype"), "continuous")
  expect_equal(xmlGetAttr(fit_pmml_1[[3]][[3]][[3]][[2]], name = "dataType"), "double")
  expect_equal(xmlGetAttr(fit_pmml_1[[3]][[3]][[3]][[2]], name = "optype"), "continuous")
})


test_that(".pmmlHeader() adds modelVersion attribute when model_version is not NULL", {
  header <- .pmmlHeader(
    description = "Test model", copyright = NULL,
    model_version = "someVersion", app_name = "App Name"
  )
  expect_equal(xmlGetAttr(header, name = "modelVersion"), "someVersion")

  header2 <- .pmmlHeader(
    description = "Test model", copyright = NULL,
    model_version = c("someVersion"), app_name = "App Name"
  )
  expect_equal(xmlGetAttr(header2, name = "modelVersion"), "someVersion")
})

test_that(".pmmlHeader() does not add modelVersion attribute when model_version is NULL", {
  header <- .pmmlHeader(
    description = "Test model", copyright = NULL,
    model_version = NULL, app_name = "App Name"
  )
  # XML::xmlNode does not add an attribute if its value is NULL
  expect_equal(xmlGetAttr(header, name = "modelVersion"), NULL)
})

test_that(".pmmlHeader() errors if model_version is not a character vector of length 1", {
  expect_error(
    .pmmlHeader(
      description = "Test model", copyright = NULL,
      model_version = 123, app_name = "App Name"
    ),
    'model_version must be of type "character" and of length 1.'
  )

  expect_error(
    .pmmlHeader(
      description = "Test model", copyright = NULL,
      model_version = c(1, 2, 3), app_name = "App Name"
    ),
    'model_version must be of type "character" and of length 1.'
  )

  expect_error(
    .pmmlHeader(
      description = "Test model", copyright = NULL,
      model_version = c("adf", 1), app_name = "App Name"
    ),
    'model_version must be of type "character" and of length 1.'
  )

  expect_error(
    .pmmlHeader(
      description = "Test model", copyright = NULL,
      model_version = c("adf", "asdf"), app_name = "App Name"
    ),
    'model_version must be of type "character" and of length 1.'
  )
  # >>>>>>> master
})