tests/testthat/test-compose-bv.R

In ngme2: Linear Latent Non-Gaussian Models with Flexible Distributions

test_that("test bv operator", {
  n <- 10

  op <- bv(
    mesh = 1:5,
    theta = 0.5,
    rho = 0.5,
    sub_models = list(
      A = ar1(rho = 0.5),
      B = ar1(rho = -0.5)
    )
  )
  op

  model <- f(
    c(1:(n / 2), 1:(n / 2)),
    model = bv(
      use_c_param = TRUE,
      mesh = 1:5,
      rho = 0.5,
      sub_models = list(
        A = ar1(rho = 0.5),
        B = ar1(rho = -0.5)
      )
    ),
    group = c(rep("A", n / 2), rep("B", n / 2)),
    noise = list(
      A = noise_normal(),
      B = noise_normal()
    )
  )
  model
})

test_that("test bv(ar1, ar1) with 2 noise", {
  op <- bv(
    mesh = 1:5,
    theta = 0.5, rho = 0.8,
    sub_models = list(
      A = ar1(rho = 0.5),
      B = ar1(rho = -0.5)
    )
  )

  n <- 10
  true_model <- f(
    c(1:(n / 2), 1:(n / 2)),
    model = bv(
      mesh = 1:5,
      rho = 0.8,
      sub_models = list(
        A = ar1(rho = 0.5),
        B = ar1(rho = -0.5)
      )
    ),
    group = c(rep("A", n / 2), rep("B", n / 2)),
    noise = list(
      A = noise_nig(mu = 3, sigma = 2, nu = 1),
      B = noise_nig(mu = -3, sigma = 2, nu = 1)
    )
  )
  true_model
  true_model$operator$K


  W <- simulate(true_model, seed = 1)[[1]]
  n_obs <- length(W)
  Y <- W + rnorm(n_obs, sd = 0.5)
  # Y = c(Y_A, Y_B)
  # label = c(A, B)

  out <- ngme(
    Y ~ 0 + f(
      c(1:(n / 2), 1:(n / 2)),
      model = bv(
        mesh = c(1:(n / 2)),
        theta = 0.45,
        sub_models = list(
          A = ar1(rho = 0.5),
          B = ar1(rho = -0.5)
        )
      ),
      noise = list(
        A = noise_nig(),
        B = noise_nig()
      )
    ),
    group = c(rep("A", n / 2), rep("B", n / 2)),
    data = data.frame(Y = Y),
    control_opt = control_opt(
      optimizer = precond_sgd(),
      seed = 3,
      iterations = 10,
      n_batch = 5,
      n_parallel_chain = 4,
      print_check_info = TRUE
    )
  )

  out
  traceplot(out, "field1")

  lp <- predict(out,
    map = list(field1 = c(1, 2, 3)),
    group = c("B", "B", "A")
  )
  str(lp)
})

test_that("test on bv(matern, matern)", {
  pl01 <- cbind(c(0, 1, 1, 0, 0) * 10, c(0, 0, 1, 1, 0) * 5)
  mesh <- fmesher::fm_mesh_2d(loc.domain = pl01, cutoff = 0.2, max.edge = c(1, 10))
  mesh$n

  n_obs1 <- 300
  loc1 <- cbind(runif(n_obs1, 0, 10), runif(n_obs1, 0, 5))
  n_obs2 <- 400
  loc2 <- cbind(runif(n_obs2, 0, 10), runif(n_obs2, 0, 5))

  true_model <- f(
    map = rbind(loc1, loc2),
    model = bv(
      mesh = mesh,
      sub_models = list(
        A = matern(theta_kappa = log(1)),
        B = matern(theta_kappa = log(3))
      )
    ),
    group = c(rep("A", 300), rep("B", 400)),
    noise = list(A = noise_nig(), B = noise_nig())
  )

  W <- simulate(true_model)[[1]]
  n_obs <- length(W)
  Y <- W + rnorm(n_obs, sd = 0.5)
  length(Y)

  out <- ngme(
    Y ~ 0 + f(
      map = rbind(loc1, loc2),
      model = bv(
        mesh = mesh,
        sub_models = list(
          A = matern(),
          B = matern()
        )
      ),
      noise = list(A = noise_nig(), B = noise_nig())
    ),
    group = c(rep("A", 300), rep("B", 400)),
    data = data.frame(
      Y = Y
    ),
    control_ngme = control_ngme(
      n_gibbs_samples = 5
    ),
    control_opt = control_opt(
      iterations = 10,
      n_parallel_chain = 4,
      estimation = T,
      verbose = T
    )
  )

  out
  traceplot(out, "field1")
  predict(out,
    map = list(field1 = cbind(c(1, 2, 3), c(2, 3, 4))),
    group = rep("A", 6)
  )
  # out$replicates[[1]]$models[[1]]$theta_K
  # out$replicates[[1]]$models[[1]]$operator$theta_K
})

