R/plotCluster.R

Defines functions plotClusters plot2PLclusters plotCluster1 plotCluster

Documented in plotCluster

# Thu Sep 16 14:51:08 2021 ------------------------------

##
#' @title Plotting item clusters
#'
#' @description Plotting relative DIFs and item clusters.
#'
#' @param res Results generated by \code{\link{clusterItems}} or \code{\link{testMI}}.
#' @param showLegend Adds item identifiers to the plot. Defaults to \code{FALSE}.
#' @param tickWidth Give widths of ticks manually. Defaults to \code{0.2}.
#'
#' @return A plot, either a single plot if MI analysis was done for only one parameter,
#' or multiple plots showing the subsequent clustering via item loadings and difficulties.
#' Relative DIF effects are always moved to a scale where the lowest DIF values is zero.
#'
#' @usage plotCluster(res = res_clusterItems,
#'                    showLegend = FALSE,
#'                    tickWidth = 0.2)
#'
#' @importFrom plyr "round_any"
#'
#' @export



##########################################################
## modified plot function
plotCluster <- function(res,                             # model from testMI or clusterItems
                        showLegend = FALSE,              # plot legend for items
                        tickWidth = 0.2) {

  ### filtering what to plot
  levels <- c("configural",
              "weak",
              "strong",
              "strict")
  clusterWhat <- res$Factor$clusterWhat

  if (is.null(clusterWhat) && res$model$dichModel != "Rasch") {
    message("Only relative DIF of loadings can be plotted before clustering.")
    clusterWhat <- "difficulties"
    pkg <- ifelse(res$model$dichModel == "factor",
                  "lavaan", "mirt")
    drids <- getDrids(res[["Factor"]]$configural[[1]], pkg)
  }

  if (is.null(clusterWhat) && res$model$dichModel == "Rasch") {
    clusterWhat <- "difficulties"
  }

  if (!("loadings" %in% clusterWhat) && !("difficulties" %in% clusterWhat)) {
    stop("There is nothing to be plotted.")
  }

  ### plot
  if (!("loadings" %in% clusterWhat) && ("difficulties" %in% clusterWhat)) {
    drids <- res$Factor$itemClustering$modelAStep$`Loading cluster=1`$drids
      plotCluster1(drids$A[, 1] - min(drids$A[, 1]), # shift lowest drid to 0
                 res,
                 clustering = res$Factor$itemClustering$finalClustering,
                 showLegend = showLegend,
                 fontSize = 1,
                 type = "difficulties")
  }

  if (("loadings" %in% clusterWhat) && !("difficulties" %in% clusterWhat)) {
    drids <- res$Factor$itemClustering$clusterLStep$drids
    plotCluster1(drids$L[, 1] - min(drids$L[, 1]), # shift lowest drid to 0
                 res,
                 clustering = res$Factor$itemClustering$finalClustering,
                 showLegend = showLegend,
                 fontSize = 1,
                 type = "log(loadings)")
  }

  if (("loadings" %in% clusterWhat) && ("difficulties" %in% clusterWhat)) {
    plot2PLclusters(res,
                    tickWidth = tickWidth,
                    showLegend = showLegend)
  }

}


#### single plot
plotCluster1 <- function(d,                             # drids
                         res,
                         clustering = NULL,               # numeric[n]: cluster a point in d belongs to
                         showLegend = FALSE,               # plot legend for clusters
                         fontSize = 1,                    # font size of labels and axis label
                         type = NULL,
                         ...                              # plot options (DANGER: only some work...)
){
  n     <- length(d)
  maxD  <- max(d)
  minD  <- min(d)
  meanD <- mean(d)

  if (is.null(clustering)) clustering <- rep(1,n)

  cols <- c("red", "blue", "purple", "olivedrab3", "darkorange1",
            "magenta1", "lawngreen", "brown",
            "plum", "seagreen", "burlywood")
  pchs <- rep("I", n)

  plot(d, rep(0.4,n), axes = FALSE, ylab = "", cex=1.5,
       xlab = "", ylim=c(-0.3, 1),
       xlim = c(round(minD + minD/100 - 0.1, 2),
                round(maxD - maxD/100 + 0.6, 2)),
       col = cols[clustering], pch = pchs[clustering], ...)

  lines(c(round(minD + minD/100, 2), round(maxD + maxD/100,2)), c(0.2,0.2))
  tickX <- seq(round(minD,2), round(maxD,2), length = 5)
  segments(tickX, 0.25, tickX, 0.15)
  text(tickX, 0.05, round(tickX,2), cex=fontSize)
  text(tickX[3], -0.1,
       paste0("Relative DIF in ", type),
       pos = 1)

  if (showLegend) {
    text(x = d, y = 0.6,
         abbreviate(res$model$items$Factor, 7, strict = TRUE),
         pos = 3, srt = 90)
  }
  if (!is.null(res$Factor$itemClustering)){
    legend(maxD + (maxD - minD)/20, 0.4,
           paste("Cluster", 1:max(clustering)),
           col = cols, pch = pchs, bty = "n")
  }
}



