tests/testthat/test-genStart.R

In Andrea-Havron/clustTMB: Spatio-Temporal Finite Mixture Model using 'TMB'

clss <- unmap(hclass(hc(faithful), 2))
init.parm.mclust <- list(
  mu = list(
    g1 = apply(faithful[clss[, 1] == 1, ], 2, mean),
    g2 = apply(faithful[clss[, 2] == 1, ], 2, mean)
  ),
  Sigma = list(
    g1 = apply(faithful[clss[, 1] == 1, ], 2, var),
    g2 = apply(faithful[clss[, 2] == 1, ], 2, var)
  ),
  Corr = list(
    g1 = cor(faithful[clss[, 1] == 1, ])[2, 1],
    g2 = cor(faithful[clss[, 2] == 1, ])[2, 1]
  ),
  Pi = list(g1 = 0.5, g2 = 0.5)
)
# Pi = list(g1 = sum(clss[,1])/nrow(faithful),
#           g2 = sum(clss[,2])/nrow(faithful)))
dim.list <- list(
  n.i = nrow(faithful), n.j = ncol(faithful), n.t = 1,
  n.g = 2, n.f.sp = ncol(faithful), n.f.rand = ncol(faithful), n.v = NULL
)
dim.list$nl.fix <- (dim.list$n.j^2 - dim.list$n.j) / 2
dim.list$n.f.rand <- dim.list$n.j
dim.list$nl.rand <- dim.list$n.j * dim.list$n.f.rand -
  (dim.list$n.f.rand * (dim.list$n.f.rand - 1)) / 2
dim.list$n.f.sp <- dim.list$n.j
dim.list$nl.sp <- dim.list$n.j * dim.list$n.f.sp -
  (dim.list$n.f.sp * (dim.list$n.f.sp - 1)) / 2
Dat <- mkDat(
  response = as.matrix(faithful), time.vector = rep(1, nrow(faithful)),
  expert.dat = as.data.frame(rep(1, nrow(faithful))),
  gating.dat = as.data.frame(rep(1, nrow(faithful))),
  expert.formula = ~1,
  gating.formula = ~1,
  ll.method = 0,
  fixStruct = "VVV",
  rrStruct = rep(0, 2),
  reStruct = matrix(0, 2, 3),
  dim.list = dim.list
)
dim.list$n.v <- Dat$spde$n_s
init.parm.clustTMB <- genInit(Dat,
  family = gaussian(link = "identity"), dim.list,
  control = init.options(hc.options = list(
    modelName = "VVV", use = "VARS"
  ))
)

context("equal mvn init parameters")
test_that("mu", {
  expect_equal(
    as.vector(init.parm.mclust$mu$g1),
    init.parm.clustTMB$parms$betad[1, , 1]
  )
  expect_equal(
    as.vector(init.parm.mclust$mu$g2),
    init.parm.clustTMB$parms$betad[1, , 2]
  )
})
test_that("Sigma", {
  expect_equal(
    as.vector(init.parm.mclust$Sigma$g1),
    exp(init.parm.clustTMB$parms$theta[, 1])
  )
  expect_equal(
    as.vector(init.parm.mclust$Sigma$g2),
    exp(init.parm.clustTMB$parms$theta[, 2])
  )
})
# test_that("Corr", { Not same now input is based on cholesky decomp
#   expect_equal(as.vector(unlist(init.parm.mclust$Corr)),
#                as.vector(1/(1+exp(-init.parm.clustTMB$parms$logit_corr_fix))*2-1))
# })
test_that("Pi", {
  expect_equal(
    as.vector(unlist(init.parm.mclust$Pi)),
    c(
      1 / (1 + exp(-init.parm.clustTMB$parms$betag)),
      1 - 1 / (1 + exp(-init.parm.clustTMB$parms$betag))
    )
  )
})
test_that("Class", {
  expect_equal(map(clss), init.parm.clustTMB$class)
})
test_that("Random Effects dim", {
  expect_equal(
    c(dim.list$n.t, dim.list$n.g - 1),
    dim(init.parm.clustTMB$parms$upsilon_tg)
  )
  expect_equal(
    c(dim.list$n.t, dim.list$n.j, dim.list$n.g),
    dim(init.parm.clustTMB$parms$epsilon_tjg)
  )
  # expect_equal(
  # c(dim.list$n.i, dim.list$n.g-1),
  # dim(init.parm.clustTMB$parms$u_ig)
  # )
  expect_equal(
    c(dim.list$n.i, dim.list$n.f.rand, dim.list$n.g),
    dim(init.parm.clustTMB$parms$v_ifg)
  )
  expect_equal(
    c(dim.list$n.v, dim.list$n.g - 1),
    dim(init.parm.clustTMB$parms$Gamma_vg)
  )
  expect_equal(
    c(dim.list$n.v, dim.list$n.f.sp, dim.list$n.g),
    dim(init.parm.clustTMB$parms$Omega_vfg)
  )
})


