Bug fixed - v.1.0.0

Author: Wenchao-Ma

DESCRIPTION

@@ -1,16 +1,36 @@
 Package: GDINA
 Type: Package
 Title: The Generalized DINA Model Framework
-Version: 1.0.0
-Date: 2016-12-12
+Version: 1.1.0
+Date: 2017-1-2
 Authors@R: c(person(given = "Wenchao",family = "Ma", role = c("aut", "cre"),email = "wenchao.ma@rutgers.edu"),person(given = "Jimmy", family = "de la Torre", role = "aut"))
-Description: A set of psychometric tools for cognitive diagnostic analyses for both dichotomous and polytomous responses. Various cognitive diagnosis models (CDMs) can be estimated, include the generalized deterministic inputs, noisy and gate (G-DINA) model by de la Torre (2011) <DOI:10.1007/s11336-011-9207-7>, the sequential G-DINA model by Ma and de la Torre (2016)<DOI:10.1111/bmsp.12070>, and many other models they subsume. Joint attribute distribution can be saturated, higher-order or structured. Q-matrix validation, item and model fit statistics, model comparison at test and item level and differential item functioning can also be conducted. A graphical user interface is also provided.
+Description: A set of psychometric tools for cognitive diagnostic analyses for
+    both dichotomous and polytomous responses. Various cognitive diagnosis models
+    (CDMs) can be estimated, include the generalized deterministic inputs, noisy
+    and gate (G-DINA) model by de la Torre (2011) <DOI:10.1007/s11336-011-9207-7>,
+    the sequential G-DINA model by Ma and de la Torre (2016)<DOI:10.1111/bmsp.
+    12070>, and many other models they subsume. Joint attribute distribution can
+    be saturated, higher-order or structured. Q-matrix validation, item and model
+    fit statistics, model comparison at test and item level and differential item
+    functioning can also be conducted. A graphical user interface is also provided.
 License: GPL-3
 LazyData: TRUE
 Depends:
     R (>= 3.1.0)
 Imports:
-    stats, graphics, utils, Rcpp (>= 0.12.1), nloptr, MASS, numDeriv, alabama, Rsolnp, ggplot2, shiny, shinydashboard
+    stats,
+    graphics,
+    utils,
+    Rcpp (>= 0.12.1),
+    nloptr,
+    MASS,
+    numDeriv,
+    alabama,
+    Rsolnp,
+    ggplot2,
+    shiny,
+    shinydashboard,
+    data.table
 Suggests:
     testthat
 LinkingTo: Rcpp, RcppArmadillo
@@ -57,6 +77,7 @@ Collate:
     'plotIRF.GDINA.R'
     'plotPVAF.Qval.R'
     'print.GDINA.R'
+    'rowCount.R'
     's3GDINA.R'
     'sim10GDINA.R'
     'sim20seqGDINA.R'

R/personparm.GDINA.R

