tests/testthat/test-tmt_rm.R

In tmt: Estimation of the Rasch Model for Multistage Tests

mstdesign <- "
    B1 =~ c(i1, i2, i3, i4, i5)
    B2 =~ c(i6, i7, i8, i9, i10)
    B3 =~ c(i11, i12, i13, i14, i15)
    B4 =~ c(i16, i17, i18, i19, i20)
    B5 =~ c(i21, i22, i23, i24, i25)
    B6 =~ c(i26, i27, i28, i29, i30)

    # define branches
    b1 := B4(0,2) + B2(0,2) + B1(0,5)
    b2 := B4(0,2) + B2(3,5) + B3(0,5)
    b3 := B4(3,5) + B5(0,2) + B3(0,5)
    b4 := B4(3,5) + B5(3,5) + B6(0,5)
  "

mstdesign_wrong <- "
    B1 =~ c(ii1, i2, i3, i4, i5)
    B2 =~ c(i6, i7, i8, i9, i10)
    B3 =~ c(i11, i12, i13, i14, i15)
    B4 =~ c(i16, i17, i18, i19, i20)
    B5 =~ c(i21, i22, i23, i24, i25)
    B6 =~ c(i26, i27, i28, i29, i30)

    # define branches
    b1 := B4(0,2) + B2(0,2) + B1(0,5)
    b2 := B4(0,2) + B2(3,5) + B3(0,5)
    b3 := B4(3,5) + B5(0,2) + B3(0,5)
    b4 := B4(3,5) + B5(3,5) + B6(0,5)
  "
mstdesign_precon <- "
  B1 =~ paste0('i', 1:10)
  B2 =~ paste0('i',11:20)
  B3 =~ paste0('i',21:30)
  B4 =~ paste0('i',31:40)
  B5 =~ paste0('i',41:50)
  B6 =~ paste0('i',51:60)

  # define constraints
  xcat == data$xcat

  # define routing criteria
  r1 = c(0.35,0.30,0.25,0.90,0.85,0.80,0.90,0.85,0.80,0.75,0.70,0.65,0.60,0.55)
  r2 = c(0.65,0.70,0.75,0.10,0.15,0.20,0.10,0.15,0.20,0.25,0.30,0.35,0.40,0.45)
  r3 = c(0.30,0.25,0.15,0.95,0.93,0.90,0.95,0.93,0.90,0.85,0.83,0.80,0.75,0.73,0.70,0.68,0.63,0.60,0.58,0.53,0.50,0.48,0.43,0.40)
  r4 = c(0.70,0.75,0.85,0.05,0.07,0.10,0.05,0.07,0.10,0.15,0.17,0.20,0.25,0.27,0.30,0.32,0.37,0.40,0.42,0.47,0.50,0.52,0.57,0.60)

  # define path
  p1:= xcat(1:4) += B4(r1) += B2(r3) += B1
  p2:= xcat(1:4) += B4(r1) += B2(r4) += B3
  p3:= xcat(1:4) += B4(r2) += B5(r3) += B3
  p4:= xcat(1:4) += B4(r2) += B5(r4) += B6
"

mstdesign_small_v1 <- "
  B1 =~ c(i1, i2, i3, i4, i5)
  B2 =~ c(i6, i7)
  B3 =~ c(i8, i9, i10, i11, i12)

  # define branches
  b1 := B2(0,0) + B1
  b2 := B2(1,2) + B3
 "

mstdesign_small_v2 <- "
  B1 =~ c(i1, i2, i3, i4, i5)
  B2 =~ c(i6, i7, i8)
  B3 =~ c(i9, i10, i11, i12,i13)

  # define branches
  b1 := B2(0,1) + B1
  b2 := B2(2,3) + B3
 "


mstdesign_small_v3 <- "
  B1 =~ c(i1, i2, i3, i4, i5)
  B2 =~ c(i6, i7)
  B3 =~ c(i8, i9, i10, i11, i12)
  
  r1 = c(0.9,0.1,0.1)
  r2 = c(0.1,0.9,0.9)

  # define branches
  b1 := B2(r1) + B1
  b2 := B2(r2) + B3
"

# Vorbereitung

dat <- tmt:::sim.rm(theta = 100, b = 5, c(1111,1112))
datna <- dat
datna[sample(seq_len(length(datna)),10,replace = FALSE)] <- NA

items <- seq(-2,2,length.out=30)
names(items) <- c(paste0("i",1:30))

items_wrong <- items
names(items_wrong)[1] <- "ii1"

items_precon <- seq(-2,2,length.out = 60)
names(items_precon) <- c(paste0("i", 1:60))

items_small_v1 <- seq(-2,2,length.out = 12)
names(items_small_v1) <- c(paste0("i", 1:12))