clss <- unmap(mclust:::qclass(faithful$waiting, 2))
init.parm.mclust <- list(
  mu = list(
    g1 = mean(faithful$waiting[clss[, 1] == 1]),
    g2 = mean(faithful$waiting[clss[, 2] == 1])
  ),
  Sigma = list(
    g1 = var(faithful$waiting[clss[, 1] == 1]),
    g2 = var(faithful$waiting[clss[, 2] == 1])
  ),
  Corr = list(g1 = 0, g2 = 0),
  Pi = c(0.5, 0.5)
)
# Pi = list(g1 = sum(clss[,1])/nrow(faithful),
#           g2 = sum(clss[,2])/nrow(faithful)))
dim.list <- list(
  n.i = nrow(faithful), n.j = 1, n.t = 1,
  n.g = 2, n.f.sp = 1, n.f.rand = 1, n.v = NULL
)

dim.list$nl.fix <- 1
dim.list$nl.rand <- dim.list$n.j * dim.list$n.f.rand -
  (dim.list$n.f.rand * (dim.list$n.f.rand - 1)) / 2
dim.list$nl.sp <- dim.list$n.j * dim.list$n.f.sp -
  (dim.list$n.f.sp * (dim.list$n.f.sp - 1)) / 2
Dat <- mkDat(
  response = as.matrix(faithful$waiting), time.vector = rep(1, nrow(faithful)),
  expert.dat = as.data.frame(rep(1, nrow(faithful))),
  gating.dat = as.data.frame(rep(1, nrow(faithful))),
  expert.formula = ~1,
  gating.formula = ~1,
  ll.method = 0,
  fixStruct = "E",
  rrStruct = rep(0, 2),
  reStruct = matrix(0, 2, 3),
  dim.list = dim.list
)
dim.list$n.v <- Dat$spde$n_s
init.parm.clustTMB <- genInit(Dat,
  family = gaussian(link = "identity"), dim.list,
  control = init.options(init.method = "quantile")
)

context("equal uniNormal init parameters")
test_that("mu", {
  expect_equal(
    as.vector(init.parm.mclust$mu$g1),
    init.parm.clustTMB$parms$betad[1, , 1]
  )
  expect_equal(
    as.vector(init.parm.mclust$mu$g2),
    init.parm.clustTMB$parms$betad[1, , 2]
  )
})
test_that("Sigma", {
  expect_equal(
    as.vector(init.parm.mclust$Sigma$g1),
    exp(init.parm.clustTMB$parms$theta[, 1])
  )
  expect_equal(
    as.vector(init.parm.mclust$Sigma$g2),
    exp(init.parm.clustTMB$parms$theta[, 2])
  )
})
test_that("Corr", {
  expect_equal(
    as.vector(unlist(init.parm.mclust$Corr)),
    as.vector(1 / (1 + exp(-init.parm.clustTMB$parms$logit_corr_fix)) * 2 - 1)
  )
})
test_that("Pi", {
  expect_equal(
    as.vector(unlist(init.parm.mclust$Pi)),
    c(
      1 / (1 + exp(-init.parm.clustTMB$parms$betag)),
      1 - 1 / (1 + exp(-init.parm.clustTMB$parms$betag))
    )
  )
})
test_that("Class", {
  expect_equal(map(clss), init.parm.clustTMB$class)
})


