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))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.