items_small_v2 <- seq(-2,2,length.out = 13)
names(items_small_v2) <- c(paste0("i", 1:13))

dat_mst <- tmt_sim(mstdesign = mstdesign,
			items = items,
			persons = 500,
			seed = 1111)

dat_precon1 <- tmt_sim(mstdesign = mstdesign_precon,
			items = items_precon,
			persons = 500,
      preconditions = 0.4,
			seed = 1111)

dat_small_v1 <- tmt_sim(mstdesign = mstdesign_small_v1,
			items = items_small_v1,
			persons = 1500,
			seed = 1111)

dat_small_v2 <- tmt_sim(mstdesign = mstdesign_small_v2,
			items = items_small_v2,
			persons = 1500,
			seed = 1111)

dat_mst_wrong <- dat_mst
colnames(dat_mst_wrong$data) <- names(items_wrong)

datrm_1 <- tmt_rm(dat, optimization = "optim")

dat_nlm_se <- tmt_rm(dat = dat, optimization = "nlminb", se = TRUE)
dat_opt_se <- tmt_rm(dat = dat, optimization = "optim", se = TRUE)
dat_nlm <- tmt_rm(dat = dat, optimization = "nlminb", se = FALSE)
dat_opt <- tmt_rm(dat = dat, optimization = "optim", se = FALSE)

datna_nlm_se <- tmt_rm(dat = datna, optimization = "nlminb", se = TRUE)
datna_opt_se <- tmt_rm(dat = datna, optimization = "optim", se = TRUE)
datna_nlm <- tmt_rm(dat = datna, optimization = "nlminb", se = FALSE)
datna_opt <- tmt_rm(dat = datna, optimization = "optim", se = FALSE)

datmst_opt_se <- tmt_rm(dat_mst, optimization="optim", se = TRUE)
datmst_nlm_se <- tmt_rm(dat_mst, optimization="nlminb", se = TRUE)

datmst_opt <- tmt_rm(dat_mst, optimization="optim", se = FALSE)
datmst_nlm <- tmt_rm(dat_mst, optimization="nlminb", se = FALSE)

datmst_opt_0 <- tmt_rm(dat_mst, optimization="optim", sum0 = FALSE)
datmst_nlm_0 <- tmt_rm(dat_mst, optimization="nlminb", sum0 = FALSE)

dat_nlm_0 <- tmt_rm(dat = dat, optimization = "nlminb", sum0 = FALSE)
dat_opt_0 <- tmt_rm(dat = dat, optimization = "optim", sum0 = FALSE)
datna_nlm_0 <- tmt_rm(dat = datna, optimization = "nlminb", sum0 = FALSE)
datna_opt_0 <- tmt_rm(dat = datna, optimization = "optim", sum0 = FALSE)

datrm_precon_nlm_0 <- tmt_rm(dat = dat_precon1, optimization = "nlminb", sum0 = FALSE)
datrm_precon_opt_0 <- tmt_rm(dat = dat_precon1, optimization = "optim", sum0 = FALSE)


datrm_precon_nlm_se <- tmt_rm(dat = dat_precon1, optimization = "nlminb", se = TRUE)
datrm_precon_opt_se <- tmt_rm(dat = dat_precon1, optimization = "optim", se = TRUE)
datrm_precon_nlm <- tmt_rm(dat = dat_precon1, optimization = "nlminb", se = FALSE)
datrm_precon_opt <- tmt_rm(dat = dat_precon1, optimization = "optim", se = FALSE)



datrm_smallmst_v1_nlm <- tmt_rm(dat = dat_small_v1, optimization = "nlminb", se = FALSE)
datrm_smallmst_v1_opt <- tmt_rm(dat = dat_small_v1, optimization = "optim", se = FALSE)



datrm_smallmst_v2_nlm_se <- tmt_rm(dat = dat_small_v2, optimization = "nlminb", se = TRUE)
datrm_smallmst_v2_opt_se <- tmt_rm(dat = dat_small_v2, optimization = "optim", se = TRUE)
datrm_smallmst_v2_nlm <- tmt_rm(dat = dat_small_v2, optimization = "nlminb", se = FALSE)
datrm_smallmst_v2_opt <- tmt_rm(dat = dat_small_v2, optimization = "optim", se = FALSE)


