################################################################################
#' Create a histogram of person estimates.
#'
#' @param results The output from a run of \code{craschR}. (link?)
#' @param dim A numeric vector that specifies for which dimension(s) to create
#' graphic/tables. If \code{NULL}, output and graphics for each dimension
#' will be produced.
#' @param palette The color scheme for the histogram. Can be "BASS or any
#' RColorBrewer palette name (the first 2 colors of the 3-color palette will
#' be used). Can also specify a vector with 2 colors in any R-supported form;
#' the first color is for the bars and the second is for the normal curve.
#' @param normal A logical incating whether to include the normal curve overlaid
#' on the plot. The estimated mean and variance define the curve.
#' @param writeout A logical indicating whether the graph should be written to
#' your working directory as your indicated \code{imageType}. If \code{TRUE},
#' the file name will begin \code{pershist} and will include an index (if more
#' than one graph is produced) and the \code{fileSuffix} if provided.
#' @param imageType A character string indicating the format for graphics (if
#' \code{writeout = TRUE}). Supported types:
#' \code{c("pdf","svg","jpeg","bmp","tiff","png")}.
#' @param fileSuffix A character string that will be affixed to the end of each
#' file name (if \code{writeout = TRUE}). Use this if you are conducting
#' multiple analyses in the same working directory and do not wish for your
#' existing files to be overwritten.
#' @param ... Additional arguments to be passed to \code{hist} function.
#'
#' @return Plots one histogram for each dimension.
#'
#' @export
pers.hist <- function(results, dim = NULL, palette = "BASS", normal = FALSE,
writeout = FALSE, imageType = "pdf", fileSuffix = NULL,
...) {
checkResults(results)
checkWrite(writeout, fileSuffix)
checkImageType(imageType)
checkDim(dim, results$consInfo)
origPar = par(no.readonly = TRUE) # to reset graphical parameters after
if (identical(palette, "BASS")) {
color <- c(bar = "#80b1d3", curve = "gray")
} else if (length(palette) == 1) {
if (palette %in% row.names(brewer.pal.info)) {
color <- RColorBrewer::brewer.pal(3, palette)
} else {
stop('Invalid palette argument.')
}
} else if (all(areColors(palette)) & length(palette)==2) {
color <- palette
} else {
stop('Invalid palette argument.')
}
layout(matrix(1))
par(mai=c(1.36, 1.093333, 1.093333, 0.56),
mar=c(5.1, 4.1, 4.1, 2.1))
if (is.null(dim)) {
D <- 1:results$estSummary$D
} else {
D <- dim
}
for (d in D) {
h <- hist(results$persPars[,d], plot = FALSE)
if (normal) {
x <- seq(min(results$persPars[,d]), max(results$persPars[,d]),
length = 200)
y <- dnorm(x, mean = results$popDist$mean[d],
sd = sqrt(results$popDist$var.cov[d,d])) * diff(h$mids[1:2]) *
nrow(results$persPars)
} else {
x <- h$breaks
y <- h$counts
}
if (writeout) {
if (length(D) == 1) {
dd = NULL
} else {
dd = d
}
graphout = paste0("pershist", dd, fileSuffix, ".", imageType)
eval(parse(text = paste0(imageType, "('", graphout, "')")))
}
hist(results$persPars[,d], main = results$consInfo$short.name[d],
xlab = "Logits", col = color[1], freq = TRUE, axes = FALSE,
ylim = c(0, max(max(y), max(h$counts))))
axis(1, at = c(seq(0, min(0, floor(min(results$persPars[,d]))), by = -2),
seq(2, max(2, ceiling(max(results$persPars[,d]))), by = 2)))
axis(1, at = c(seq(-1, min(-1,floor(min(results$persPars[,d]))), by = -2),
seq(1, max(1, ceiling(max(results$persPars[,d]))), by = 2)),
labels = FALSE)
axis(2, las = 1)
Hmisc::minor.tick(nx = 1, ny = 2, tick.ratio = 1)
if (normal) {
lines(x, y, col = color[2], lty = 2, lwd = 2) # add normal curve
}
if (writeout) {
dev.off()
}
}
par(origPar)
}
################################################################################
#' Plots a KIDMAP for a given person and construct.
#'
#' @param results The output from a run of \code{craschR}. (link?)
#' @param personID A character or numeric vector indicating the index ID of the
#' respondent for the plot. (Do not specify a row number, use the assigned
#' ID.)
#' @param dim A numeric vector that specifies for which dimension(s) to create
#' graphic/tables. If \code{NULL}, output and graphics for each dimension
#' will be produced.
#' @param probBounds A vector containing the range of probabilities which are
#' "unsurprising."
#' @param palette The color scheme for the plot. Can be "BASS or any
#' RColorBrewer palette name (the 3-color palette will be used). Can also
#' specify a vector with 3 colors in any R-supported form; the first is the
#' color of the "expected" area, the second the "surprise" area, and the third
#' the point color.
#' @param writeout A logical indicating whether the graph should be written to
#' your working directory as your indicated \code{imageType}. If \code{TRUE},
#' the file name will begin \code{KIDMAP} and will include an index for the
#' selected respondent, and the \code{fileSuffix} if provided.
#' @param imageType A character string indicating the format for graphics (if
#' \code{writeout = TRUE}). Supported types:
#' \code{c("pdf","svg","jpeg","bmp","tiff","png")}.
#' @param fileSuffix A character string that will be affixed to the end of each
#' file name (if \code{writeout = TRUE}). Use this if you are conducting
#' multiple analyses in the same working directory and do not wish for your
#' existing files to be overwritten.
#'
#' @return KIDMAP plot for specified person.
#'
#' @export
KIDMAP <- function(results, personID, dim = NULL, probBounds = c(.25, .75),
palette = "BASS", writeout = FALSE, imageType = "pdf",
fileSuffix = NULL) {
checkResults(results)
if (!results$estSummary$consecutive & results$estSummary$D > 1) {
stop('Person fit statistics are not available for non-consecutive multi-dimensional analyses using TAM.\n KIDMAP not available.')
}
checkWrite(writeout, fileSuffix)
checkImageType(imageType)
checkDim(dim, results$consInfo)
if (!(all(as.character(personID) %in% row.names(results$scoresOrig)) &
(is.character(personID) | is.numeric(personID)))) {
stop('Invalid personID argument.')
}
if (!(is.numeric(probBounds) &
length(probBounds) == 2 &
all(probBounds <= 1 & probBounds >= 0) &
(probBounds[1] < probBounds[2]))) {
stop('Invalid probBounds argument.')
}
origPar = par(no.readonly = TRUE) # to reset graphical parameters after
if (is.null(dim)) {
D <- 1:results$estSummary$D
} else if (is.numeric(dim)) {
D <- dim
} else {
stop('Invalid dim argument.')
}
if (identical(palette, "BASS")) {
color = c(expected = rgb(red = 128, green = 177, blue = 211, alpha = 127.5,
maxColorValue = 255),
surprise = rgb(red = 255, green = 229, blue = 0, alpha = 127.5,
maxColorValue = 255),
points = "#80b1d3")
} else if (length(palette) == 1) {
if (palette %in% row.names(brewer.pal.info)) {
color <- RColorBrewer::brewer.pal(3, palette)
} else {
stop('Invalid palette argument.')
}
} else if (all(areColors(palette)) & length(palette) == 3) {
color <- palette
} else {
stop('Invalid palette argument.')
}
rowIndex <- which(row.names(results$scoresRecoded) %in% as.character(personID))
for (d in D) {
inclItem <- which(results$itemInfo$cons.ID == results$consInfo$cons.ID[d])
thres <- as.matrix(results$itemThres[inclItem,])
for (i in rowIndex) {
respVector <- as.numeric(results$scoresRecoded[i,])
toPlot <- data.frame(x = rep(1, prod(dim(thres))),
thres = c(t(thres)),
step = rep(1:ncol(thres), length(inclItem)),
score = rep(respVector[inclItem], each = ncol(thres)) )
row.names(toPlot) <- paste(rep(row.names(thres), each = ncol(thres)),
rep(1:ncol(thres), length(inclItem)), sep = "_")
toPlot = toPlot[complete.cases(toPlot),] # removes steps that don't exist
# AND skipped items
toPlot$x[toPlot$step <= toPlot$score] = -1
# all "reached" thresholds have an x-coord of -1, all others 1
# location of "surprise" lines
upBd = results$persPars[i, d] - log(probBounds[1] / (1 - probBounds[1]))
loBd = results$persPars[i, d] - log(probBounds[2] / (1 - probBounds[2]))
if (writeout) {
eval(parse(text = paste0(imageType, "('KIDMAP-", i, "_",
results$consInfo$short.name[d], fileSuffix,
".", imageType, "')")))
}
layout(matrix(1, nrow = 1))
par(mai = c(1.02, 0.82, 0.82, 0.42), mar = c(5.1, 4.1, 5.3, 2.1))
plot(1, type = "n", xlim = c(-1.5, 1.5),
ylim = c(min(toPlot$thres, loBd) - .2, max(toPlot$thres, upBd) + .2),
axes = FALSE, xlab = "", ylab = "Logits", main = "KIDMAP")
mtext(paste0("Person: ", row.names(results$scoresRecoded)[i],
"\nEst Theta (", results$consInfo$short.name[d], "): ",
round(results$persPars[i, d], 2)),
side = 3, line = 0, cex = .8)
mtext(paste0("Raw: ", round(results$persRaw[i, d], 2), "/",
round(results$persMax[i, d], 2),
"\nOutfit: ", round(results$persFit[[d]]$outfit[i], 2),
" (t=",round(results$persFit[[d]]$outfit_t[i], 2), ")",
"\nInfit: ", round(results$persFit[[d]]$infit[i], 2),
" (t=",round(results$persFit[[d]]$infit_t[i], 2), ")"),
side = 1, line = 2, cex = .7)
mtext("Reached", adj = 0)
mtext("Not Reached", adj = 1)
rect(xleft = -1.5, xright = 1.5, ybottom = loBd, ytop = upBd,
col = color[1], border = NA)
rect(xleft = -1.5, xright = 0, ybottom = upBd, ytop = 100,
col = color[2], border = NA)
rect(xleft = 0, xright = 1.5, ybottom = -100, ytop = loBd,
col = color[2], border = NA)
abline(v = 0)
abline(h = results$persPars[i, d])
axis(side = 2, at = c(seq(0, floor(min(toPlot$thres, loBd) - .2), by = -1),
seq(0, ceiling(max(toPlot$thres, upBd) + .2), by = 1)),
las = 1)
axis(side = 4, at = c(seq(0, floor(min(toPlot$thres, loBd) - .2), by = -1),
seq(0, ceiling(max(toPlot$thres, upBd) + .2), by = 1)),
las = 1)
points(x = toPlot$x, y = toPlot$thres, pch = 21, bg = color[3])
if (sum(toPlot$x == -1) == 1) {
text(x = -1, y = toPlot$thres[toPlot$x == -1],
row.names(toPlot[toPlot$x == -1,]), pos = 4, cex = .5)
} else if (sum(toPlot$x == -1) > 1) {
text(x = -1, y = sort(toPlot$thres[toPlot$x == -1]),
labels = row.names(toPlot)[toPlot$x == -1][order(toPlot$thres[toPlot$x == -1])],
pos = c(2, 4), cex = .5)
}
if (sum(toPlot$x == 1) == 1) {
text(x = 1, y = toPlot$thres[toPlot$x == 1],
row.names(toPlot[toPlot$x == 1,]), pos = 2, cex = .5)
} else if (sum(toPlot$x == 1) > 1) {
text(x = 1, y = sort(toPlot$thres[toPlot$x == 1]),
labels = row.names(toPlot)[toPlot$x == 1][order(toPlot$thres[toPlot$x == 1])],
pos = c(2, 4), cex = .5)
}
if (writeout) {
dev.off()
}
}
}
par(origPar)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.