test_that("test on bv matern NIG", {
  pl01 <- cbind(c(0, 1, 1, 0, 0) * 10, c(0, 0, 1, 1, 0) * 5)
  mesh <- fmesher::fm_mesh_2d(
    loc.domain = pl01,
    cutoff = 0.2,
    max.edge = c(1, 5)
  )
  mesh$n
  n_obs <- 500

  # generate random locations (same for two fields)
  long <- runif(n_obs / 2, 0, 10)
  lat <- runif(n_obs / 2, 0, 5)
  long <- c(long, long)
  lat <- c(lat, lat)
  group <- c(rep("W1", n_obs / 2), rep("W2", n_obs / 2))

  # plot the mesh
  # plot(mesh); points(long, lat)

  # parameters of the bivariate model
  theta <- pi / 4
  rho <- 0.2
  theta_K_1 <- log(2)
  theta_K_2 <- log(5)
  mu_1 <- -2
  sigma_1 <- 0.5
  nu_1 <- 1
  mu_2 <- 2
  sigma_2 <- 0.3
  nu_2 <- 0.5

  true_model <- f(
    ~ long + lat,
    model = bv_matern(
      mesh = mesh,
      theta = theta,
      rho = rho,
      sd1 = sigma_1,
      sd2 = sigma_2,
      sub_models = list(
        W1 = matern(theta_kappa = theta_K_1),
        W2 = matern(theta_kappa = theta_K_2)
      )
    ),
    group = group,
    noise = list(
      W1 = noise_nig(mu = mu_1, sigma = 1, nu = nu_1),
      W2 = noise_nig(mu = mu_2, sigma = 1, nu = nu_2)
    )
  )
  true_model

  sim_fields <- simulate(true_model)[[1]]

  sd_1 <- 0.6
  sd_2 <- 0.9
  rho_e <- 0.9
  Cov_same_idx <- matrix(c(sd_1^2, rho_e * sd_1 * sd_2, rho_e * sd_1 * sd_2, sd_2^2), nrow = 2)

  Cov_measurement <- Cov_same_idx %x% diag(n_obs / 2)

  # e ~ N(0, Cov_measurement)
  L <- t(chol(Cov_measurement))
  e <- L %*% rnorm(n_obs)

  # fixed effects
  x1 <- rexp(n_obs)
  x2 <- rnorm(n_obs)
  feff <- c(-3, 1.5)

  Y <- sim_fields + x1 * feff[1] + x2 * feff[2] + as.numeric(e)

  B_sigma <- matrix(0, nrow = n_obs, ncol = 2)
  B_sigma[group == "W1", 1] <- 1
  B_sigma[group == "W2", 2] <- 1

  #
  out_cor_gauss <- ngme(
    Y ~ 0 + x1 + x2 + f(
      ~ long + lat,
      name = "bv",
      model = bv_matern(
        mesh = mesh,
        sub_models = list(
          W1 = matern(),
          W2 = matern()
        )
      ),
      # debug=T,
      noise = list(
        W1 = noise_normal(),
        W2 = noise_normal()
      )
    ),
    group = group,
    family = noise_normal(
      corr_measurement = TRUE,
      index_corr = c(1:(n_obs / 2), 1:(n_obs / 2)),
      B_sigma = B_sigma,
      theta_sigma = c(0, 0)
    ),
    data = data.frame(Y, long, lat),
    control_opt = control_opt(
      iterations = 20,
      n_parallel_chain = 4,
      seed = 50
    ),
    debug = FALSE
  )
  out_cor_gauss
  traceplot(out_cor_gauss, "bv")
  traceplot(out_cor_gauss, hline = c(log(sd_1), log(sd_2), rho_e, feff))

  out_cor_nig <- ngme(
    Y ~ 0 + x1 + x2 + f(
      ~ long + lat,
      name = "bv",
      model = bv_matern(
        mesh = mesh,
        theta = pi / 4,
        fix_theta = TRUE,
        sub_models = list(
          W1 = matern(),
          W2 = matern()
        )
      ),
      # debug=T,
      noise = list(
        W1 = noise_nig(),
        W2 = noise_nig()
      )
    ),
    group = group,
    family = noise_normal(
      corr_measurement = TRUE,
      index_corr = c(1:(n_obs / 2), 1:(n_obs / 2)),
      B_sigma = B_sigma,
      theta_sigma = c(0, 0)
    ),
    data = data.frame(Y, long, lat),
    control_opt = control_opt(
      estimation = TRUE,
      iterations = 20,
      print_check_info = FALSE,
      seed = 50,
      n_parallel_chain = 1
    ),
    debug = FALSE,
    start = out_cor_gauss
  )
  out_cor_nig
  traceplot(out_cor_nig, "bv")
  traceplot(out_cor_nig, hline = c(log(sd_1), log(sd_2), rho_e, feff))
})