test-extras.R
In SSN2: Spatial Modeling on Stream Networks

copy_lsn_to_temp()
temp_path <- paste0(tempdir(), "/MiddleFork04.ssn")
mf04p <- ssn_import(
  temp_path,
  predpts = c("pred1km"),
  overwrite = TRUE
)

test_that("covariance matrix functions run", {




  ################
  ##### create distance object
  ################

  initial_object_val <- get_initial_object(
    tailup_type = "exponential",
    taildown_type = "exponential",
    euclid_type = "exponential",
    nugget_type = "nugget",
    tailup_initial = NULL,
    taildown_initial = NULL,
    euclid_initial = NULL,
    nugget_initial = NULL
  )

  object <- get_dist_object(
    ssn.object = mf04p,
    initial_object = initial_object_val,
    additive = "afvArea",
    anisotropy = FALSE
  )

  object_anis <- get_dist_object(
    ssn.object = mf04p,
    initial_object = initial_object_val,
    additive = "afvArea",
    anisotropy = TRUE
  )

  ################
  ##### tailup
  ################

  tailup_covs <- c("linear", "spherical", "exponential",
                   "mariah", "epa", "none")
  lapply(tailup_covs, function(x) {
    if (x == "none") {
      params <- tailup_params(x)
      expect_equal(cov_matrix(params, object), 0)
    } else {
      params <- tailup_params(x, de = 1, range = 1)
      expect_equal(dim(cov_matrix(params, object)), c(45, 45))
    }
  })

  ################
  ##### taildown
  ################

  taildown_covs <- c("linear", "spherical", "exponential",
                   "mariah", "epa", "none")
  lapply(taildown_covs, function(x) {
    if (x == "none") {
      params <- taildown_params(x)
      expect_equal(cov_matrix(params, object), 0)
    } else {
      params <- taildown_params(x, de = 1, range = 1)
      expect_equal(dim(cov_matrix(params, object)), c(45, 45))
    }
  })

  ################
  ##### euclid
  ################

  euclid_covs <- c("exponential", "spherical", "gaussian", "cubic",
                    "pentaspherical", "cosine", "wave", "jbessel", "gravity",
                   "rquad", "magnetic", "none")
  lapply(euclid_covs, function(x) {
    if (x == "none") {
      params <- euclid_params(x)
      expect_equal(cov_matrix(params, object), 0)
    } else if (x == "spherical") {
      params <- euclid_params(x, de = 1, range = 1, rotate = 0.5, scale = 0.5)
      expect_equal(dim(cov_matrix(params, object_anis, anisotropy = TRUE)), c(45, 45))
    } else {
      params <- euclid_params(x, de = 1, range = 1, rotate = 0, scale = 1)
      expect_equal(dim(cov_matrix(params, object, anisotropy = FALSE)), c(45, 45))
    }
  })

  ################
  ##### nugget
  ################

  nugget_covs <- c("nugget", "none")
  lapply(nugget_covs, function(x) {
    if (x == "none") {
      params <- nugget_params(x)
      expect_equal(dim(cov_matrix(params, object, de_scale = 1)), c(45, 45))
    } else {
      params <- nugget_params(x, nugget = 1)
      expect_equal(dim(cov_matrix(params, object, de_scale = 1)), c(45, 45))
    }
  })

})

