tests/testthat/test-ModelMatrix.R

In SSBtools: Statistics Norway's Miscellaneous Tools

test_that("ModelMatrix: dimVar vs formula", {
  z3 <- SSBtoolsData("z3")
  
  set.seed(123)
  z <- z3[sample.int(nrow(z3),50), ]
  
  m1 <- ModelMatrix(z, formula = ~ region*hovedint*mnd + fylke*hovedint*mnd + kostragr*hovedint*mnd + region*hovedint*mnd2 + fylke*hovedint*mnd2 + kostragr*hovedint*mnd2, crossTable = TRUE)
  m2 <- ModelMatrix(z, formula = ~ region*hovedint*mnd + fylke*hovedint*mnd + kostragr*hovedint*mnd + region*hovedint*mnd2 + fylke*hovedint*mnd2 + kostragr*hovedint*mnd2, crossTable = TRUE, removeEmpty = FALSE)
  m3 <- ModelMatrix(z, dimVar = 1:6 , crossTable = TRUE)
  m4 <- ModelMatrix(z, dimVar = 1:6, crossTable = TRUE, removeEmpty = TRUE)
  
  ma14 <- Match(m1$crossTable, m4$crossTable)
  expect_equal(range(diff(sort(ma14))), c(1, 1))
  
  ma23 <- Match(m2$crossTable,m3$crossTable)
  expect_equal(range(diff(sort(ma23))), c(1, 1))
  
  expect_equal(max(abs(m4$modelMatrix[,ma14] -m1$modelMatrix)), 0)
  expect_equal(max(abs(m3$modelMatrix[,ma23] -m2$modelMatrix)), 0)
})


