R/simMPRM.R

In pcIRT: IRT Models for Polytomous and Continuous Item Responses

#' simulate data according to MPRM
#' 
#' With this function data sets according to the multidimensional polytomous
#' Rasch model (MPRM) are simulated
#' 
#' Data are generated with category values starting with 0. Thus the first row
#' of the matrix containing the item parameters is matched to the category
#' value 0 and so on. The last category is the reference category. Please note,
#' that the item category parameters of the last category have to be 0 (due to
#' parameter normalization)!
#' 
#' Person parameters are generated by a standard normal distribution.
#' 
#' @param itempar a matrix with item category parameters; each row represents a
#' category and each column an item (see details)
#' @param persons an integer representing the number of persons (observations)
#' of the data set (see details)
#' @param seed a seed for the random number generated can optionally be set
#' @return \item{datmat}{simulated data set} \item{true_itempar}{the fixed item
#' parameters according to the input} \item{true_perspar}{the fixed person
#' parameters}
#' @author Christine Hohensinn
#' @seealso \code{\link{simCRSM}}
#' @references Fischer, G. H. (1974). Einfuehrung in die Theorie
#' psychologischer Tests [Introduction to test theory]. Bern: Huber.
#' 
#' Rasch, G. (1961). On general laws and the meaning of measurement in
#' psychology, Proceedings Fourth Berekely Symposium on Mathematical
#' Statistiscs and Probability 5, 321-333.
#' @examples
#' 
#' #set item parameters
#' item_p <- rbind(matrix(c(-1.5,0.5,0.5,1,0.8,-0.3, 0.2,-1.2), ncol=4),0)
#' 
#' #number of persons
#' pn <- 500
#' 
#' #simulate data set
#' simdatM <- simMPRM(item_p, pn)
#' 
#' @export simMPRM
simMPRM <-
function(itempar, persons=500, seed=NULL){

#normalization of person parameters
kateg <- nrow(itempar)

ppar <- rnorm(persons*kateg, 0,1)

lauf <- seq(1,length(ppar), by=kateg)
for (l in lauf) {
  ppar[l:(l+kateg-1)] <- ppar[l:(l+kateg-1)] - ppar[l+kateg-1]    
  }
items <- ncol(itempar)
itmat <- matrix(rep(itempar*(-1), persons), ncol=items*kateg, byrow = TRUE)

persmat <- matrix(ppar, nrow=persons, byrow=T)

persmat.ext <- matrix(rep(persmat,items), ncol=items*kateg, byrow=FALSE)

zahler <- exp(persmat.ext+itmat)

nenn <- sapply(seq(1,kateg*items, by=kateg), function(y) rowSums(zahler[,y:(y+kateg-1)], na.rm=TRUE))
nenn.est <- matrix(rep(nenn, each=kateg),ncol=items*kateg,byrow=TRUE)


prob.mat <- mapply(function(z,n) zahler[,z]/nenn[,n], z=1:(kateg*items), n=rep(1:items, each=kateg))

if (!is.null(seed)) {set.seed(seed)}
   
datmat <- t(apply(prob.mat, 1, function(ma){
         sapply(seq(1,kateg*items, by=kateg), function(ma2) {sample(0:(kateg-1),size=1,prob=ma[ma2:(ma2+kateg-1)])})
      }))

return(list(datmat=datmat, true_itempar=itempar, true_perspar=ppar))
}