# 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)
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.