R/MCNPC.R

In NPCDTools: The Nonparametric Classification Methods for Cognitive Diagnosis

#' @title The Nonparametric Classification Method for Multiple-Choice Items
#'
#' @description
#' Function \code{MCNPC} is used to estimate examinees' attribute profiles using the general nonparametric classification method for multiple-choice items (MC-NPC).
#' Different from the traditional multiple-choice items where distractors are not coded, Some or all of the distractors are coded and responses are polytomous.
#' Studies have shown that such a format will increase the classification rates compared to the binary format.
#'
#' @param dat A \eqn{N \times J} polytomous data matrix consisting of the responses from \eqn{N} examinees to \eqn{J} items.
#' @param mcQ A \eqn{\sum_{j=1}^J H_j \times (K+2)} binary matrix where \eqn{H_j} is the number of coded options for item \eqn{j}.
#' The first and second columns contain the IDs of the items and the IDs of the coded options. Columns 3 to \eqn{K+2} contains the q-entries of the coded options.
#' For each item, the first row is designated to the key and the others are to the coded distractors.
#' @param H The number of options. By default, all items have the same number of options.
#' @param LS A matrix representing the possible attribute patterns in the data. The default (= NULL) is the \eqn{2^K} attribute patterns expanded by the \eqn{K} binary attributes.
#' It can also take user-specified attribute patterns.
#'
#' @return The function returns
#' \describe{
#' \item{att}{The estimated attribute patterns}
#' \item{classID}{The estimated class memberships}
#' \item{distance order}{The order of latent classes based on the corresponding distances}
#' \item{distance}{The calculated distances associated with the possible latent classes}
#' \item{latentclass}{The possible latent classes in the data}
#' }
#'
#' @export
#'
MCNPC <- function(dat, mcQ, H, LS = NULL) {
  # input: matrix not a list
  # LS: a matrix

  K = ncol(mcQ) - 2
  J = ncol(dat)
  N = nrow(dat)
if (is.null(LS)){
  LatentClass <- class.generate(K)
  M = 2^K
} else {
  LatentClass <- as.matrix(LS)
  M = nrow(LS)
  
  if (ncol(mcQ) != ncol(LatentClass) + 2) {
    stop(
      paste0(
        "Invalid Q-matrix for `MCNPC()`: expected an option-level Q-matrix.\n",
        "`mcQ` must have ", ncol(LatentClass) + 2,
        " columns: item ID, option ID, and ", ncol(LatentClass), " attribute columns.\n",
        "Current `mcQ` has ", ncol(mcQ), " columns."
      ),
      call. = FALSE
    )
  }
}
  
  if(length(H) == 1){
    H <- rep(H, J)
  } else {
    H <- H
  }

  item.no <- mcQ[, 1]

  save.m <- c()
  key <- c()
  for (i in 1:J) {
    j.id = unique(item.no)[i]

    key[i] <- mcQ[, 2][min(which(mcQ[, 1] == j.id))]
    save.m <- c(save.m, length(which(mcQ[, 1] == j.id)))
  }



  eta.class <- epc.generate(mcQ, H, key,LatentClass) # "scored" option

  score.op <- score.option(mcQ, H)

  # number of coded options is larger than the noncoded options
  w.class <- matrix(1, J, M)
  for (j in 1:J){
    p = 1 / H[j]
    w = seq(1, 0, by = -p)[-c(1, H[j], H[j] + 1)]
    if (2 <= save.m[j] && save.m[j]<= (H[j] - 1)){
      w.class[j, which(eta.class[j, ] == 0)] = w[save.m[j] - 1]
    } else if (save.m[j] == H[j]){
      w.class[j, which(eta.class[j, ] == 0)] = 0
    }
  }

  ### score examinees's responses
  score.response <- matrix(0,
                           nrow = N,
                           ncol = J,
                           byrow = TRUE)
  for (j in 1:J) {
    gl <- score.op[[j]]
    op <- c(1:H[j])
    for (h in 1:H[j]) {
      score.response[, j][which(dat[, j] == h)] <-
        gl[, 2][which(gl[, 1] == h)]
    }
  }

  dis.ham <- vector(length = N, mode = "list")
  dis.order <- matrix(nrow = N, ncol = M)
  dis.all <- matrix(nrow = N, ncol = M)
  for (i in 1:N) {
    # cat("The estimation by the MC-NPC is in process: ",i,"/",N,"\n")
    d <- apply(t(eta.class), 1, function(x) {
      x - score.response[i, ]
    })
    d <- matrix(d, byrow = FALSE, ncol = M)
    d.hamming <- apply(d, c(1, 2), function(x) {
      ifelse(x != 0, 1, 0)
    })
    sum.d <- diag(t(d.hamming) %*% w.class)
    dis.all[i, ] <- sum.d

    dis.order[i, ] <- order(sum.d, decreasing = FALSE)

    min.d <- which(sum.d == min(sum.d))
    x = ifelse(length(min.d) == 1, min.d, sample(min.d, 1))

    dis.ham[[i]] <- x
  }

  class.ham <- unlist(dis.ham)
  est.att.ham <- matrix(nrow = N, ncol = K)
  for (i in 1:length(class.ham)) {
    est.att.ham[i, ] <- LatentClass[class.ham[i], ]
  }

  colnames(est.att.ham) = paste0("Att", 1:K)
  rownames(est.att.ham) = paste0("Examinee", 1:N)
  out = list(
    "att"            = est.att.ham,
    "classID"        = class.ham,
    "distance.order" = dis.order,
    "distance"       = dis.all,
    "latentclass"    = LatentClass
  )
  class(out) = "MCNPC"
  return(out)
}

#' @export
print.MCNPC = function(x, ...){
  N = nrow(x$att)
  K = ncol(x$att)
  M = nrow(x$latentclass)
  
  cat("MC-NPC attribute profile estimation\n")
  cat("-----------------------------------\n")
  
  cat("Components (access with $):\n")
  cat("  $att            : ", N, "x", K, "data frame of estimated attribute profiles\n")
  cat("  $classID        : length-", N, " vector of estimated class memberships\n", sep = "")
  cat("  $`distance.order`: ", N, "x", M, "matrix of latent classes ordered by distance\n")
  cat("  $distance       : ", N, "x", M, "matrix of distances to each latent class\n")
  cat("  $latentclass    : ", M, "x", K, "matrix of possible latent classes\n\n")
  
  cat("Preview of $att (first", min(6, N), "examinees):\n")
  print(utils::head(x$att, 6))
  
  invisible(x)
}