R/mcQ.generate.R

In NPCDTools: The Nonparametric Classification Methods for Cognitive Diagnosis

#' @title Generation of Plausible and Proper Q-matrix with Coded Distractors
#'
#' @description This function generates a useful and proper Q-matrix based on a dichotomous Q-matrix.
#'
#' @param Q The dichotomous Q-matrix that the MC Q-matrix is based on
#' @param H The number of maximal attributes required by the items. H takes values 3, 4, 5, or 6.
#'
#' @return The function returns
#' \describe{
#' \item{mcq}{The useful and proper Q-matrix with coded distractors}
#' \item{key}{The keys of the MC items}
#' \item{H_star}{The number of coded options}
#' }
#'
#' @export
#'
mcQ.generate = function(H, Q) {
  mc.q <- c()
  key <- c()
  save.m <- c()

  J <- nrow(Q)
  K <- ncol(Q)
  q.matrix <- cbind(Q, rowSums(Q))

  for (i in 1:J) {
    num <- q.matrix[i, K + 1]

    if (H == 3) {
      p1 = c(0.8, 0.1, 0.1)
      p2 = c(0.2, 0.2, 0.6)
      p3 = c(0.2, 0.2, 0.2)
    } else if (H == 4) {
      p1 = c(0.7, 0.2, 0.1, 0)
      p2 = c(0.1, 0.2, 0.2, 0.5)
      p3 = c(0.1, 0.2, 0.2, 0.1)
    } else {
      # p1 = c(0.7, 0.1, 0.1, 0.1, 0)
      # p2 = c(0.1, 0.1, 0.1, 0.1, 0.6)
      # p3 = c(0.1, 0.1, 0.1, 0.1, 0.1)
      ## to acoomodate the large number of options
      p1 = rep(0.1,H)
      p1[1] = 0.7
      p2 = rep(0.1,H)
      p2[H] = 0.7
      p3 = rep(0.1,H)
    }

    if (num == 1) {
      p = p1
    } else if (num >= H) {
      p = p2
    } else {
      p = p3
      p[num] = 0.6
    }

    m <- sample(1:H, 1, prob = p)
    sub.q <- matrix(0, nrow = H, ncol = K)
    od.option <- sample(1:H, H)
    id.key <- od.option[1]
    sub.q[1, ] <- q.matrix[i, 1:K]

    r.q.key <- which(q.matrix[i, 1:K] == 1)
    not.q.key <- which(q.matrix[i, 1:K] == 0)
    cb <-
      expand.grid(lapply(r.q.key, function(x)
        (c(0, x))))[1:(2 ^ num - 1), , drop = FALSE]  ## keep dataframe
    cb2 <- expand.grid(lapply(not.q.key, function(x)
      (c(0, x))))

    # remaining m-1 coded options
    if (m == 2) {
      x1 = sample(nrow(cb), 1)
      x2 = ifelse(x1 == 1, sample(2:nrow(cb2), 1), sample(nrow(cb2), 1))

      v <- rep(0, K)
      loc <- unlist(c(cb[x1, ], cb2[x2, ]))
      v[loc] = 1
      sub.q[2, ] <- v

    } else if (m > 2 && m <= nrow(cb)) {
      ### two possibilities: 1) nested within the key; 2) nested within the first generated "large" q-vector
      ### No hybrid!!!

      nest <- sample(c(1, 0), 1)
      nest <- ifelse(num == K, 1, nest)

      m0 = m
      if (nest == 1) {
        ### nested within the key
        x1 = sample(2:nrow(cb), m - 1, replace = FALSE)

        v.matrix <- matrix(0, nrow = m - 1, ncol = K)
        for (ttt in 1:(m - 1)) {
          loc <- unlist(cb[x1[ttt], ])
          v.matrix[ttt, loc] = 1
        }

        largest.d <- v.matrix[which.max(rowSums(v.matrix)), ]
        r.large.d <- which(largest.d == 1)
        sub.q[2, ] <- largest.d

        full.q <- q.matrix[i, 1:K]

        abc = 1
        complement = 0
        sub.ava = length(r.large.d) > 1

        while (abc <= (m0 - 2) && complement == 0 && sub.ava) {
          complt.largest <- full.q - largest.d
          complement = sample(c(0, 1), 1) ## of select the complement, the selection of distractors ends

          if (complement == 1) {
            if (sum(complt.largest) == 0) {
              m = 2 + abc - 1
            } else {
              sub.q[2 + abc, ] <- complt.largest
              m = 2 + abc
            }

          } else {
         if (sub.ava) {
              full.q <- sub.q[abc + 1, ]
              cb3 <-
                expand.grid(lapply(r.large.d, function(x)
                  (c(0, x))))[2:(2 ^ length(r.large.d) - 1), , drop = FALSE]

              x1 = sample(2:nrow(cb3), m0 - 1 - abc, replace = TRUE)

              v.matrix <- matrix(0, nrow = m0 - 1 - abc, ncol = K)
              for (ttt in 1:nrow(v.matrix)) {
                loc <- unlist(cb3[x1[ttt], ])
                v.matrix[ttt, loc] = 1
              }

              largest.d <- v.matrix[which.max(rowSums(v.matrix)), ]
              r.large.d <- which(largest.d == 1)
              sub.q[2 + abc, ] <- largest.d

              m = 2 + abc
              abc = abc + 1
              sub.ava = length(r.large.d) > 1

            } else {
              m = 2 + abc - 1
            }
          }
        }
      } else {
        ### nested within the first generated "large" q-vector
        x2 = sample(2:nrow(cb2), m - 1, replace = TRUE)

        v.matrix <- matrix(0, nrow = m - 1, ncol = K)
        for (ttt in 1:(m - 1)) {
          loc <- unlist(cb2[x2[ttt], ])
          v.matrix[ttt, loc] = 1
        }
        largest.d <- v.matrix[which.max(rowSums(v.matrix)), ]
        r.large.d <- which(largest.d == 1)
        sub.q[2, ] <- largest.d

        full.q <- largest.d

        abc = 1
        complement = 0
        sub.ava = length(r.large.d) > 1

        while (abc <= (m0 - 2) && complement == 0 && sub.ava) {
          complt.largest <- full.q - largest.d
          # complement = sample(c(0,1),1) ## of select the complement, the selection of distractors ends

          if (complement == 1) {
            if (sum(complt.largest) == 0) {
              m = 2 + abc - 1
            } else {
              sub.q[2 + abc, ] <- complt.largest
              m = 2 + abc
            }
          } else {
            if (sub.ava) {
              full.q <- sub.q[abc + 1, ]
              cb3 <-
                expand.grid(lapply(r.large.d, function(x)
                  (c(0, x))))[2:(2 ^ length(r.large.d) - 1), , drop = FALSE]

              x1 = sample(2:nrow(cb3), m0 - 1 - abc, replace = TRUE)

              v.matrix <- matrix(0, nrow = m0 - 1- abc, ncol = K)
              for (ttt in 1:nrow(v.matrix)) {
                loc <- unlist(cb3[x1[ttt], ])
                v.matrix[ttt, loc] = 1
              }
              largest.d <- v.matrix[which.max(rowSums(v.matrix)), ]
              r.large.d <- which(largest.d == 1)
              sub.q[2 + abc, ] <- largest.d

              m = 2 + abc
              abc = abc + 1
              sub.ava = length(r.large.d) > 1
              complement = sample(c(0, 1), 1) ## of select the complement, the selection of distractors ends

            } else {
              m = 2 + abc - 1
            }
          }
        }
      }
    } else if (m > nrow(cb)) {
      ### one possibility: nested within the first generated "large" q-vector
      m0 = m

      x2 = sample(2:nrow(cb2), m - 1, replace = TRUE)

      v.matrix <- matrix(0, nrow = m - 1, ncol = K)
      for (ttt in 1:(m - 1)) {
        loc <- unlist(cb2[x2[ttt], ])
        v.matrix[ttt, loc] = 1
      }

      largest.d <- v.matrix[which.max(rowSums(v.matrix)), ]
      r.large.d <- which(largest.d == 1)
      sub.q[2, ] <- largest.d

      full.q <- largest.d

      abc = 1
      complement = 0
      sub.ava = length(r.large.d) > 1

      while (abc <= (m0 - 2) && complement == 0 && sub.ava) {
        complt.largest <- full.q - largest.d

        if (complement == 1) {
          if (sum(complt.largest) == 0) {
            m = 2 + abc - 1
          } else {
            sub.q[2 + abc, ] <- complt.largest
            m = 2 + abc
          }
        } else {
          if (sub.ava) {
            full.q <- sub.q[abc + 1, ]
            cb3 <-
              expand.grid(lapply(r.large.d, function(x)
                (c(0, x))))[2:(2 ^ length(r.large.d) - 1), , drop = FALSE]

            x1 = sample(2:nrow(cb3), m0 - 1 - abc, replace = TRUE)

            v.matrix <- matrix(0, nrow = m0 - 1 - abc, ncol = K)
            for (ttt in 1:nrow(v.matrix)) {
              loc <- unlist(cb3[x1[ttt], ])
              v.matrix[ttt, loc] = 1
            }
            largest.d <- v.matrix[which.max(rowSums(v.matrix)), ]
            r.large.d <- which(largest.d == 1)
            sub.q[2 + abc, ] <- largest.d

            m = 2 + abc
            abc = abc + 1
            sub.ava = length(r.large.d) > 1
            complement = sample(c(0, 1), 1) ## of select the complement, the selection of distractors ends
          } else {
            m = 2 + abc - 1
          }
        }
      }
    }
    item.q <- cbind(rep(i, H), od.option, sub.q)

    dl <- which(rowSums(sub.q) == 0)
    if (length(dl) == 0) {
      item.q = item.q
    } else {
      item.q = item.q[-which(rowSums(sub.q) == 0), ]
    }
    mc.q <- rbind(mc.q, item.q)
    key <- c(key, id.key)
    save.m <- c(save.m, m)
  }
  save.m <- c()
  for (j in 1:J) {
    save.m <- c(save.m, length(which(mc.q[, 1] == j)))
  }
  rownames(mc.q) <- NULL
  colnames(mc.q) <- c("Item", "Option", paste0("Att", seq(1:K)))

  return(list(
    "mcq" = mc.q,
    "key" = key,
    "H_star" = save.m
  ))
}