##### plots for 2step clustering: umbrella function
plot2PLclusters <- function(res, #  result list from twoStepThreshold function
                            tickWidth = tickWidth,                   #  length of tick interval in DRID plots
                            showLegend = FALSE
) {

  #  get clusterings
  cluster1stStep <- res$Factor$itemClustering$clusterLStep$cluster
  cluster2ndStep <- res$Factor$itemClustering$finalClustering

  cluster1stStep_1 <- unname(which(table(cluster1stStep) == 1))           #  check for 1-item alpha clusters...
  cluster1stStep_for2ndStep <- unname(which(table(cluster1stStep) > 1))   #  ...and here all clusters with more than 1 item
  clusCount <- length(cluster1stStep_for2ndStep)

  dR_alpha <- res$Factor$itemClustering$clusterLStep$drids$L[, 1]

  dR_beta <- vector(length=length(cluster1stStep))
  #  getting beta DRIDs for non 1-item clusters
  for (i in cluster1stStep_for2ndStep) {
    betasCurrent <- res$Factor$itemClustering$modelAStep[[paste0("Loading cluster=", i)]]
    dR_beta[cluster1stStep == i] <- betasCurrent$drids$A[cluster1stStep == i, 1]
  }

  #  calculate plot widths
  totalRange <- 0
  previousRange <- 0
  rangeL <- list() #  store cumulative ranges of the single 2nd step plots to calculate their individual plot widths later
  for (pos in cluster1stStep_for2ndStep) {
    minD <- min(dR_beta[cluster1stStep == pos] - min(dR_beta[cluster1stStep == pos]))
    maxD <- max(dR_beta[cluster1stStep == pos] - min(dR_beta[cluster1stStep == pos]))
    tickX <- seq(round_any(minD, tickWidth, floor), round_any(maxD, tickWidth, ceiling),
                 by = tickWidth)
    rangeL[[pos]] <- previousRange
    totalRange <- totalRange + max(tickX) - min(tickX) + tickWidth
    previousRange <- previousRange + max(tickX) - min(tickX) + tickWidth
  }

  ##  plotting
  par(mai=c(0, 0, 0, 0))
  plot(0, type="n", axes=F, xaxs="i", #  empty plot, setting up plotting area
       ylim=c(0, 3),
       xlim = c(-totalRange/40, totalRange+tickWidth))

  # 1st step
  cols1stStep <- c("red", "blue", "palevioletred", "skyblue1",   #  12 colors for 1st step (red and blueish)
                   "firebrick3", "steelblue3","coral1", "dodgerblue2",
                   "orangered2", "navy", "deeppink4", "cyan")
  if (length(cluster1stStep_for2ndStep) > 12) print("Color coding in step 1 has failed due to high cluster number.")
  cols <- vector()
  cols[cluster1stStep_for2ndStep] <- cols1stStep[as.integer(factor(cluster1stStep_for2ndStep))]  # the as.integer(factor(..)) construct lets R start with the first color
  cols[cluster1stStep_1] <- "black"

  text(labels=expression("1"^"st"*" step: loading clusters"), x=0, y=3, cex=1, pos=4) #  1st heading
  plotClusters(dR_alpha - min(dR_alpha), #  shift values to start with 0
               res,
               x = 0, y = 2,
               showLegend = showLegend,
               tickWidth = tickWidth,
               clustering = cluster1stStep,
               broken = rep(0, length(cluster1stStep)),
               clusterColors = cols)

  text(labels=expression("Relative DIF in log(loadings)"), x=((round_any(max(dR_alpha- min(dR_alpha)), tickWidth, ceiling) - round_any(min(dR_alpha- min(dR_alpha)), tickWidth, floor)) / 2), y=2.3, cex=0.7)

  #  2nd step
  cols2ndStep <- c("purple", "olivedrab3", "darkorange1", #  color coding in 9 colors, three times over (full line, once broken, twice broken)
                   "magenta1", "lawngreen", "brown",
                   "plum", "seagreen", "burlywood",
                   "purple", "olivedrab3", "darkorange1",
                   "magenta1", "lawngreen", "brown",
                   "plum", "seagreen", "burlywood",
                   "purple", "olivedrab3", "darkorange1",
                   "magenta1", "lawngreen", "brown",
                   "plum", "seagreen", "burlywood")
  brokenS <- c(rep("0", 9), rep("1", 9), rep("2", 9))
  if (length(unique(cluster2ndStep)) > 27) print("Color coding in step 2 has failed due to high cluster number.")

  thirdPlotCols <- vector(length=length(unique(cluster2ndStep))) #  to contain the color coding of the 2nd step to print a third plot for all items
  thirdPlotBroken <- vector(length=length(unique(cluster2ndStep))) #  ... and broken lines coding likewise

  text(labels=expression("2"^"nd"*"clustering step: difficulties"), x=0, y=2, cex=1, pos=4) #  2nd heading

  for (pos in cluster1stStep_for2ndStep) {
    currClus <- sort(unique(cluster2ndStep[cluster1stStep == pos]))

    plotClusters(dR_beta[cluster1stStep == pos] - min(dR_beta[cluster1stStep == pos]), #  shift values to be greater than 0
                 res,
                 x = rangeL[[pos]], y = 1,
                 showLegend = showLegend,
                 tickWidth = tickWidth,
                 clustering = cluster2ndStep[cluster1stStep == pos],
                 axisCol = cols1stStep[which(unique(cluster1stStep_for2ndStep) == pos)],
                 clusterColors = cols2ndStep[currClus],
                 broken = brokenS[currClus])
    text(labels=expression("Relative DIF in difficulties"), cex=0.7,
         x=rangeL[[pos]] + ((round_any(max(dR_beta[cluster1stStep == pos] - min(dR_beta[cluster1stStep == pos])), tickWidth, ceiling) - round_any(min(dR_beta[cluster1stStep == pos] - min(dR_beta[cluster1stStep == pos])), tickWidth, floor)) / 2), y=1.3)
    thirdPlotCols[currClus] <- cols2ndStep[currClus]
    thirdPlotBroken[currClus] <- brokenS[currClus]
  }
  thirdPlotCols[thirdPlotCols == "FALSE"] <- "black"   #  insert values for 1-item clusters
  thirdPlotBroken[thirdPlotBroken == "FALSE"] <- "0"

  #  3rd: plot summary for all items
  text(labels="Cluster summary", x=0, y=0.9, cex=1, pos=4)
  plotClusters(seq(0, totalRange/2, by=(totalRange/2)/(length(cluster1stStep)-1)),
               res,
               x = 0, y = 0,
               showLegend = FALSE,
               tickWidth = tickWidth,
               clustering = cluster2ndStep,
               clusterColors = thirdPlotCols,
               broken = thirdPlotBroken,
               thirdPlot = T,
               addInfo = abbreviate(res$model$items$Factor, 7, strict = TRUE))
  text(labels="Item number", x=totalRange/4, y=0.2, cex=0.7)

  #  plot legend
  legend(totalRange*0.55, 0.75,
         paste("Cluster", 1:max(cluster2ndStep)),
         col = thirdPlotCols, pch = "I", bty = "n")
}