@@ -64,12 +64,12 @@ personparm.GDINA <- function(object,
         }
         colnames(out)[1:K] <- paste("A",1:K,sep = "")
       }else if(what=="MLE"){
-        if(max(Q) > 1) stop("Please use EAP.att for polytomous attributes.", call. = FALSE)
-        out <- data.frame(MLE=pattern[max.col(extract.GDINA(object,what = "logposterior.i")),],
-                          multimodes=as.logical(rowSums(extract.GDINA(object,what = "logposterior.i")==apply(extract.GDINA(object,what = "logposterior.i"),1,max))-1))
+        if(max(Q) > 1) stop("Please use EAP for polytomous attributes.", call. = FALSE)
+        out <- data.frame(MLE=pattern[max.col(extract.GDINA(object,what = "loglikelihood.i")),],
+                          multimodes=as.logical(rowSums(extract.GDINA(object,what = "loglikelihood.i")==apply(extract.GDINA(object,what = "loglikelihood.i"),1,max))-1))
         colnames(out)[1:K] <- paste("A",1:K,sep = "")
       }else if(what=="MAP"){
-        if(max(Q) > 1) stop("Please use EAP.att for polytomous attributes.", call. = FALSE)
+        if(max(Q) > 1) stop("Please use EAP for polytomous attributes.", call. = FALSE)
         out <- data.frame(MAP=pattern[max.col(extract.GDINA(object,what = "logposterior.i")),],
                           multimodes=as.logical(rowSums(extract.GDINA(object,what = "logposterior.i")==apply(extract.GDINA(object,what = "logposterior.i"),1,max))-1))
         colnames(out)[1:K] <- paste("A",1:K,sep = "")

R/print.GDINA.R

@@ -5,7 +5,7 @@ print.GDINA <-
   {
     cat("\nThe Generalized DINA Model Framework  \n")
     packageinfo <- utils::packageDescription("GDINA")
-    cat( paste( "   Beta Version " , packageinfo$Version , " (" , packageinfo$Date , ")" , sep="") , "\n" )
+    cat( paste( "   Version " , packageinfo$Version , " (" , packageinfo$Date , ")" , sep="") , "\n" )
     cat("\nCall:\n", paste(deparse(extract.GDINA(x,"call")), sep = "\n", collapse = "\n"),
         "\n", sep = "")
     cat("\nNumber of items       =", extract.GDINA(x,"nitem"), "\n")

R/rowCount.R

@@ -0,0 +1,42 @@
+#' Count and label unique rows in data frame
+#'
+#' @param df a data frame or matrix
+#'
+#' @return freq the number of rows
+#' @return group the data frame with a column named row.no giving unique labels for all unique rows
+#' @export
+#' @import data.table
+#' @examples
+#'
+#' df <- data.frame(V1=c(1L,2L),V2=LETTERS[1:3],V3=rep(1,12))
+#' rowCount(df)
+#'
+#'
+#'
+rowCount <- function(df){
+  DT <- data.table(df)
+  varb <- colnames(DT)
+  freq <- DT[,.N,by=c(varb)]
+  DT$gr <- as.numeric(factor(apply(DT,1,paste0,collapse="")))
+  return(list(freq=data.frame(freq),group=data.frame(DT)))
+}
+
+#' Count the frequency of a row vector in a data frame
+#'
+#' @param df a data frame or matrix
+#'
+#' @return count the number of vector vec in the data frame
+#' @return row.no row numbers of the vector vec in the data frame
+#' @export
+#'
+#' @examples
+#'
+#' df <- data.frame(V1=c(1L,2L),V2=LETTERS[1:3],V3=rep(1,12))
+#' rowMatch(df,c(2,"B",1))
+#'
+#'
+#'
+rowMatch <- function(df,vec=NULL){
+  logicalvec <- apply(df,1,paste0,collapse="")==paste0(vec,collapse = "")
+  return(list(count=sum(logicalvec),row.no=which(logicalvec)))
+}

R/utils.R

@@ -495,24 +495,6 @@ seq_coding <- function(dat,Q){
   return(out)
 }
 
-Rmatrix.att <- function(K){
-  R <- vector("list",K)
-  Lk <- 2^K
-  if (K<=1) return(warning("K must be 2 or more!"))
-  # gives which groups should be set to equal
-  pattK <- alpha(K)
-  pattK_1 <- alpha(K-1)
-  for(a in 1:K){
-    Rk <- matrix(0,Lk/2,Lk)
-    for (l in 1:nrow(pattK_1)){
-      loc <- which(apply(pattK[,-a,drop=FALSE],1,function(x){all(x==pattK_1[l,])}))
-      Rk[l,loc[1]] <- 1
-      Rk[l,loc[2]] <- -1
-    }
-    R[[a]] <- Rk
-  }
-  return(R)
-}
 
 
 bdiag <- function(mlist,fill=0){
@@ -634,3 +616,56 @@ scorefunc <- function(object,...){
   list(score = scof$score, index = index)
 }
 
+Rmatrix.vec <- function(K){
+  patt <- alpha(K)
+  eta <- eta.loc(patt[-c(1,nrow(patt)),])
+  Rv <- vector("list",nrow(eta))
+  for (r in 1:nrow(eta)){
+    for(lc in seq_len(max(eta[r,]))){
+      loc <- which(eta[r,]==lc)
+      tmp <- matrix(0,length(loc)-1,2^K)
+      tmp[,loc[1]] <- 1
+      tmp[cbind(seq_len(length(loc)-1),loc[-1])] <- -1
+      Rv[[r]] <- rbind(Rv[[r]],tmp)
+    }
+  }
+  return(Rv)
+}
+
+
+Rmatrix.att <- function(K){
+  R <- vector("list",K)
+  Lk <- 2^K
+  if (K<=1) return(warning("K must be 2 or more!"))
+  # gives which groups should be set to equal
+  pattK <- alpha(K)
+  pattK_1 <- alpha(K-1)
+  for(a in 1:K){
+    Rk <- matrix(0,Lk/2,Lk)
+    for (l in 1:nrow(pattK_1)){
+      loc <- which(apply(pattK[,-a,drop=FALSE],1,function(x){all(x==pattK_1[l,])}))
+      Rk[l,loc[1]] <- 1
+      Rk[l,loc[2]] <- -1
+    }
+    R[[a]] <- Rk
+  }
+  return(R)
+
+
+}
+
+
+valQrate <- function(trueQ,misQ,valQ){
+  Qs <- data.frame(trueQ=c(as.matrix(trueQ)),misQ=c(as.matrix(misQ)),valQ=c(as.matrix(valQ)))
+  CR <- data.frame(true2mis=
+                     apply(matrix(c(0,0,
+                                    1,1,
+                                    0,1,
+                                    1,0),ncol = 2,byrow = TRUE),1,function(x)rowMatch(Qs[,-3],x)$count),
+                   mis2val=apply(matrix(c(0,0,0,
+                                          1,1,1,
+                                          0,1,0,
+                                          1,0,1),ncol = 3,byrow = TRUE),1,function(x)rowMatch(Qs,x)$count),
+                   row.names = c("000/00","111/11","010/01","101/10"))
+  return(CR)
+}