# -----------------------------------------------------------------
context("test-tmt_rm")
# -----------------------------------------------------------------
  test_that("tmt_rm data structure", {
    expect_is(dat_nlm_se,"nmst")
    expect_is(dat_opt_se,"nmst")
    expect_is(datna_nlm,"nmst")
    expect_is(datna_opt,"nmst")
    expect_is(datmst_nlm_se,"mst")
    expect_is(datmst_opt_se,"mst")
    expect_is(datmst_nlm,"mst")
    expect_is(datmst_opt,"mst")
    expect_is(datrm_precon_nlm_se,"mst")
    expect_is(datrm_precon_opt_se,"mst")
    expect_is(datrm_precon_nlm,"mst")
    expect_is(datrm_precon_opt,"mst")
  })
  test_that("tmt_rm content", {
    expect_that(tmt_rm(as.data.frame(dat_mst$data), mstdesign = mstdesign, optimization="optim")$betapar, 
        is_identical_to(tmt_rm(as.matrix(dat_mst$data), mstdesign = mstdesign, optimization="optim")$betapar))
  })

  test_that("tmt_rm se", {
    expect_that(dat_nlm_se$betapar, 
     is_identical_to(dat_nlm$betapar))
    expect_that(datna_nlm_se$betapar, 
     is_identical_to(datna_nlm$betapar))
    expect_that(dat_opt_se$betapar, 
     is_identical_to(dat_opt$betapar))
    expect_that(datna_opt_se$betapar, 
     is_identical_to(datna_opt$betapar))
    expect_that(datmst_nlm_se$betapar, 
     is_identical_to(datmst_nlm$betapar))
    expect_that(datmst_opt_se$betapar, 
     is_identical_to(datmst_opt$betapar))
    expect_that(datrm_precon_nlm_se$betapar, 
     is_identical_to(datrm_precon_nlm$betapar))
    expect_that(datrm_precon_opt_se$betapar, 
     is_identical_to(datrm_precon_opt$betapar))
  })


  test_that("tmt_rm sum0 = FALSE", {
    expect_equal(
        dat_nlm_0$betapar,
        dat_opt_0$betapar, tolerance = 0.001)
    expect_equal(
        datna_nlm_0$betapar,
        datna_opt_0$betapar, tolerance = 0.001) 
    expect_equal(
        datmst_opt_0$betapar,
        datmst_nlm_0$betapar, tolerance = 0.001)
    expect_equal(
        datrm_precon_opt_0$betapar,
        datrm_precon_opt_0$betapar, tolerance = 0.001)
  })


test_that("tmt_rm sum0 = TRUE", {
    expect_equal(
      datrm_smallmst_v1_nlm$betapar,
      datrm_smallmst_v1_opt$betapar, tolerance = 0.001)
    
    expect_equal(
      datrm_smallmst_v2_nlm_se$betapar,
      datrm_smallmst_v2_opt_se$betapar, tolerance = 0.001)
    expect_equal(
      datrm_smallmst_v2_nlm$betapar,
      datrm_smallmst_v2_opt$betapar, tolerance = 0.001)
  })


  test_that("tmt_rm structure", {
    expect_s3_class(dat_nlm_se,"nmst")
    expect_s3_class(dat_opt_se,"nmst")
    expect_s3_class(datna_nlm,"nmst")
    expect_s3_class(datna_opt,"nmst")
    expect_s3_class(datmst_opt_se,"mst")
    expect_s3_class(datmst_nlm_se,"mst")
    expect_s3_class(datmst_opt,"mst")
    expect_s3_class(datmst_nlm,"mst")
    expect_s3_class(datrm_precon_opt,"mst")
    expect_s3_class(datrm_precon_nlm,"mst")
  })

  test_that("tmt_rm preconditions", {

  tmp <- split(dat_precon1$persons,dat_precon1$preconpar[[1]]) 



    expect_is(dat_precon1,"list")
    expect_false(is.null(dat_precon1$preconpar))
    expect_length(dat_precon1$preconpar,1)
    expect_length(dat_precon1$preconpar[[1]],nrow(dat_precon1$data_mst))
    
    expect_that(datmst_nlm_se$betapar, 
     is_identical_to(datmst_nlm$betapar))
    
  })
# -----------------------------------------------------------------
context("test-tmt_rm warning and error")
# -----------------------------------------------------------------
  test_that("tmt_rm data structure", {
    expect_that(raschmodel.nmst(list(dat), optimization="optim"),
        throws_error()
        )
     expect_that(raschmodel.nmst(list(dat), optimization="nlminb"),
        throws_error()
        )
     expect_that(suppressWarnings(tmt_rm(dat_mst$data, mstdesign = mstdesign_wrong)),
        throws_error()
        )
    expect_that(suppressWarnings(tmt_rm(dat_mst_wrong$data, mstdesign = mstdesign)),
        throws_error()
        )

    expect_that(tmt_rm(dat = dat_small_v1, optimization = "nlminb", se = TRUE),
        throws_error()
        )
    # expect_that(tmt_rm(dat = dat_small_v1, optimization = "optim", se = TRUE),
    #     gives_warning()
    #     )
  })