##### plots for 2step clustering: core plot function
plotClusters <- function(Dat,                     #  numeric[n]: input data
                         res,
                         showLegend = FALSE,
                         axisCol = "black",
                         x = NULL,
                         y = NULL,
                         clustering = NULL,       #  numeric[n]: cluster a point in d belongs to
                         broken = NULL,           #  numeric[0, 1], coding, which clusters should be displayed as broken lines for clarity
                         clusterColors = NULL,    #  character[n]: colors for the clusters
                         thirdPlot=FALSE,
                         tickWidth=tickWidth,
                         addInfo = NULL
                         #-> Q2
) {
  tickX <- seq(round_any(min(Dat), tickWidth, floor), round_any(max(Dat), tickWidth, ceiling),
               by = tickWidth)
  if (thirdPlot) {
    tickX <- Dat
    text(x+tickX, y+0.4, labels=addInfo, cex=0.7)
  }
  clustering <- as.integer(factor(clustering)) #  getting cluster names to starting with 1

  #  draw lines in plot
  for (i in unique(clustering)) {
    segments(x+Dat[clustering == i], y+0.6, x+Dat[clustering == i], y+0.7, col=clusterColors[i], lwd=2)
    if (broken[i] == "1") {
      segments(x+Dat[clustering == i], y+0.64, x+Dat[clustering == i], y+0.66, col="white", lwd=2, lend=1)
    }
    if (broken[i] == "2") {
      segments(x+Dat[clustering == i], y+0.6233, x+Dat[clustering == i], y+0.6433, col="white", lwd=2, lend=1)
      segments(x+Dat[clustering == i], y+0.6566, x+Dat[clustering == i], y+0.6766, col="white", lwd=2, lend=1)
    }
  }
  #  draw axis
  lines(c(x+min(tickX), x+max(tickX)),
        c(y+0.5, y+0.5),
        col = axisCol, lwd = 2, lend=2)
  segments(x+tickX, y+0.47, x+tickX, y+0.53, col = axisCol, lend=1)
  if (!thirdPlot) text(x+tickX, y+0.4, tickX, cex=0.5)

  # item legend
  if (showLegend) {
    text(x+Dat, y+0.7,
         cex=0.7,
         abbreviate(res$model$items$Factor, 7, strict = TRUE),
         pos = 3, srt = 90)
  }
}
Dani-Schulze/measurementInvariance documentation built on Jan. 28, 2022, 1:56 a.m.