tests/testthat/helper-test-GLM.R

In gofreg: Bootstrap-Based Goodness-of-Fit Tests for Parametric Regression

expect_params_range <- function(params_est, params_true, tol) {
  params_est_unlist <- unlist(params_est, use.names = FALSE)
  params_true_unlist <- unlist(params_true, use.names = FALSE)
  q <- length(params_est_unlist)
  for (i in 1:q) {
    expect_lt(params_est_unlist[i], params_true_unlist[i] + tol)
    expect_gt(params_est_unlist[i], params_true_unlist[i] - tol)
  }
}

test_glm_fF1_yx <- function(distr, params, new.params, t, p, true_vals) {
  g1 <- function(u) {
    1 / u
  }
  x <- rbind(c(1, 2, 3), c(4, 5, 6))

  # create model
  model <- GLM.new(distr = distr, linkinv = g1)

  # no parameters specified (nor saved yet)
  expect_error(model$f_yx(t, x))
  expect_error(model$F_yx(t, x))
  expect_error(model$F1_yx(p, x))

  # wrong shape of parameters
  expect_error(model$f_yx(t, x, params = list(useless_param = 3)))
  expect_error(model$F_yx(t, x, params = list(useless_param = 3)))
  expect_error(model$F1_yx(p, x, params = list(useless_param = 3)))

  # use saved parameters
  model$set_params(params)

  # print(model$f_yx(t, x))

  tv <- true_vals(t, p, x, g1, params)

  expect_equal(model$f_yx(t, x), tv$dens)
  expect_equal(model$F_yx(t, x), tv$dist)
  expect_equal(model$F1_yx(p, x), tv$quan)

  tv <- true_vals(t, p, x, g1, new.params)

  # use new parameters if specified
  expect_equal(model$f_yx(t, x, new.params), tv$dens)
  expect_equal(model$F_yx(t, x, new.params), tv$dist)
  expect_equal(model$F1_yx(p, x, new.params), tv$quan)
}

test_glm_sample_yx <- function(distr, params, new.params, expected_sample) {
  g1 <- function(u) {
    1 / u
  }
  x <- rbind(c(1, 2, 3), c(4, 5, 6))

  # create model
  model <- GLM.new(distr, g1)

  # no parameters specified (nor saved yet)
  expect_error(model$sample_yx(x))

  # wrong shape of parameters
  expect_error(model$sample_yx(x, params = list(useless_param = 3)))

  # use saved parameters
  model$set_params(params)
  set.seed(123)
  s1 <- model$sample_yx(x)
  # print(s1)
  set.seed(123)
  s2 <- expected_sample(x, g1, params)
  expect_equal(s1, s2)

  # use new parameters if specified
  set.seed(123)
  s1 <- model$sample_yx(x, new.params)
  set.seed(123)
  s2 <- expected_sample(x, g1, new.params)
  expect_equal(s1, s2)
}

test_glm_fit <- function(distr, params_true, params_error, tol, multi, cens = FALSE) {
  set.seed(123)

  dummy_model_func <- "dummy_"

  # with or without censoring
  if (cens) {
    dummy_model_func <- paste0(dummy_model_func, "xzdmodel_")
    loglik <- loglik_xzd
  } else {
    dummy_model_func <- paste0(dummy_model_func, "xymodel_")
    loglik <- loglik_xy
  }

  # univariate or multidimensional covariates x
  if (multi) {
    dummy_model_func <- paste0(dummy_model_func, "x3")
  } else {
    dummy_model_func <- paste0(dummy_model_func, "x1")
  }

  # create data and model
  dummy <- do.call(dummy_model_func, args = list(params_true = params_true, distr = distr))
  data <- dummy$data
  model <- dummy$model

  # no initial parameter values
  expect_error(model$fit(data, loglik = loglik))

  # wrong shape of initial parameters
  expect_error(model$fit(data, params_init = list(useless_param = 3), loglik = loglik))

  # print( model$f_yx(data$z[data$delta == 1], as.matrix(data[data$delta == 1, "x"]), params_error) )
  # print( 1 - model$F_yx(data$z[data$delta == 0], as.matrix(data[data$delta == 0, "x"]), params_error) )

  # non-feasible initial parameter values
  expect_error(model$fit(data, params_init = params_error, loglik = loglik))

  # estimated parameters are close to true values
  params_est <- model$fit(data, params_init = params_true, loglik = loglik)

  expect_params_range(params_est, params_true, tol)

  # by default, fit does not set model parameters
  expect(is.na(model$get_params()), "Model parameters should not be defined yet.")

  # model parameters are set if inplace=TRUE
  model$fit(data, params_init = params_true, inplace = TRUE, loglik = loglik)
  expect_equal(model$get_params(), params_est)
}