# test MakeADFun
test_that("Random Effects dim", {
  expect_equal(
    c(dim.list$n.t, dim.list$n.g - 1),
    dim(init.parm.clustTMB$parms$upsilon_tg)
  )
  expect_equal(
    c(dim.list$n.t, dim.list$n.j, dim.list$n.g),
    dim(init.parm.clustTMB$parms$epsilon_tjg)
  )
  # expect_equal(
  # c(dim.list$n.i, dim.list$n.g-1),
  # dim(init.parm.clustTMB$parms$u_ig)
  # )
  expect_equal(
    c(dim.list$n.i, dim.list$n.f.rand, dim.list$n.g),
    dim(init.parm.clustTMB$parms$v_ifg)
  )
  expect_equal(
    c(dim.list$n.v, dim.list$n.g - 1),
    dim(init.parm.clustTMB$parms$Gamma_vg)
  )
  expect_equal(
    c(dim.list$n.v, dim.list$n.f.sp, dim.list$n.g),
    dim(init.parm.clustTMB$parms$Omega_vfg)
  )
})


context("univariate normal data with covaraites")
G <- 2

z.co2 <- unmap(hclass(hc(cbind(CO2, GNP), use = "VARS"), G))
y.co2 <- as.matrix(CO2)
x.co2 <- as.matrix(GNP)
newz <- clustTMB:::run.mahala(z.co2, y.co2, x.co2)
# MoEclust Mahalanobis distance
adjz <- init.z(
  y. = data.frame(CO2 = CO2),
  dat = data.frame(CO2, GNP),
  expN = CO2 ~ GNP, g = 2
)

test_that("class", {
  expect_equal(newz, adjz)
})

context("multivariate normal data with covaraites")
data(ais)
hema <- ais[, 3:7]
hema.sb <- cbind(hema, ais$Sex, ais$BMI)
G <- 3

z.ais <- unmap(hclass(hc(hema.sb, use = "VARS"), G))
y.ais <- as.matrix(hema)
x.ais <- cbind(ais$Sex, ais$BMI)
newz <- clustTMB:::run.mahala(z.ais, y.ais, x.ais)

adjz <- init.z(
  y. = data.frame(hema),
  dat = data.frame(hema, Sex = ais$Sex, BMI = ais$BMI),
  expN = cbind(Wt, LBM, RCC, WCC, Hc) ~ Sex + BMI, g = G
)
test_that("class", {
  expect_equal(newz, adjz)
})


# test_that("mu", {
#   expect_equal(
# as.vector(init.parm.mclust$mu$g1),
# init.parm.clustTMB$parms$betad[1,,1]
# )
#   expect_equal(
# as.vector(init.parm.mclust$mu$g2),
# init.parm.clustTMB$parms$betad[1,,2]
# )
# })
# test_that("Sigma", {
#   expect_equal(
# as.vector(init.parm.mclust$Sigma$g1),
# exp(init.parm.clustTMB$parms$theta[,1])
# )
#   expect_equal(
# as.vector(init.parm.mclust$Sigma$g2),
# exp(init.parm.clustTMB$parms$theta[,2])
# )
# })
# test_that("Corr", {
#   expect_equal(
# as.vector(unlist(init.parm.mclust$Corr)),
# as.vector(1/(1+exp(-init.parm.clustTMB$parms$logit_corr_fix))*2-1)
# )
# })
# test_that("Pi", {
#   expect_equal(as.vector(unlist(init.parm.mclust$Pi)),
#                c(1/(1+exp(-init.parm.clustTMB$parms$betag)),
#                  1-1/(1+exp(-init.parm.clustTMB$parms$betag))))
# })
# test_that("Class", {
#   expect_equal(map(clss), init.parm.clustTMB$class)
# })