tests/testthat/test-control.R

In unitquantreg: Parametric Quantile Regression Models for Bounded Data

test_that("testing control options in the fitting", {

  skip_on_cran()

  data(sim_bounded, package = "unitquantreg")

  # Gradient argument
  lt_fits <- lapply(lt_families, function(fam) {
    # cat(fam, '\n')
    sim_bounded_curr <- sim_bounded[sim_bounded$family == fam, ]

    fit_nogradient <- unitquantreg(
      formula = y1 ~ x, data = sim_bounded_curr,
      tau = 0.5, family = fam, link.theta = "log",
      control = unitquantreg.control(gradient = FALSE))
    fit_gradient <- unitquantreg(
      formula = y1 ~ x, data = sim_bounded_curr,
      tau = 0.5, family = fam, link.theta = "log",
      control = unitquantreg.control(gradient = TRUE))

    se_nogradient <- sqrt(diag(vcov(fit_nogradient)))
    se_gradient <- sqrt(diag(vcov(fit_gradient)))
    coef_nogradient <- coef(fit_nogradient)
    coef_gradient <- coef(fit_gradient)

    df_se <- data.frame(se_nogradient, se_gradient, coef_nogradient,
                        coef_gradient)
    df_se <- data.frame(apply(df_se, 2, function(x) round(x, 6)))
    df_se$family <- fam
    df_se$parms <- rownames(df_se)
    rownames(df_se) <- NULL
    list(
      elapsed_time = c(nogradient = fit_nogradient$elapsed_time,
                       gradient = fit_gradient$elapsed_time),
      df_se = df_se
    )
  })
  df_res_parms <- do.call("rbind", lapply(lt_fits, "[[", "df_se"))
  npar <- length(unique(df_res_parms$parms))
  expect_equal(nrow(df_res_parms), length(lt_families) * npar,
               label = "gradient argument in control works")


  # Hessian argument
  lt_fits_2 <- lapply(lt_families, function(fam) {
    # cat(fam, '\n')
    sim_bounded_curr <- sim_bounded[sim_bounded$family == fam, ]

    fit_numeric <- unitquantreg(
      formula = y1 ~ x, data = sim_bounded_curr,
      tau = 0.5, family = fam, link.theta = "log",
      control = unitquantreg.control(hessian = TRUE))

    fit_analitic <- unitquantreg(
      formula = y1 ~ x, data = sim_bounded_curr,
      tau = 0.5, family = fam, link.theta = "log",
      control = unitquantreg.control(hessian = FALSE))

    se_numeric <- round(sqrt(diag(vcov(fit_numeric))), 5)
    se_analitic <- round(sqrt(diag(vcov(fit_analitic))), 5)
    df_se <- data.frame(se_numeric, se_analitic)
    df_se$family <- fam
    list(
      elapsed_time = c(numeric = fit_numeric$elapsed_time,
                       analitic = fit_analitic$elapsed_time),
      df_se = df_se
    )
  })
  expect_equal(length(lt_fits_2), length(lt_families))
  expect_equal(length(lt_fits_2[[1L]]), 2)
  expect_equal(class(lt_fits_2[[1L]]$df_se), "data.frame")



})