fix and test bracket notation for special syntax inputs

Author: philchalmers

R/03-estimation.R

@@ -262,7 +262,24 @@ ESTIMATION <- function(data, model, group, itemtype = NULL, guess = 0, upper = 1
                          customGroup=customGroup[[1L]], spline_args=spline_args, monopoly.k=monopoly.k,
                          fulldata=opts$PrepList[[1L]]$fulldata, key=key, opts=opts,
                          gpcm_mats=gpcm_mats, internal_constraints=opts$internal_constraints,
-                         dcIRT_nphi=opts$dcIRT_nphi, dentype=opts$dentype, item.Q=opts$item.Q)
+                         dcIRT_nphi=opts$dcIRT_nphi, dentype=opts$dentype, item.Q=opts$item.Q,
+                         groupName=Data$groupNames[1])
+            if(length(unique(Data$model$x[,'OptionalGroups'])) > 1){
+                for(g in 2:Data$ngroups)
+                    PrepList[[g]] <-
+                        PrepData(data=Data$data, model=Data$model, itemtype=itemtype, guess=guess,
+                                 upper=upper, parprior=parprior, verbose=opts$verbose,
+                                 technical=opts$technical, parnumber=1L, BFACTOR=opts$dentype == 'bfactor',
+                                 grsm.block=Data$grsm.block, rsm.block=Data$rsm.block,
+                                 mixed.design=mixed.design, customItems=customItems,
+                                 customItemsData=customItemsData,
+                                 customGroup=customGroup[[1L]], spline_args=spline_args, monopoly.k=monopoly.k,
+                                 fulldata=opts$PrepList[[1L]]$fulldata, key=key, opts=opts,
+                                 gpcm_mats=gpcm_mats, internal_constraints=opts$internal_constraints,
+                                 dcIRT_nphi=opts$dcIRT_nphi, dentype=opts$dentype, item.Q=opts$item.Q,
+                                 groupName=Data$groupNames[g])
+
+            }
             if(!is.null(dots$Return_PrepList)) return(PrepListFull)
             if(!is.null(itemtypefull)){
                 for(g in 2L:nrow(itemtypefull)){
@@ -276,7 +293,8 @@ ESTIMATION <- function(data, model, group, itemtype = NULL, guess = 0, upper = 1
                                  customGroup=customGroup[[1L]], spline_args=spline_args, monopoly.k=monopoly.k,
                                  fulldata=opts$PrepList[[1L]]$fulldata, key=key, opts=opts,
                                  gpcm_mats=gpcm_mats, internal_constraints=opts$internal_constraints,
-                                 dcIRT_nphi=opts$dcIRT_nphi, dentype=opts$dentype, item.Q=opts$item.Q)
+                                 dcIRT_nphi=opts$dcIRT_nphi, dentype=opts$dentype, item.Q=opts$item.Q,
+                                 groupName=Data$groupNames[g])
                 }
             }
         }
@@ -291,7 +309,7 @@ ESTIMATION <- function(data, model, group, itemtype = NULL, guess = 0, upper = 1
             matrix(sapply(PrepListFull$pars, function(y) length(y@parnum)), nrow=1L)
         for(g in seq_len(Data$ngroups)){
             if(g != 1L){
-                if(is.null(itemtypefull))
+                if(is.null(itemtypefull) && length(unique(Data$model$x[,'OptionalGroups'])) == 1)
                     PrepList[[g]] <- list(pars=PrepList[[1L]]$pars)
                 else attr(PrepList[[g]]$pars, 'nclasspars') <-
                         sapply(PrepList[[g]]$pars, function(y) length(y@parnum))

R/04-PrepData.R

@@ -2,8 +2,11 @@ PrepData <- function(data, model, itemtype, guess, upper, gpcm_mats, opts,
                      parprior, verbose, technical, parnumber = 1, BFACTOR = FALSE,
                      grsm.block = NULL, rsm.block = NULL, mixed.design, customItems,
                      customGroup, customItemsData, fulldata = NULL, key,
-                     spline_args, internal_constraints, monopoly.k, dentype, dcIRT_nphi, item.Q)
+                     spline_args, internal_constraints, monopoly.k, dentype, dcIRT_nphi, item.Q,
+                     groupName)
 {
+    pick <- sapply(strsplit(model$x[,'OptionalGroups'], ','), \(x) any(x == groupName))
+    model$x <- model$x[pick, , drop=FALSE]
     if(is.null(grsm.block)) grsm.block <- rep(1, ncol(data))
     if(is.null(rsm.block)) rsm.block <- rep(1, ncol(data))
     grsm.block[!itemtype %in% c('grsm', 'grsmIRT')] <- NA

R/05-model.elements.R

@@ -2,7 +2,7 @@ model.elements <- function(model, factorNames, itemtype, nfactNames, nfact, J, K
                            itemloc, data, N, guess, upper, itemnames, exploratory, parprior,
                            parnumber, BFACTOR = FALSE, mixed.design, customItems, customItemsData,
                            dentype, item.Q, customGroup, key, gpcm_mats, spline_args,
-                           monopoly.k, dcIRT_nphi = NULL)
+                           monopoly.k, dcIRT_nphi = NULL, groupName)
 {
     hasProdTerms <- ifelse(nfact == nfactNames, FALSE, TRUE)
     prodlist <- NULL

tests/testthat/test-09-mirt.model.R

@@ -45,6 +45,11 @@ test_that('syntax', {
                           FIXED = (1-5, a1)
                           START = (1-5, a1, 1.0)
                           FREE = (GROUP, COV_11)")
+    model15 <- mirt.model("F = 1-5
+                          FIXED [female] = (1-5, a1)
+                          START [female] = (1-5, a1, 1.0)
+                          FREE [male] = (GROUP, COV_11)
+                          MEAN [male] = F")
 
     mod0 <- mirt(data, model0, verbose=FALSE, calcNull=FALSE)
     expect_equal(mod2values(mod0)$value, c(0.9879254,1.85606,0,1,1.080885,0.8079786,0,1,1.705801,1.804219,0,1,0.7651853,0.4859966,0,1,0.735798,1.854513,0,1,0,1),
@@ -91,6 +96,10 @@ test_that('syntax', {
     mod14 <- mirt(data, model14, verbose = FALSE)
     expect_equal(mod2values(mod14)$value, c(1,1.868016,0,1,1,0.7908857,0,1,1,1.46078,0,1,1,0.5214175,0,1,1,1.99271,0,1,0,1.021912),
                  tolerance = 1e-2)
+    mod15 <- multipleGroup(data, model15, group=group, verbose = FALSE)
+
+    expect_equal(as.integer(mod2values(mod15)$est), c(0,1,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,0,1,1,0,0,1,1,0,0,1,1,0,0,1,1,0,0,1,1,0,0,1,1))
+
 
     data(data.read, package = 'sirt')
     dat <- data.read