tests/testthat/test_node.r

In simDAG: Simulate Data from a DAG and Associated Node Information

#### testing root nodes output

test_that("root: accepts built-in function in type", {
  expected <- list(name="C",
                   type_str="rbernoulli",
                   type_fun=rbernoulli,
                   parents=NULL,
                   time_varying=FALSE,
                   params=list())
  class(expected) <- "DAG.node"

  out <- node("C", rbernoulli, NULL)
  expect_equal(out, expected)
})

test_that("root: accepts custom function in type", {

  rtesting <- function(n) {
    return(n)
  }

  expected <- list(name="C",
                   type_str="rtesting",
                   type_fun=rtesting,
                   parents=NULL,
                   time_varying=FALSE,
                   params=list())
  class(expected) <- "DAG.node"

  out <- node("C", rtesting, NULL)
  expect_equal(out, expected)
})

test_that("root: all positional, no additional", {
  expected <- list(name="C",
                   type_str="rbernoulli",
                   type_fun=rbernoulli,
                   parents=NULL,
                   time_varying=FALSE,
                   params=list())
  class(expected) <- "DAG.node"

  out <- node("C", "rbernoulli", NULL)
  expect_equal(out, expected)
})

test_that("root: multiple names, all positional, no additional", {
  expected <- list(list(name="C",
                   type_str="rbernoulli",
                   type_fun=rbernoulli,
                   parents=NULL,
                   time_varying=FALSE,
                   params=list()),
                   list(name="D",
                        type_str="rbernoulli",
                        type_fun=rbernoulli,
                        parents=NULL,
                        time_varying=FALSE,
                        params=list()))
  class(expected[[1]]) <- "DAG.node"
  class(expected[[2]]) <- "DAG.node"
  class(expected) <- "DAG.node"

  out <- node(c("C", "D"), "rbernoulli", NULL)
  expect_equal(out, expected)
})

test_that("root: all positional, with additional", {
  expected <- list(name="C",
                   type_str="rbernoulli",
                   type_fun=rbernoulli,
                   parents=NULL,
                   time_varying=FALSE,
                   params=list(p=0.5))
  class(expected) <- "DAG.node"

  out <- node("C", "rbernoulli", NULL, p=0.5)
  expect_equal(out, expected)
})

test_that("root: no positional, no additional", {
  expected <- list(name="C",
                   type_str="rbernoulli",
                   type_fun=rbernoulli,
                   parents=NULL,
                   time_varying=FALSE,
                   params=list())
  class(expected) <- "DAG.node"

  # specifying parents
  out <- node(name="C", type="rbernoulli", parents=NULL)
  expect_equal(out, expected)

  # not specifying parents
  out <- node(name="C", type="rbernoulli")
  expect_equal(out, expected)
})

test_that("root: no positional, with additional", {
  expected <- list(name="C",
                   type_str="rbernoulli",
                   type_fun=rbernoulli,
                   parents=NULL,
                   time_varying=FALSE,
                   params=list(p=0.5))
  class(expected) <- "DAG.node"

  # specifying parents
  out <- node(name="C", parents=NULL, type="rbernoulli", p=0.5)
  expect_equal(out, expected)

  # not specifying parents
  out <- node(name="C", type="rbernoulli", p=0.5)
  expect_equal(out, expected)
})

test_that("root: name positional, rest named, no additional", {
  expected <- list(name="C",
                   type_str="rbernoulli",
                   type_fun=rbernoulli,
                   parents=NULL,
                   time_varying=FALSE,
                   params=list())
  class(expected) <- "DAG.node"

  # specifying parents
  out <- node("C", parents=NULL, type="rbernoulli")
  expect_equal(out, expected)

  # not specifying parents
  out <- node("C", type="rbernoulli")
  expect_equal(out, expected)
})

test_that("root: name positional, rest named, with additional", {
  expected <- list(name="C",
                   type_str="rbernoulli",
                   type_fun=rbernoulli,
                   parents=NULL,
                   time_varying=FALSE,
                   params=list(p=0.5))
  class(expected) <- "DAG.node"

  # specifying parents
  out <- node("C", parents=NULL, type="rbernoulli", p=0.5)
  expect_equal(out, expected)

  # not specifying parents
  out <- node("C", type="rbernoulli", p=0.5)
  expect_equal(out, expected)
})


#### testing child nodes output

