R/Wpermut.R

In christinehohensinn/parAL: Goodness-of-fit of the user-defined weight matrix of the linear logistic test model

#'generate permutated weight matrices
#'
#'generate weight matrices that permutate rows from the original weight matrix
#'
#'The original weight matrix is taken and new weight matrices are generated by permutating the rows of the original matrix. The permutations are drawn randomly. Duplicated permutations are eliminated - thus the user-defined number of replications can deviate from the number of generated weight matrices. For each generated weight matrix, an LLTM is estimated using the function \code{DRM} of the R package pcIRT. A Rasch model is estimated for the original data set using the function \code{DRM} from pcIRT. The item parameters estimated by the Rasch model are correlated with the item parameters reconstructed from the parameters estimated by the LLTM.
#'
#'
#'@param datmat data file
#'@param weightmat original weight matrix
#'@param repl number of weight matrices that are generated
#'@param keepmat if TRUE, the generated random weight matrices are kept in an three-dimensional array
#'
#'@return 
#'\item{conv}{convergence of the estimated LLTMs of the generated weight matrices}
#'\item{npermut}{number of generated weight matrices}
#'\item{nchange}{matrix with the frequencies of the number of rows that were changed in the generated weight matrices}
#'\item{hchange}{vector with the number of changed rows for each permutation}
#'\item{raschpar}{estimated Rasch model item parameters for the original data set}
#'\item{lltmpar}{item parameters reconstructed from the estimated parameters of the LLTM of the generated weight matrices}
#'\item{corlr}{correlation of the re-constructed item parameters by the LLTM and the estimated item parameters of the original Rasch model}
#'\item{sumcorlr}{short summary descriptive statistics of the correlations}
#'\item{randommat}{array containing the generated weight matrices (if argument keepmat is set TRUE)}
#'
#' @importFrom sna numperm
#'
#' @author Christine Hohensinn
#' 
#' @keywords random weight matrix, linear logistic test model
#' @references 
#' Baghaei, P. & Hohensinn, C. (submitted). A Method of Q-Matrix Validation for the Linear Logistic Test Model.
#' 
#' Fischer, G. H. (1973). The linear logistic test model as an instrument in educational research. Acta Psychologica, 37, 359-374.
#'
#' @examples
#'
#' #generate three permutated weight matrices for example data set
#' data(exampledata)
#' data(exampleweight)
#' 
#' Wpermut(exdat, orig.weight, repl=3)
#'
#' @export Wpermut
#' @rdname wpermut


Wpermut <- function(datmat, weightmat, repl=100, keepmat=FALSE){
  datmat <- as.matrix(datmat)
  weightmat <- as.matrix(weightmat)
  if(!all(datmat %in% c(0,1))){stop("data matrix has to contain only 0 and 1s")}
  if(!all(weightmat %in% c(0,1))){stop("weight matrix has to contain only 0 and 1s")}
  if(repl > 1000){warning("The defined number of replications is high. The process may take some time!")}
  
permuts <- t(sapply(1:repl,numperm,olength=ncol(datmat)))

if(anyDuplicated(permuts)!=0){
  warning("There are duplicated weight matrices that are eliminated. The actual replication number deviates from the user-defined number!")
  permuts <- unique(permuts)
  }

#how many rows switched
hchanged <- apply(permuts, 1, function(x) sum(x!=c(1:ncol(datmat))))
tch <- table(hchanged)
tchn <- rbind(as.numeric(names(tch)), tch)
row.names(tchn) <- c("rows changed", "freq")
colnames(tchn) <- NULL

changed <- sort(hchanged)
so <- order(hchanged)

permuts.o <- permuts[so,]

#objects for results
conv <- rep(NA, length=repl)
lltmpar <- matrix(NA, nrow=nrow(weightmat), ncol=repl)
corlr <- rep(NA, length=repl)

if(keepmat){
  randommat <- array(NA, dim=c(nrow(weightmat), ncol(weightmat),repl))
} else {
  randommat <- NULL
}

#Rasch model with original data
rasch <- DRM(datmat)

#generate weight matrices
for(j in 1:nrow(permuts.o)){
  qm <- weightmat[permuts.o[j,],]
  
  lltz <- DRM(datmat, desmat=qm)
  lltzbeta.norm <- lltz$itempar-mean(lltz$itempar)
  
  #correlation
  korr <- cor(rasch$itempar, lltzbeta.norm)
  
  #save results
  conv[j] <- lltz$convergence
  lltmpar[,j] <- lltzbeta.norm
  corlr[j] <- korr
  
  if(keepmat){
    randommat[,,j] <- qm
  } else {
    randommat <- NULL
  }
  
  rm(lltz, lltzbeta.norm, qm)
}

sumcorlr <- c(min(corlr), median(corlr), mean(corlr), quantile(corlr, probs=c(0.95)), max(corlr))
names(sumcorlr) <- c("Min.", "Median", "Mean", "95%", "Max.")

res <- list(conv=conv, npermut=nrow(permuts), nchange=tchn, hchange=hchanged, lltmpar=lltmpar, raschpar=rasch$itempar, corlr=corlr, sumcorlr=sumcorlr, randommat=randommat)

class(res) <- "wpermut"

res

}