dwww Home | Show directory contents | Find package

.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes"
.runStanTest <- Sys.getenv("RunAllinsightStanTests") == "yes"

if (.runThisTest && .runStanTest) {
  if (suppressWarnings(
    requiet("lme4") &&
      requiet("BayesFactor") &&
      requiet("rstanarm")
  )) {
    # skip_on_cran()
    skip_if_offline()

    # defining models ---------------------

    m1 <- insight::download_model("stanreg_merMod_5")
    m2 <- insight::download_model("stanreg_glm_6")
    m3 <- insight::download_model("stanreg_glm_1")

    data("puzzles")
    m4 <- suppressWarnings(
      stan_glm(
        RT ~ color * shape,
        data = puzzles,
        prior = rstanarm::cauchy(0, c(3, 1, 2)),
        iter = 500,
        chains = 2,
        refresh = 0
      )
    )
    m5 <- suppressWarnings(
      stan_glm(
        RT ~ color * shape,
        data = puzzles,
        prior = rstanarm::cauchy(0, c(1, 2, 3)),
        iter = 500,
        chains = 2,
        refresh = 0
      )
    )
    m6 <- insight::download_model("stanreg_gamm4_1")

    m7 <- suppressWarnings(
      stan_lm(mpg ~ wt + qsec + am,
        data = mtcars, prior = R2(0.75),
        chains = 1, iter = 300, refresh = 0
      )
    )

    m8 <- stan_lmer(Reaction ~ Days + (1 | Subject), data = sleepstudy, refresh = 0)

    m9 <- stan_aov(yield ~ block + N * P * K, data = npk, prior = R2(0.5), refresh = 0)

    N <- 200
    x <- rnorm(N, 2, 1)
    z <- rnorm(N, 2, 1)
    mu <- binomial(link = "logit")$linkinv(1 + 0.2 * x)
    phi <- exp(1.5 + 0.4 * z)
    y <- rbeta(N, mu * phi, (1 - mu) * phi)
    hist(y, col = "dark grey", border = FALSE, xlim = c(0, 1))
    fake_dat <- data.frame(y, x, z)
    m10 <- stan_betareg(
      y ~ x | z,
      data = fake_dat,
      link = "logit",
      link.phi = "log",
      refresh = 0,
      algorithm = "optimizing" # just for speed of example
    )

    ols <- lm(mpg ~ wt + qsec + am,
      data = mtcars, # all row are complete so ...
      na.action = na.exclude
    ) # not necessary in this case
    b <- coef(ols)[-1]
    R <- qr.R(ols$qr)[-1, -1]
    SSR <- crossprod(ols$residuals)[1]
    not_NA <- !is.na(fitted(ols))
    N <- sum(not_NA)
    xbar <- colMeans(mtcars[not_NA, c("wt", "qsec", "am")])
    y <- mtcars$mpg[not_NA]
    ybar <- mean(y)
    s_y <- sd(y)
    m11 <- suppressWarnings(
      stan_biglm.fit(b, R, SSR, N, xbar, ybar, s_y,
        prior = R2(0.75),
        # the next line is only to make the example go fast
        refresh = 0,
        chains = 1, iter = 500, seed = 12345
      )
    )

    dat <- infert[order(infert$stratum), ] # order by strata
    m12 <- suppressWarnings(
      stan_clogit(case ~ spontaneous + induced + (1 | education),
        strata = stratum,
        data = dat,
        subset = parity <= 2,
        QR = TRUE,
        chains = 2, iter = 500, refresh = 0
      )
    ) # for speed only

    if (.Platform$OS.type != "windows" || .Platform$r_arch != "i386") {
      void <- capture.output(
        m13 <- suppressMessages(
          suppressWarnings(
            stan_jm(
              formulaLong = logBili ~ year + (1 | id),
              dataLong = pbcLong,
              formulaEvent = Surv(futimeYears, death) ~ sex + trt,
              dataEvent = pbcSurv,
              time_var = "year",
              # this next line is only to keep the example small in size!
              chains = 1, cores = 1, seed = 12345, iter = 1000, refresh = 0
            )
          )
        )
      )
      # expect_snapshot(model_info(m13))
    }

    data("Orange", package = "datasets")
    Orange$circumference <- Orange$circumference / 100
    Orange$age <- Orange$age / 100


    ## TODO probably re-enable once strange check error is resolved

    # m14 <- stan_nlmer(
    #   circumference ~ SSlogis(age, Asym, xmid, scal) ~ Asym | Tree,
    #   data = Orange,
    #   # for speed only
    #   chains = 1,
    #   iter = 1000
    # )

    m15 <- suppressWarnings(
      stan_mvmer(
        formula = list(
          logBili ~ year + (1 | id),
          albumin ~ sex + year + (year | id)
        ),
        data = pbcLong,
        # this next line is only to keep the example small in size!
        chains = 1, cores = 1, seed = 12345, iter = 1000, refresh = 0
      )
    )

    test_that("model_info-stanreg-glm", {
      expect_equal(
        model_info(m1),
        list(
          is_binomial = TRUE, is_bernoulli = FALSE, is_count = FALSE,
          is_poisson = FALSE, is_negbin = FALSE, is_beta = FALSE, is_betabinomial = FALSE,
          is_dirichlet = FALSE, is_exponential = FALSE, is_logit = TRUE,
          is_probit = FALSE, is_censored = FALSE, is_truncated = FALSE,
          is_survival = FALSE, is_linear = FALSE, is_tweedie = FALSE,
          is_zeroinf = FALSE, is_zero_inflated = FALSE, is_dispersion = FALSE,
          is_hurdle = FALSE, is_ordinal = FALSE, is_cumulative = FALSE,
          is_multinomial = FALSE, is_categorical = FALSE, is_mixed = TRUE,
          is_multivariate = FALSE, is_trial = TRUE, is_bayesian = TRUE,
          is_gam = FALSE, is_anova = FALSE, is_timeseries = FALSE,
          is_ttest = FALSE, is_correlation = FALSE, is_onewaytest = FALSE,
          is_chi2test = FALSE, is_ranktest = FALSE, is_levenetest = FALSE,
          is_variancetest = FALSE, is_xtab = FALSE, is_proptest = FALSE,
          is_binomtest = FALSE, is_ftest = FALSE, is_meta = FALSE,
          link_function = "logit", family = "binomial", n_obs = 56L,
          n_grouplevels = c(herd = 15L)
        )
      )

      expect_equal(
        model_info(m2),
        list(
          is_binomial = FALSE, is_bernoulli = FALSE, is_count = FALSE,
          is_poisson = FALSE, is_negbin = FALSE, is_beta = FALSE, is_betabinomial = FALSE,
          is_dirichlet = FALSE, is_exponential = FALSE, is_logit = FALSE,
          is_probit = FALSE, is_censored = FALSE, is_truncated = FALSE,
          is_survival = FALSE, is_linear = TRUE, is_tweedie = FALSE,
          is_zeroinf = FALSE, is_zero_inflated = FALSE, is_dispersion = FALSE,
          is_hurdle = FALSE, is_ordinal = FALSE, is_cumulative = FALSE,
          is_multinomial = FALSE, is_categorical = FALSE, is_mixed = FALSE,
          is_multivariate = FALSE, is_trial = FALSE, is_bayesian = TRUE,
          is_gam = FALSE, is_anova = FALSE, is_timeseries = FALSE,
          is_ttest = FALSE, is_correlation = FALSE, is_onewaytest = FALSE,
          is_chi2test = FALSE, is_ranktest = FALSE, is_levenetest = FALSE,
          is_variancetest = FALSE, is_xtab = FALSE, is_proptest = FALSE,
          is_binomtest = FALSE, is_ftest = FALSE, is_meta = FALSE,
          link_function = "identity", family = "gaussian", n_obs = 150L,
          n_grouplevels = NULL
        )
      )

      expect_equal(
        model_info(m3),
        list(
          is_binomial = TRUE, is_bernoulli = TRUE, is_count = FALSE,
          is_poisson = FALSE, is_negbin = FALSE, is_beta = FALSE, is_betabinomial = FALSE,
          is_dirichlet = FALSE, is_exponential = FALSE, is_logit = TRUE,
          is_probit = FALSE, is_censored = FALSE, is_truncated = FALSE,
          is_survival = FALSE, is_linear = FALSE, is_tweedie = FALSE,
          is_zeroinf = FALSE, is_zero_inflated = FALSE, is_dispersion = FALSE,
          is_hurdle = FALSE, is_ordinal = FALSE, is_cumulative = FALSE,
          is_multinomial = FALSE, is_categorical = FALSE, is_mixed = FALSE,
          is_multivariate = FALSE, is_trial = FALSE, is_bayesian = TRUE,
          is_gam = FALSE, is_anova = FALSE, is_timeseries = FALSE,
          is_ttest = FALSE, is_correlation = FALSE, is_onewaytest = FALSE,
          is_chi2test = FALSE, is_ranktest = FALSE, is_levenetest = FALSE,
          is_variancetest = FALSE, is_xtab = FALSE, is_proptest = FALSE,
          is_binomtest = FALSE, is_ftest = FALSE, is_meta = FALSE,
          link_function = "logit", family = "binomial", n_obs = 32L,
          n_grouplevels = NULL
        )
      )

      ## TODO add model m4 to m15
    })

    test_that("n_parameters", {
      expect_equal(n_parameters(m1), 21)
      expect_equal(n_parameters(m1, effects = "fixed"), 5)
    })

    test_that("get_priors", {
      expect_equal(
        colnames(get_priors(m1)),
        c("Parameter", "Distribution", "Location", "Scale")
      )
      expect_equal(
        colnames(get_priors(m2)),
        c(
          "Parameter",
          "Distribution",
          "Location",
          "Scale",
          "Adjusted_Scale"
        )
      )
      expect_equal(get_priors(m1)$Scale, c(2.5, 2.5, 2.5, 2.5, 2.5), tolerance = 1e-3)
      expect_equal(get_priors(m2)$Adjusted_Scale, c(1.08967, 2.30381, 2.30381, 0.61727, 0.53603, 0.41197), tolerance = 1e-3)
      expect_equal(get_priors(m3)$Adjusted_Scale, c(NA, 2.555042), tolerance = 1e-3)
      expect_equal(get_priors(m4)$Adjusted_Scale, c(6.399801, NA, NA, NA), tolerance = 1e-3)
      expect_equal(get_priors(m5)$Adjusted_Scale, c(6.399801, NA, NA, NA), tolerance = 1e-3)
      expect_equal(
        get_priors(m6),
        data.frame(
          Parameter = "(Intercept)",
          Distribution = "normal",
          Location = 3.057333,
          Scale = 2.5,
          Adjusted_Scale = 1.089666,
          stringsAsFactors = FALSE,
          row.names = NULL
        ),
        tolerance = 1e-3
      )
    })


    test_that("clean_names", {
      expect_identical(
        clean_names(m1),
        c("incidence", "size", "period", "herd")
      )
    })


    test_that("find_predictors", {
      expect_identical(find_predictors(m1), list(conditional = c("size", "period")))
      expect_identical(find_predictors(m1, flatten = TRUE), c("size", "period"))
      expect_identical(
        find_predictors(m1, effects = "all", component = "all"),
        list(
          conditional = c("size", "period"),
          random = "herd"
        )
      )
      expect_identical(
        find_predictors(
          m1,
          effects = "all",
          component = "all",
          flatten = TRUE
        ),
        c("size", "period", "herd")
      )
    })

    test_that("find_response", {
      expect_equal(
        find_response(m1, combine = TRUE),
        "cbind(incidence, size - incidence)"
      )
      expect_equal(
        find_response(m1, combine = FALSE),
        c("incidence", "size")
      )
    })

    test_that("get_response", {
      expect_equal(nrow(get_response(m1)), 56)
      expect_equal(colnames(get_response(m1)), c("incidence", "size"))
    })

    test_that("find_random", {
      expect_equal(find_random(m1), list(random = "herd"))
    })

    test_that("get_random", {
      expect_equal(get_random(m1), lme4::cbpp[, "herd", drop = FALSE])
    })

    test_that("find_terms", {
      expect_identical(
        find_terms(m1),
        list(
          response = "cbind(incidence, size - incidence)",
          conditional = c("size", "period"),
          random = "herd"
        )
      )
    })

    test_that("find_variables", {
      expect_identical(
        find_variables(m1),
        list(
          response = c("incidence", "size"),
          conditional = c("size", "period"),
          random = "herd"
        )
      )
      expect_identical(
        find_variables(m1, effects = "fixed"),
        list(
          response = c("incidence", "size"),
          conditional = c("size", "period")
        )
      )
      expect_null(find_variables(m1, component = "zi"))
    })

    test_that("n_obs", {
      expect_equal(n_obs(m1), 56)
      expect_equal(n_obs(m1, disaggregate = TRUE), 842)
    })

    test_that("find_paramaters", {
      expect_equal(
        find_parameters(m1),
        list(
          conditional = c("(Intercept)", "size", "period2", "period3", "period4"),
          random = c(sprintf("b[(Intercept) herd:%i]", 1:15), "Sigma[herd:(Intercept),(Intercept)]")
        )
      )
      expect_equal(
        find_parameters(m1, flatten = TRUE),
        c(
          "(Intercept)",
          "size",
          "period2",
          "period3",
          "period4",
          sprintf("b[(Intercept) herd:%i]", 1:15),
          "Sigma[herd:(Intercept),(Intercept)]"
        )
      )
    })

    test_that("find_paramaters", {
      expect_equal(
        colnames(get_parameters(m1)),
        c("(Intercept)", "size", "period2", "period3", "period4")
      )
      expect_equal(
        colnames(get_parameters(m1, effects = "all")),
        c(
          "(Intercept)",
          "size",
          "period2",
          "period3",
          "period4",
          sprintf("b[(Intercept) herd:%i]", 1:15),
          "Sigma[herd:(Intercept),(Intercept)]"
        )
      )
    })

    test_that("linkfun", {
      expect_false(is.null(link_function(m1)))
    })

    test_that("link_inverse", {
      expect_equal(link_inverse(m1)(0.2), plogis(0.2), tolerance = 1e-4)
    })

    test_that("get_data", {
      expect_equal(nrow(get_data(m1)), 56)
      expect_equal(
        colnames(get_data(m1)),
        c("incidence", "size", "period", "herd")
      )
    })

    test_that("find_formula", {
      expect_length(find_formula(m1), 2)
      expect_equal(
        find_formula(m1),
        list(
          conditional = as.formula("cbind(incidence, size - incidence) ~ size + period"),
          random = as.formula("~1 | herd")
        ),
        ignore_attr = TRUE
      )
    })

    test_that("get_variance", {
      expect_equal(
        get_variance(m1),
        list(
          var.fixed = 0.36274,
          var.random = 0.5988885,
          var.residual = 3.28987,
          var.distribution = 3.28987,
          var.dispersion = 0,
          var.intercept = c(herd = 0.59889)
        ),
        tolerance = 1e-3
      )

      expect_equal(get_variance_fixed(m1),
        c(var.fixed = 0.3627389),
        tolerance = 1e-4
      )
      expect_equal(get_variance_random(m1),
        c(var.random = 0.5988885),
        tolerance = 1e-4
      )
      expect_equal(get_variance_residual(m1),
        c(var.residual = 3.289868),
        tolerance = 1e-4
      )
      expect_equal(get_variance_distribution(m1),
        c(var.distribution = 3.289868),
        tolerance = 1e-4
      )
      expect_equal(get_variance_dispersion(m1),
        c(var.dispersion = 0),
        tolerance = 1e-4
      )
    })

    test_that("find_algorithm", {
      expect_equal(
        find_algorithm(m1),
        list(
          algorithm = "sampling",
          chains = 2,
          iterations = 500,
          warmup = 250
        )
      )
    })

    test_that("clean_parameters", {
      expect_equal(
        clean_parameters(m2),
        structure(
          list(
            Parameter = c(
              "(Intercept)",
              "Speciesversicolor",
              "Speciesvirginica",
              "Petal.Length",
              "Speciesversicolor:Petal.Length",
              "Speciesvirginica:Petal.Length",
              "sigma"
            ),
            Effects = c(
              "fixed", "fixed", "fixed",
              "fixed", "fixed", "fixed", "fixed"
            ),
            Component = c(
              "conditional",
              "conditional",
              "conditional",
              "conditional",
              "conditional",
              "conditional",
              "sigma"
            ),
            Cleaned_Parameter = c(
              "(Intercept)",
              "Speciesversicolor",
              "Speciesvirginica",
              "Petal.Length",
              "Speciesversicolor:Petal.Length",
              "Speciesvirginica:Petal.Length",
              "sigma"
            )
          ),
          class = c("clean_parameters", "data.frame"),
          row.names = c(NA, -7L)
        ),
        ignore_attr = TRUE
      )
    })

    test_that("find_statistic", {
      expect_null(find_statistic(m1))
      expect_null(find_statistic(m2))
      expect_null(find_statistic(m3))
      expect_null(find_statistic(m4))
      expect_null(find_statistic(m5))
      expect_null(find_statistic(m6))
    })

    model <- stan_glm(
      disp ~ carb,
      data = mtcars,
      priors = NULL,
      prior_intercept = NULL,
      refresh = 0
    )

    test_that("flat_priors", {
      p <- get_priors(model)
      expect_equal(p$Distribution, c("uniform", "normal"))
      expect_equal(p$Location, c(NA, 0), tolerance = 1e-3)
    })
  }
}

Generated by dwww version 1.15 on Sun Jun 16 03:03:36 CEST 2024.