test_that("covariance vector functions run", {



  ssn_mod <- ssn_lm(Summer_mn ~ ELEV_DEM, mf04p,
                    tailup_type = "exponential", taildown_type = "exponential",
                    euclid_type = "exponential", anisotropy = FALSE,
                    random = ~ as.factor(netID), additive = "afvArea",
                    estmethod = "ml", partition_factor = ~ as.factor(netID))

  ssn_mod_anis <- ssn_lm(Summer_mn ~ ELEV_DEM, mf04p,
                         euclid_type = "exponential", anisotropy = TRUE)


  ################
  ##### create distance object
  ################

  initial_object_val <- get_initial_object(
    tailup_type = "exponential",
    taildown_type = "exponential",
    euclid_type = "exponential",
    nugget_type = "nugget",
    tailup_initial = NULL,
    taildown_initial = NULL,
    euclid_initial = NULL,
    nugget_initial = NULL
  )

  object <- get_dist_pred_object(
    object = ssn_mod,
    newdata_name = "pred1km",
    initial_object = initial_object_val
  )

  initial_object_val <- get_initial_object(
    tailup_type = "none",
    taildown_type = "none",
    euclid_type = "exponential",
    nugget_type = "nugget",
    tailup_initial = NULL,
    taildown_initial = NULL,
    euclid_initial = NULL,
    nugget_initial = NULL
  )

  object_anis <- get_dist_pred_object(
    object = ssn_mod_anis,
    newdata_name = "pred1km",
    initial_object = initial_object_val
  )


  ################
  ##### tailup
  ################

  tailup_covs <- c("linear", "spherical", "exponential",
                   "mariah", "epa", "none")
  lapply(tailup_covs, function(x) {
    if (x == "none") {
      params <- tailup_params(x)
      expect_equal(cov_vector(params, object), 0)
    } else {
      params <- tailup_params(x, de = 1, range = 1)
      expect_equal(dim(cov_vector(params, object)), c(175, 45))
    }
  })

  ################
  ##### taildown
  ################

  taildown_covs <- c("linear", "spherical", "exponential",
                     "mariah", "epa", "none")
  lapply(taildown_covs, function(x) {
    if (x == "none") {
      params <- taildown_params(x)
      expect_equal(cov_vector(params, object), 0)
    } else {
      params <- taildown_params(x, de = 1, range = 1)
      expect_equal(dim(cov_vector(params, object)), c(175, 45))
    }
  })

  ################
  ##### euclid
  ################

  euclid_covs <- c("exponential", "spherical", "gaussian", "cubic",
                   "pentaspherical", "cosine", "wave", "jbessel", "gravity",
                   "rquad", "magnetic", "none")
  lapply(euclid_covs, function(x) {
    if (x == "none") {
      params <- euclid_params(x)
      expect_equal(cov_vector(params, object), 0)
    } else if (x == "spherical") {
      params <- euclid_params(x, de = 1, range = 1, rotate = 0.5, scale = 0.5)
      expect_equal(dim(cov_vector(params, object_anis, anisotropy = TRUE)), c(175, 45))
    } else {
      params <- euclid_params(x, de = 1, range = 1, rotate = 0, scale = 1)
      expect_equal(dim(cov_vector(params, object, anisotropy = FALSE)), c(175, 45))
    }
  })

  ################
  ##### prediction
  ################

  expect_no_error(predict(ssn_mod, "pred1km", interval = "prediction", level = 0.9))
  expect_no_error(predict(ssn_mod_anis, "pred1km"))



})


test_that("initial objects", {
  tu <- tailup_initial("exponential", de = 1, range = 1, known = "given")
  td <- taildown_initial("exponential", de = 1, range = 1, known = c("de", "range"))
  eu <- euclid_initial("exponential", de = 1, range = 1,
                       rotate = 0, scale = 1, known = "given")
  nu <- nugget_initial("nugget", 1, known = "nugget")
  disp <- dispersion_initial("Gamma", dispersion = 1, known = "given")
  ssn_mod <- ssn_lm(Summer_mn ~ ELEV_DEM, mf04p,
                    tailup_initial = tu, taildown_initial = td,
                    euclid_initial = eu, nugget_initial = nu,
                    additive = "afvArea")
  expect_s3_class(ssn_mod, "ssn_lm")

  ssn_mod <- ssn_glm(Summer_mn ~ ELEV_DEM, mf04p,
                    tailup_initial = tu, taildown_initial = td,
                    euclid_initial = eu, nugget_initial = nu,
                    dispersion_initial = disp,
                    additive = "afvArea")
  expect_s3_class(ssn_mod, "ssn_glm")
})


test_that("print an ssn", {
  expect_output(print(mf04p))
  expect_output(print(summary(mf04p)))
  expect_output(print(names(mf04p)))
})



test_that("extra test fits", {
  ssn_mod <- ssn_glm(Summer_mn > 11 ~ ELEV_DEM, mf04p, family = "binomial",
                     tailup_type = "exponential", additive = "afvArea",
                     estmethod = "ml")
  expect_s3_class(ssn_mod, "ssn_glm")

  ssn_mod <- ssn_glm(round(Summer_mn) ~ ELEV_DEM, mf04p, family = "poisson",
                     taildown_type = "exponential")
  expect_s3_class(ssn_mod, "ssn_glm")

  ssn_mod <- ssn_glm(round(Summer_mn) ~ ELEV_DEM, mf04p, family = "nbinomial",
                     euclid_type = "exponential")
  expect_s3_class(ssn_mod, "ssn_glm")

  ssn_mod <- ssn_glm(Summer_mn ~ ELEV_DEM, mf04p, family = "inverse.gaussian",
                     tailup_type = "exponential", additive = "afvArea")
  expect_s3_class(ssn_mod, "ssn_glm")

  ssn_mod <- ssn_glm(ratio ~ ELEV_DEM, mf04p, family = "beta",
                     taildown_type = "exponential")
  expect_s3_class(ssn_mod, "ssn_glm")

  ssn_mod <- ssn_lm(Summer_mn ~ ELEV_DEM, mf04p, family = "binomial",
                     tailup_type = "exponential", additive = "afvArea",
                     random = ~ as.factor(netID))
  expect_output(print(ssn_mod))
  expect_output(print(summary(ssn_mod)))
  expect_type(fitted(ssn_mod, type = "randcov"), "list")

  ssn_mod <- ssn_glm(Summer_mn ~ ELEV_DEM, mf04p, family = "Gamma",
                    random = ~ as.factor(netID))
  expect_output(print(ssn_mod))
  expect_output(print(summary(ssn_mod)))
  expect_type(fitted(ssn_mod, type = "randcov"), "list")

})