test_that("child: accepts built-in function in type", {
  expected <- list(name="C",
                   type_str="binomial",
                   type_fun=node_binomial,
                   parents=c("A", "B"),
                   time_varying=FALSE,
                   betas=c(1, 2),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node("C", node_binomial, c("A", "B"), betas=c(1, 2), intercept=-10,
              p=0.1)
  expect_equal(out, expected)
})

test_that("child: accepts custom function in type", {

  some_test_fun <- function(data, parents) {
    return("ay")
  }

  expected <- list(name="C",
                   type_str="some_test_fun",
                   type_fun=some_test_fun,
                   parents=c("A", "B"),
                   time_varying=FALSE,
                   betas=c(1, 2),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node("C", some_test_fun, c("A", "B"), betas=c(1, 2), intercept=-10,
              p=0.1)
  expect_equal(out, expected)
})

test_that("child: all positional", {
  expected <- list(name="C",
                   type_str="binomial",
                   type_fun=node_binomial,
                   parents=c("A", "B"),
                   time_varying=FALSE,
                   betas=c(1, 2),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node("C", "binomial", c("A", "B"), betas=c(1, 2), intercept=-10,
              p=0.1)
  expect_equal(out, expected)
})

test_that("child: multiple, all positional", {
  expected <- list(list(name="C",
                        type_str="binomial",
                        type_fun=node_binomial,
                        parents=c("A", "B"),
                        time_varying=FALSE,
                        betas=c(1, 2),
                        intercept=-10,
                        p=0.1),
                   list(name="D",
                        type_str="binomial",
                        type_fun=node_binomial,
                        parents=c("A", "B"),
                        time_varying=FALSE,
                        betas=c(1, 2),
                        intercept=-10,
                        p=0.1))
  class(expected[[1]]) <- "DAG.node"
  class(expected[[2]]) <- "DAG.node"
  class(expected) <- "DAG.node"

  out <- node(c("C", "D"), "binomial", c("A", "B"), betas=c(1, 2),
              intercept=-10, p=0.1)
  expect_equal(out, expected)
})

test_that("child: all positional with formula", {
  expected <- list(name="C",
                   type_str="binomial",
                   type_fun=node_binomial,
                   parents=c("A", "B"),
                   time_varying=FALSE,
                   formula=~ A + B,
                   betas=c(1, 2),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node("C", "binomial", NULL, ~ A + B, betas=c(1, 2),
              intercept=-10, p=0.1)
  expect_equal(out, expected, ignore_formula_env=TRUE)
})

test_that("child: only name positional", {
  expected <- list(name="C",
                   type_str="binomial",
                   type_fun=node_binomial,
                   parents=c("A", "B"),
                   time_varying=FALSE,
                   betas=c(1, 2),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node("C", type="binomial", parents=c("A", "B"), betas=c(1, 2),
              intercept=-10, p=0.1)
  expect_equal(out, expected)
})

test_that("child: only name positional with formula", {
  expected <- list(name="C",
                   type_str="binomial",
                   type_fun=node_binomial,
                   parents=c("A", "B"),
                   time_varying=FALSE,
                   formula=~ A + B + I(A^2),
                   betas=c(1, 2, 3),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node("C", type="binomial", parents=c("A", "B"),
              formula=~ A + B + I(A^2), betas=c(1, 2, 3),
              intercept=-10, p=0.1)
  expect_equal(out, expected, ignore_formula_env=TRUE)
})

test_that("child: name & type positional", {
  expected <- list(name="C",
                   type_str="binomial",
                   type_fun=node_binomial,
                   parents=c("A", "B"),
                   time_varying=FALSE,
                   betas=c(1, 2),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node("C", "binomial", parents=c("A", "B"), betas=c(1, 2),
              intercept=-10, p=0.1)
  expect_equal(out, expected)
})

test_that("child: no positional", {
  expected <- list(name="C",
                   type_str="binomial",
                   type_fun=node_binomial,
                   parents=c("A", "B"),
                   time_varying=FALSE,
                   betas=c(1, 2),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node(name="C", type="binomial", parents=c("A", "B"), betas=c(1, 2),
              intercept=-10, p=0.1)
  expect_equal(out, expected)
})

test_that("child: no positional with formula", {
  expected <- list(name="C",
                   type_str="binomial",
                   type_fun=node_binomial,
                   parents=c("A", "B"),
                   time_varying=FALSE,
                   formula=~ A + B + I(A^2),
                   betas=c(1, 2, 3),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node(name="C", type="binomial", parents=NULL,
              formula=~ A + B + I(A^2), betas=c(1, 2, 3),
              intercept=-10, p=0.1)
  expect_equal(out, expected, ignore_formula_env=TRUE)
})

#### testing child nodes output with time-varying=TRUE

test_that("time-varying: accepts built-in fun in type", {
  expected <- list(name="C",
                   type_str="binomial",
                   type_fun=node_binomial,
                   parents=c("A", "B"),
                   time_varying=TRUE,
                   betas=c(1, 2),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node_td("C", node_binomial, c("A", "B"), NULL,
                 betas=c(1, 2), intercept=-10, p=0.1)
  expect_equal(out, expected, ignore_formula_env=TRUE)
})

test_that("time-varying: accepts custom fun in type", {

  custom_fun <- function(data, parents) {
    return("ahh")
  }

  expected <- list(name="C",
                   type_str="custom_fun",
                   type_fun=custom_fun,
                   parents=c("A", "B"),
                   time_varying=TRUE,
                   betas=c(1, 2),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node_td("C", custom_fun, c("A", "B"), NULL,
                 betas=c(1, 2), intercept=-10, p=0.1)
  expect_equal(out, expected, ignore_formula_env=TRUE)
})

test_that("time-varying: all positional", {
  expected <- list(name="C",
                   type_str="binomial",
                   type_fun=node_binomial,
                   parents=c("A", "B"),
                   time_varying=TRUE,
                   formula= ~ A + B,
                   betas=c(1, 2),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node_td("C", "binomial", c("A", "B"), ~ A + B,
                 betas=c(1, 2), intercept=-10, p=0.1)
  expect_equal(out, expected, ignore_formula_env=TRUE)
})

test_that("time-varying: multiple, all positional", {
  expected <- list(list(name="C",
                        type_str="binomial",
                        type_fun=node_binomial,
                        parents=c("A", "B"),
                        time_varying=TRUE,
                        formula= ~ A + B,
                        betas=c(1, 2),
                        intercept=-10,
                        p=0.1),
                   list(name="D",
                        type_str="binomial",
                        type_fun=node_binomial,
                        parents=c("A", "B"),
                        time_varying=TRUE,
                        formula= ~ A + B,
                        betas=c(1, 2),
                        intercept=-10,
                        p=0.1))
  class(expected[[1]]) <- "DAG.node"
  class(expected[[2]]) <- "DAG.node"
  class(expected) <- "DAG.node"

  out <- node_td(c("C", "D"), "binomial", c("A", "B"), ~ A + B,
                 betas=c(1, 2), intercept=-10, p=0.1)
  expect_equal(out, expected, ignore_formula_env=TRUE)
})

test_that("time-varying: only name positional", {
  expected <- list(name="C",
                   type_str="binomial",
                   type_fun=node_binomial,
                   parents=c("A", "B"),
                   time_varying=TRUE,
                   betas=c(1, 2),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node_td("C", type="binomial", parents=c("A", "B"), betas=c(1, 2),
                 intercept=-10, p=0.1)
  expect_equal(out, expected)
})

test_that("time-varying: only name positional with formula", {
  expected <- list(name="C",
                   type_str="binomial",
                   type_fun=node_binomial,
                   parents=c("A", "B"),
                   time_varying=TRUE,
                   formula=~ A + B + I(A^2),
                   betas=c(1, 2, 3),
                   intercept=-10,
                   p=0.1)
  class(expected) <- "DAG.node"

  out <- node_td("C", type="binomial", parents=c("A", "B"),
                 formula=~ A + B + I(A^2), betas=c(1, 2, 3),
                 intercept=-10, p=0.1)
  expect_equal(out, expected, ignore_formula_env=TRUE)
})

test_that("time-varying: no parents", {
  expected <- list(name="C",
                   type_str="time_to_event",
                   type_fun=node_time_to_event,
                   parents=NULL,
                   time_varying=TRUE,
                   prob_fun=0.001)
  class(expected) <- "DAG.node"

  out <- node_td("C", "time_to_event", prob_fun=0.001)
  expect_equal(out, expected, ignore_formula_env=TRUE)
})

test_that("call with only two unnamed arguments", {
  expected <- list(name="C",
                   type_str="rbernoulli",
                   type_fun=rbernoulli,
                   parents=NULL,
                   time_varying=FALSE,
                   params=list())
  class(expected) <- "DAG.node"

  out <- node("C", "rbernoulli")
  expect_equal(out, expected)
})

test_that("call with only two named arguments", {
  expected <- list(name="C",
                   type_str="rbernoulli",
                   type_fun=rbernoulli,
                   parents=NULL,
                   time_varying=FALSE,
                   params=list())
  class(expected) <- "DAG.node"

  out <- node(type="rbernoulli", name="C")
  expect_equal(out, expected)
})

test_that("cubic terms showing up in parents", {
  dag <- empty_dag() +
    node(c("A", "B"), type="rnorm") +
    node("C", type="gaussian", formula= ~ -2 + A*1 + I(B^2)*0.3, error=2)

  expect_equal(dag$child_nodes[[1]]$parents, c("A", "B"))
})

test_that("node: error when name or type missing", {
  expect_error(empty_dag() + node())
  expect_error(empty_dag() + node(name="A"))
  expect_error(empty_dag() + node(type="rbernoulli"))
  expect_error(empty_dag() + node(name="A", betas=c(1, 2), intercept=2,
                                  parents=c("sex", "age"), error=2))
})

test_that("node_td: error when name or type missing", {
  expect_error(empty_dag() + node_td())
  expect_error(empty_dag() + node_td(name="A"))
  expect_error(empty_dag() + node_td(type="rbernoulli"))
  expect_error(empty_dag() + node_td(name="A", betas=c(1, 2), intercept=2,
                                     parents=c("sex", "age"), error=2))
})

test_that("snapshot print node_td", {
  expect_snapshot_output(print(node_td("A", type="time_to_event")))
})