tests/testthat/test-multigroup.R

In lava: Latent Variable Models

context("Multiple Group")

test_that("Multiple group I", {
  m <- lvm(y~x)
  set.seed(1)
  d <- sim(m,100)
  ## Just a stratified analysis
  e <- estimate(list("Group A"=m,"Group B"=m),list(d,d))
  testthat::expect_true(mean((coef(e)[c(1,3)]-coef(lm(y~x,d)))^2)<1e-9)
  testthat::expect_true(mean((coef(e)[c(2,5)]-coef(lm(y~x,d)))^2)<1e-9)
})

test_that("Multiple group II", {
  m <- baptize(lvm(y~x))
  set.seed(1)
  d <- sim(m,100)
  ## Just a standard linear regression (single group)
  e <- estimate(list(m,m),list(d,d))
  testthat::expect_identical(coef(e,type=2)[[1]],coef(e,type=2)[[2]])
  testthat::expect_true(mean((coef(e,type=2)[[1]][1:2,1]-coef(lm(y~x,cbind(d,d))))^2)<1e-9)
})

context("Missing data")

test_that("Missing data analysis", {
  ## Random intercept model
  m <- lvm(c(y1,y2,y3)~x+u); latent(m) <- ~u
  set.seed(1)
  ## Missing on first two outcomes
  d <- makemissing(sim(m,200),p=0.3,cols=c("y1","y2"))  
  e <- estimate(m,d,missing=TRUE)
  testthat::expect_true("lvm.missing"%in%class(e))
  testthat::expect_true(sum(unlist(lapply(e$estimate$model$data,nrow)))==200)
  ## Convergence:
  g <- gof(e)
  testthat::expect_true(mean(score(e))<1e-3)
  testthat::expect_true(g$rankV==length(pars(e)))
})

test_that("Multiple group, missing data analysis", {
  m <- lvm(list(c(y1,y2,y3)~u,u~x)); latent(m) <- ~u
  m <- baptize(fixsome(m))
  regression(m,u~x) <- NA
  covariance(m,~u) <- NA
  set.seed(1)
  ## Missing on all outcomes
  d1 <- makemissing(sim(m,500),cols=c("y1","y2"),p=0.3)
  d2 <- makemissing(sim(m,500),cols=c("y1","y2"),p=0.3)
  e <- estimate(list(m,m),list(d1,d2),missing=TRUE)
  g <- gof(e)
  testthat::expect_true(g$n==1000)
  testthat::expect_true(mean(score(e))<1e-3)
  testthat::expect_true(g$rankV==length(pars(e)))
})


test_that("Multiple group, constraints", {
    m1 <- lvm(y ~ f(x,beta)+f(z,beta2))
    m2 <- lvm(y ~ f(x,psi) + z)
    ## And simulate data from them
    set.seed(1)
    d1 <- sim(m1,100)
    d2 <- sim(m2,100)
    ## Add 'non'-linear parameter constraint
    constrain(m2,psi ~ beta2) <- function(x) x
    ## Add parameter beta2 to model 2, now beta2 exists in both models
    parameter(m2) <- ~ beta2
    ee <- estimate(list(m1,m2),list(d1,d2))

    m <- lvm(y1 ~ x1 + beta2*z1)
    regression(m) <- y2 ~ beta2*x2 + z2
    d <- cbind(d1,d2); names(d) <- c(paste0(names(d1),1),paste0(names(d1),2))
    e <- estimate(m,d)

    b1 <- coef(e,2,labels=TRUE)["beta2",1]
    b2 <- constraints(ee)[1]
    testthat::expect_true(mean((b1-b2)^2)<1e-5)
    
    ## "Multiple group, constraints (non-linear in x)
    m <- lvm(y[m:v] ~ 1)
    addvar(m) <- ~x
    parameter(m) <- ~a+b
    constrain(m,m~a+b+x) <- function(z) z[1]+z[2]*z[3]
    ee <- estimate(list(m,m),list(d1[1:5,],d1[6:10,]))
    b1 <- coef(lm(y~x,d1[1:10,]))
    b2 <- coef(ee)[c("a@1","b@1")]
    testthat::expect_true(mean(b1-b2)^2<1e-4)

})