test_that("ModelMatrix: select parameter", {
  z <- SSBtoolsData("sprt_emp_withEU")
  z$age[z$age == "Y15-29"] <- "young"
  z$age[z$age == "Y30-64"] <- "old"
  ageHier <- data.frame(mapsFrom = c("young", "old"), mapsTo = "Total", sign = 1)
  geoDimList <- FindDimLists(z[, c("geo", "eu")], total = "Europe")[[1]]
  
  mm <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = "Total"), crossTable = TRUE)
  
  sel <- c(10, 3, 55, 57, 36, 33, 65, 61, 24, 58)
  selectA <- mm$crossTable[sel, ]
  selectA$year[2] <- "2023"
  selectA$age[3] <- "middle"
  selectB <- selectA[c(1, 4:10), ]
  selectC <- selectA[c(1, 1:10, 3, 4), ]
  
  
  selectD <- list(age = c("Total", "Total", "middle", "young"),
                  geo = c("nonEU", "Europe", "Portugal"), 
                  year = c("2014", "2023", "Total"))
  
  selectE <- selectD[1] 
  
  
  select <- selectA
  m1A <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), crossTable = TRUE, select = select, removeEmpty = TRUE)
  m2A <- ModelMatrix(z, formula = ~age * geo * year, crossTable = TRUE, select = select, removeEmpty = TRUE)
  m3A <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), formula = ~age * geo + year, crossTable = TRUE, select = select, removeEmpty = TRUE)
  m1A_ <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), crossTable = TRUE, select = select, removeEmpty = FALSE)
  expect_warning({m2A_ <- ModelMatrix(z, formula = ~age * geo * year, crossTable = TRUE, select = select, removeEmpty = FALSE)})
  expect_warning({m3A_ <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), formula = ~age * geo + year, crossTable = TRUE, select = select, removeEmpty = FALSE)})
  
  select <- selectB
  m1B <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), crossTable = TRUE, select = select, removeEmpty = TRUE)
  m2B <- ModelMatrix(z, formula = ~age * geo * year, crossTable = TRUE, select = select, removeEmpty = TRUE)
  m3B <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), formula = ~age * geo + year, crossTable = TRUE, select = select, removeEmpty = TRUE)
  m1B_ <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), crossTable = TRUE, select = select, removeEmpty = FALSE)
  m2B_ <- expect_warning({ModelMatrix(z, formula = ~age * geo * year, crossTable = TRUE, select = select, removeEmpty = FALSE)})
  m3B_ <- expect_warning({ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), formula = ~age * geo + year, crossTable = TRUE, select = select, removeEmpty = FALSE)})
  
  select <- selectC
  expect_warning({m1C <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), crossTable = TRUE, select = select, removeEmpty = TRUE)})
  expect_warning({m2C <- ModelMatrix(z, formula = ~age * geo * year, crossTable = TRUE, select = select, removeEmpty = TRUE)})
  expect_warning({m3C <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), formula = ~age * geo + year, crossTable = TRUE, select = select, removeEmpty = TRUE)})
  expect_warning({m1C_ <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), crossTable = TRUE, select = select, removeEmpty = FALSE)})
  expect_warning({m2C_ <- ModelMatrix(z, formula = ~age * geo * year, crossTable = TRUE, select = select, removeEmpty = FALSE)})
  expect_warning({m3C_ <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), formula = ~age * geo + year, crossTable = TRUE, select = select, removeEmpty = FALSE)})
  
  select <- selectD
  expect_warning({m1D <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), crossTable = TRUE, select = select, removeEmpty = TRUE)})
  expect_warning({m2D <- ModelMatrix(z, formula = ~age * geo * year, crossTable = TRUE, select = select, removeEmpty = TRUE)})
  expect_warning({m3D <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), formula = ~age * geo + year, crossTable = TRUE, select = select, removeEmpty = TRUE)})
  expect_warning({m1D_ <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), crossTable = TRUE, select = select, removeEmpty = FALSE)})
  expect_warning({m2D_ <- ModelMatrix(z, formula = ~age * geo * year, crossTable = TRUE, select = select, removeEmpty = FALSE)})
  expect_warning({m3D_ <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), formula = ~age * geo + year, crossTable = TRUE, select = select, removeEmpty = FALSE)})
  
  select <- selectE
  expect_warning({m1E <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), crossTable = TRUE, select = select, removeEmpty = TRUE)})
  expect_warning({m2E <- ModelMatrix(z, formula = ~age * geo * year, crossTable = TRUE, select = select, removeEmpty = TRUE)})
  expect_warning({m3E <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), formula = ~age * geo + year, crossTable = TRUE, select = select, removeEmpty = TRUE)})
  expect_warning({m1E_ <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), crossTable = TRUE, select = select, removeEmpty = FALSE)})
  expect_warning({m2E_ <- ModelMatrix(z, formula = ~age * geo * year, crossTable = TRUE, select = select, removeEmpty = FALSE)})
  expect_warning({m3E_ <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), formula = ~age * geo + year, crossTable = TRUE, select = select, removeEmpty = FALSE)})
  
  expect_equal(m1A, m1B)
  expect_equal(m2A, m2B)
  expect_equal(m3A, m3B)
  expect_equal(m1A, m1C)
  expect_equal(m2A, m2C)
  expect_equal(m3A, m3C)
  
  expect_true(all.equal(m1A_, m1C_, check.attributes = FALSE))
  expect_true(all.equal(m2A_, m2C_, check.attributes = FALSE))
  expect_true(all.equal(m3A_, m3C_, check.attributes = FALSE))
  
  expect_true(all.equal(selectB, m1B_$crossTable[names(selectB)], check.attributes = FALSE)) 
  expect_true(all.equal(selectB, m2B_$crossTable[names(selectB)], check.attributes = FALSE))
  expect_true(all.equal(selectB, m3B_$crossTable[names(selectB)], check.attributes = FALSE))
  
  m1AF <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), crossTable = FALSE, select = selectA, removeEmpty = TRUE)
  m2BF <- ModelMatrix(z, formula = ~age * geo * year, crossTable = FALSE, select = selectB, removeEmpty = TRUE)
  expect_warning({m3CF_ <- ModelMatrix(z, list(age = ageHier, geo = geoDimList, year = ""), formula = ~age * geo + year, crossTable = FALSE, select = selectC, removeEmpty = FALSE)})
  expect_equal(m1AF, m1A$modelMatrix)
  expect_equal(m2BF, m2B$modelMatrix)
  expect_equal(m3CF_, m3C_$modelMatrix)
  
  expect_true(all.equal(m1C$crossTable, m1C_$crossTable[colSums(m1C_$modelMatrix)!=0, , drop=FALSE], check.attributes = FALSE)) 
  expect_true(all.equal(m2C$crossTable, m2C_$crossTable[colSums(m2C_$modelMatrix)!=0, , drop=FALSE], check.attributes = FALSE)) 
  expect_true(all.equal(m3C$crossTable, m3C_$crossTable[colSums(m3C_$modelMatrix)!=0, , drop=FALSE], check.attributes = FALSE)) 
  
  expect_equal(m2D, m2D_)
  expect_equal(m3D, m3D_)
  expect_equal(m2E, m2E_)
  expect_equal(m3E, m3E_)
  expect_true(all.equal(m1D$crossTable, m1D_$crossTable[colSums(m1D_$modelMatrix)!=0, , drop=FALSE], check.attributes = FALSE)) 
  expect_true(all.equal(m1E$crossTable, m1E_$crossTable[colSums(m1E_$modelMatrix)!=0, , drop=FALSE], check.attributes = FALSE)) 
  
})