Related
I would like to plot several forecasts on the same plot in different colours, however, the scale is off.
I'm open to any other methods.
reproducible example:
require(forecast)
# MAKING DATA
data <- c(3.86000, 19.55810, 19.51091, 20.74048, 20.71333, 29.04191, 30.28864, 25.64300, 23.33368, 23.70870 , 26.16600 ,27.61286 , 27.88409 , 28.41400 , 24.81957 , 24.60952, 27.49857, 32.08000 , 29.98000, 27.49000 , 237.26150, 266.35478, 338.30000, 377.69476, 528.65905, 780.00000 )
a.ts <- ts(data,start=c(2005,1),frequency=12)
# FORECASTS
arima011_css =stats::arima(x = a.ts, order = c(0, 1, 1), method = "CSS") # css estimate
arima011_forecast = forecast(arima011_css, h=10, level=c(99.5))
arima321_css =stats::arima(x = a.ts, order = c(3, 2, 1), method = "CSS") # css estimate
arima321_forecast = forecast(arima321_css, h=10, level=c(99.5))
# MY ATTEMPT AT PLOTS
plot(arima321_forecast)
par(new=T)
plot(arima011_forecast)
Here is something similar to #jay.sf but using ggplot2.
library(ggplot2)
autoplot(a.ts) +
autolayer(arima011_forecast, series = "ARIMA(0,1,1)", alpha = 0.5) +
autolayer(arima321_forecast, series = "ARIMA(3,2,1)", alpha = 0.5) +
guides(colour = guide_legend("Model"))
Created on 2020-05-19 by the reprex package (v0.3.0)
You could do a manual plot using a sequence of dates.
rn <- format(seq.Date(as.Date("2005-01-01"), by="months", length.out=12*3), "%Y.%m")
Your ARIMAs you'll need as.matrix form.
arima321_mat <- as.matrix(as.data.frame(arima321_forecast))
arima011_mat <- as.matrix(as.data.frame(arima011_forecast))
Some colors with different alpha=.
col.1 <- rainbow(2, ,.7)
col.2 <- rainbow(2, ,.7, alpha=.2)
For the CIs use polygon.
plot(data, type="l", xlim=c(1, length(rn)), ylim=c(0, 3500), xaxt="n", main="Forecasts")
axis(1, axTicks(1), labels=F)
mtext(rn[(seq(rn)-1) %% 5 == 0], 1, 1, at=axTicks(1))
lines((length(data)+1):length(rn), arima321_mat[,1], col=col.1[1], lwd=2)
polygon(c(27:36, 36:27), c(arima321_mat[,2], rev(arima321_mat[,3])), col=col.2[1],
border=NA)
lines((length(data)+1):length(rn), arima011_mat[,1], col=col.1[2], lwd=3)
polygon(c(27:36, 36:27), c(arima011_mat[,2], rev(arima011_mat[,3])), col=col.2[2],
border=NA)
legend("topleft", legend=c("ARIMA(3,2,1)", "ARIMA(0,1,1)"), col=col.1, lwd=2, cex=.9)
Edit: To avoid the repetition of lines and polygon calls, you may unite them using Map.
mats <- list(arima321_mat, arima011_mat) ## put matrices into list
plot(.)
axis(.)
mtext(.)
Map(function(i) {
lines((length(data)+1):length(rn), mats[[i]][,1], col=col.1[i], lwd=2)
polygon(c(27:36, 36:27), c(mats[[i]][,2], rev(mats[[i]][,3])), col=col.2[i], border=NA)
}, 1:2)
legend(.)
require(forecast)
data <- c(3.86000, 19.55810, 19.51091, 20.74048, 20.71333, 29.04191, 30.28864, 25.64300, 23.33368, 23.70870 , 26.16600 ,27.61286 , 27.88409 , 28.41400 , 24.81957 , 24.60952, 27.49857, 32.08000 , 29.98000, 27.49000 , 237.26150, 266.35478, 338.30000, 377.69476, 528.65905, 780.00000 )
a.ts <- ts(data,start=c(2005,1),frequency=12)
arima011_css =stats::arima(x = a.ts, order = c(0, 1, 1), method = "CSS") # css estimate
arima011_forecast = predict(arima011_css, n.ahead = 2)$pred
arima321_css =stats::arima(x = a.ts, order = c(3, 2, 1), method = "CSS") # css estimate
arima321_forecast = predict(arima321_css, n.ahead = 2)$pred
plot(a.ts, type = "o", xlim = c(2005, 2007.5) , ylim = c(-1, 1200) , ylab = "price" ,main = "2 month Forecast")
range = c(2007+(3/12), 2007+(4/12)) # adding the dates for the prediction
lines(y = arima011_forecast , x = range , type = "o", col = "red")
lines(y = arima321_forecast, x = range , type = "o", col = "blue")
I am trying to visualize the results of a PCoA{ape} by making a biplot in R.
The axes now get the default labels axis 1 and axis 2, but I want to edit this.
This is the code I have tried:
biplot(pcoa.ntK, Y=NULL, plot.axes=c(1,2), rn=ntnames,
xlabs="PC1 (%)", ylabs="PC2 (%)")
But the labels don't change.
Can someone tell me what I'm doing wrong here?
And I also would like to edit the title, anyone tips for this?
My data:
ntK <- matrix(
c(0.00000, 0.01500, 0.01832, 0.02061, 0.01902, 0.01270, 0.02111, 0.01655, 0.01520, 0.01691,
0.01667, 0.00000, 0.01175, 0.01911, 0.01759, 0.01127, 0.01854, 0.01041, 0.00741, 0.02007,
0.02432, 0.01404, 0.00000, 0.02551, 0.01972, 0.01838, 0.02505, 0.01484, 0.01391, 0.02687,
0.01501, 0.01252, 0.01399, 0.00000, 0.01442, 0.01294, 0.01402, 0.01132, 0.01239, 0.01455,
0.02343, 0.01951, 0.01830, 0.02440, 0.00000, 0.01727, 0.02470, 0.02021, 0.01699, 0.02482,
0.01320, 0.01054, 0.01439, 0.01847, 0.01457, 0.00000, 0.01818, 0.01366, 0.00977, 0.01394,
0.02468, 0.01950, 0.02206, 0.02251, 0.02343, 0.02040, 0.00000, 0.02028, 0.01875, 0.02558,
0.02254, 0.01276, 0.01522, 0.02117, 0.02234, 0.01790, 0.02363, 0.00000, 0.01152, 0.02557,
0.01804, 0.00792, 0.01244, 0.02019, 0.01637, 0.01116, 0.01904, 0.01004, 0.00000, 0.02099,
0.01862, 0.01988, 0.02227, 0.02200, 0.02218, 0.01476, 0.02408, 0.02066, 0.01947, 0.00000),
nrow=10,
ncol=10)
library(ape)
ntnames <- c("A","B","C","D","E","F","G","H","I","J")
pcoa.ntK <- pcoa(ntK)
biplot is a generic function. The default method and the method for use with objects that come from using the prcomp function in the stats package do allow you to specify axis labels and a title, but for some reason the person that wrote the method that is called with objects of class pcoa hasn't allowed you to specify them. I think your only option would be to write your own version of biplot.pcoa (or ask the package maintainer to add this option).
This is a very quick and dirty hack of the function in the ape package that might do what you want, but no promises that it won't have broken something else!
biplot.pcoa <- function (x, Y = NULL, plot.axes = c(1, 2), dir.axis1 = 1, dir.axis2 = 1,
rn = NULL, xlabs = NULL, ylabs = NULL, main = NULL, ...)
{
k <- ncol(x$vectors)
if (k < 2)
stop("There is a single eigenvalue. No plot can be produced.")
if (k < plot.axes[1])
stop("Axis", plot.axes[1], "does not exist.")
if (k < plot.axes[2])
stop("Axis", plot.axes[2], "does not exist.")
if (!is.null(rn))
rownames(x$vectors) <- rn
labels = colnames(x$vectors[, plot.axes])
if (!is.null(xlabs)) labels[1] <- xlabs
if (!is.null(ylabs)) labels[2] <- ylabs
diag.dir <- diag(c(dir.axis1, dir.axis2))
x$vectors[, plot.axes] <- x$vectors[, plot.axes] %*% diag.dir
if (is.null(Y)) {
limits <- apply(x$vectors[, plot.axes], 2, range)
ran.x <- limits[2, 1] - limits[1, 1]
ran.y <- limits[2, 2] - limits[1, 2]
xlim <- c((limits[1, 1] - ran.x/10), (limits[2, 1] +
ran.x/5))
ylim <- c((limits[1, 2] - ran.y/10), (limits[2, 2] +
ran.y/10))
par(mai = c(1, 1, 1, 0.5))
plot(x$vectors[, plot.axes], xlab = labels[1], ylab = labels[2],
xlim = xlim, ylim = ylim, asp = 1)
text(x$vectors[, plot.axes], labels = rownames(x$vectors),
pos = 4, cex = 1, offset = 0.5)
if (is.null(main)){
title(main = "PCoA ordination", line = 2.5)
} else title(main = main, line = 2.5)
}
else {
n <- nrow(Y)
points.stand <- scale(x$vectors[, plot.axes])
S <- cov(Y, points.stand)
U <- S %*% diag((x$values$Eigenvalues[plot.axes]/(n -
1))^(-0.5))
colnames(U) <- colnames(x$vectors[, plot.axes])
par(mai = c(1, 0.5, 1.4, 0))
biplot(x$vectors[, plot.axes], U, xlab = labels[1], ylab = labels[2])
if (is.null(main)) {
title(main = c("PCoA biplot", "Response variables projected",
"as in PCA with scaling 1"), line = 4)
} else title(main = main, line = 4)
}
invisible()
}
biplot(pcoa.ntK, xlabs = 'My x label', ylabs = 'My y label', main = 'My title')
You can check the source code of biplot.pcoa and you'll see it's not that hard to modify. The author of the package decided to hard-code the axis labels based on the input and also the main title of the plot. Here's a modified version that will first check if values for xlab, ylab and main were used before using the pre-defined ones:
biplot.pcoa <- function (x, Y = NULL, plot.axes = c(1, 2), dir.axis1 = 1, dir.axis2 = 1,
rn = NULL, ...)
{
k <- ncol(x$vectors)
if (k < 2)
stop("There is a single eigenvalue. No plot can be produced.")
if (k < plot.axes[1])
stop("Axis", plot.axes[1], "does not exist.")
if (k < plot.axes[2])
stop("Axis", plot.axes[2], "does not exist.")
if (!is.null(rn))
rownames(x$vectors) <- rn
args <- list(...)
labels = ifelse(c("xlab", "ylab") %in% names(args), c(args$xlab, args$ylab), colnames(x$vectors[, plot.axes]))
diag.dir <- diag(c(dir.axis1, dir.axis2))
x$vectors[, plot.axes] <- x$vectors[, plot.axes] %*% diag.dir
if (is.null(Y)) {
limits <- apply(x$vectors[, plot.axes], 2, range)
ran.x <- limits[2, 1] - limits[1, 1]
ran.y <- limits[2, 2] - limits[1, 2]
xlim <- c((limits[1, 1] - ran.x/10), (limits[2, 1] +
ran.x/5))
ylim <- c((limits[1, 2] - ran.y/10), (limits[2, 2] +
ran.y/10))
par(mai = c(1, 1, 1, 0.5))
title <- ifelse("main" %in% names(args), args$main, "PCoA ordination")
plot(x$vectors[, plot.axes], xlab = labels[1], ylab = labels[2],
xlim = xlim, ylim = ylim, asp = 1,
main = title)
text(x$vectors[, plot.axes], labels = rownames(x$vectors),
pos = 4, cex = 1, offset = 0.5)
#title(main = "PCoA ordination", line = 2.5)
}
else {
n <- nrow(Y)
points.stand <- scale(x$vectors[, plot.axes])
S <- cov(Y, points.stand)
U <- S %*% diag((x$values$Eigenvalues[plot.axes]/(n -
1))^(-0.5))
colnames(U) <- colnames(x$vectors[, plot.axes])
par(mai = c(1, 0.5, 1.4, 0))
title <- ifelse("main" %in% names(args), args$main, c("PCoA biplot", "Response variables projected",
"as in PCA with scaling 1"))
biplot(x$vectors[, plot.axes], U, xlab = labels[1], ylab = labels[2], main = title)
# title(main = c("PCoA biplot", "Response variables projected",
# "as in PCA with scaling 1"), line = 4)
}
invisible()
}
Then:
biplot(pcoa.ntK, Y=NULL, plot.axes=c(1,2), rn=ntnames,
xlab="PC1 (%)", main = "Main Title")
Keep in mind this won't change the original function, so you'll need to load this modified version every time you load the package and need wish to set the labels like this.
I there a way to see in R how a graph was built into a variable: the code behind the graph. I have tried the str(), deparse(), and replayPlot() functions but these don't give the answer I am searching for.
Precisely I am looking at the result returned by the MackChainLadder() function from the "ChainLadder" package. When I plot the the variable, say plot(MCL), it returns me 6 different graphs. Is it a way to find out how these graphs were built and saved into the variable?
library("ChainLadder")
MCL <- MackChainLadder(ABC)
plot(MCL)
One way to do this is to look at the package source code directly (download it from this page):
http://cran.r-project.org/web/packages/ChainLadder/index.html
The trick is finding the right method that plot() calls. I think it might be this one in MackChainLadderFunctions.R
################################################################################
## plot
##
plot.MackChainLadder <- function(x, mfrow=c(3,2), title=NULL,lattice=FALSE,...){
.myResult <- summary(x)$ByOrigin
.FullTriangle <- x[["FullTriangle"]]
.Triangle <- x[["Triangle"]]
if(!lattice){
if(is.null(title)) myoma <- c(0,0,0,0) else myoma <- c(0,0,2,0)
op=par(mfrow=mfrow, oma=myoma, mar=c(4.5,4.5,2,2))
plotdata <- t(as.matrix(.myResult[,c("Latest","IBNR")]))
n <- ncol(plotdata)
if(getRversion() < "2.9.0") { ## work around missing feature
bp <- barplot(plotdata,
legend.text=c("Latest","Forecast"),
## args.legend=list(x="topleft"), only avilable from R version >= 2.9.0
names.arg=rownames(.myResult),
main="Mack Chain Ladder Results",
xlab="Origin period",
ylab="Amount",#paste(Currency,myUnit),
ylim=c(0, max(apply(.myResult[c("Ultimate", "Mack.S.E")],1,sum),na.rm=TRUE)))
}else{
bp <- barplot(plotdata,
legend.text=c("Latest","Forecast"),
args.legend=list(x="topleft"),
names.arg=rownames(.myResult),
main="Mack Chain Ladder Results",
xlab="Origin period",
ylab="Amount",#paste(Currency,myUnit),
ylim=c(0, max(apply(.myResult[c("Ultimate", "Mack.S.E")],1,sum),na.rm=TRUE)))
}
## add error ticks
## require("Hmisc")
errbar(x=bp, y=.myResult$Ultimate,
yplus=(.myResult$Ultimate + .myResult$Mack.S.E),
yminus=(.myResult$Ultimate - .myResult$Mack.S.E),
cap=0.05,
add=TRUE)
matplot(t(.FullTriangle), type="l",
main="Chain ladder developments by origin period",
xlab="Development period", ylab="Amount", #paste(Currency, myUnit)
)
matplot(t(.Triangle), add=TRUE)
Residuals=residuals(x)
plot(standard.residuals ~ fitted.value, data=Residuals,
ylab="Standardised residuals", xlab="Fitted")
lines(lowess(Residuals$fitted.value, Residuals$standard.residuals), col="red")
abline(h=0, col="grey")
plot(standard.residuals ~ origin.period, data=Residuals,
ylab="Standardised residuals", xlab="Origin period")
lines(lowess(Residuals$origin.period, Residuals$standard.residuals), col="red")
abline(h=0, col="grey")
plot(standard.residuals ~ cal.period, data=Residuals,
ylab="Standardised residuals", xlab="Calendar period")
lines(lowess(Residuals$cal.period, Residuals$standard.residuals), col="red")
abline(h=0, col="grey")
plot(standard.residuals ~ dev.period, data=Residuals,
ylab="Standardised residuals", xlab="Development period")
lines(lowess(Residuals$dev.period, Residuals$standard.residuals), col="red")
abline(h=0, col="grey")
title( title , outer=TRUE)
par(op)
}else{
## require(grid)
## Set legend
fl <-
grid.layout(nrow = 2, ncol = 4,
heights = unit(rep(1, 2), "lines"),
widths =
unit(c(2, 1, 2, 1),
c("cm", "strwidth", "cm",
"strwidth"),
data = list(NULL, "Chain ladder dev.", NULL,
"Mack's S.E.")))
foo <- frameGrob(layout = fl)
foo <- placeGrob(foo,
linesGrob(c(0.2, 0.8), c(.5, .5),
gp = gpar(col=1, lty=1)),
row = 1, col = 1)
foo <- placeGrob(foo,
linesGrob(c(0.2, 0.8), c(.5, .5),
gp = gpar(col=1, lty=3)),
row = 1, col = 3)
foo <- placeGrob(foo,
textGrob(label = "Chain ladder dev."),
row = 1, col = 2)
foo <- placeGrob(foo,
textGrob(label = "Mack's S.E."),
row = 1, col = 4)
long <- expand.grid(origin=as.numeric(dimnames(.FullTriangle)$origin),
dev=as.numeric(dimnames(.FullTriangle)$dev))
long$value <- as.vector(.FullTriangle)
long$valuePlusMack.S.E <- long$value + as.vector(x$Mack.S.E)
long$valueMinusMack.S.E <- long$value - as.vector(x$Mack.S.E)
sublong <- long[!is.na(long$value),]
xyplot(valuePlusMack.S.E + valueMinusMack.S.E + value ~ dev |
factor(origin), data=sublong, t="l", lty=c(3,3,1), as.table=TRUE,
main="Chain ladder developments by origin period",
xlab="Development period",
ylab="Amount",col=1,
legend = list(top = list(fun = foo)),...)
}
}
I decided it was important for R users to be able to play hangman and made an R hangman game. The problem is I don't do many plots for general release and so I don't know how to provide the user with a plot that works independent of platform or gui.
Here's where you can download the complete package that contains large word bank:
library(devtools); install_github("hangman", "trinker")
The function that plots looks like this (I made the word bank go away for reproducibility):
hangman <- function() {
#x1 <- DICTIONARY[sample(1:nrow(DICTIONARY), 1), 1]
x1 <- "trapped"
x <- unlist(strsplit(x1, NULL))
len <- length(x)
x2 <- rep("_", len)
chance <- 0
win1 <- 0
win <- win1/len
wrong <- character()
right <- character()
print(x2, quote = FALSE)
hang.plot <- function(){ #plotting function
plot.new()
mtext("HANGMAN", col = "blue", cex=2)
mtext(paste(x2, collapse = " "), side = 1, cex=1.5)
mtext("wrong", side = 3, cex=1.5,
adj = 0, padj = 5, col = "red")
text(.015, .8, paste(wrong, collapse = "\n"), offset=.3,
cex=1.5, adj=c(0,1))
mtext("correct", side = 3, cex=1.5,
adj = 1, padj = 5, col = "red")
text(.96, .8, paste(right, collapse = "\n"), offset=.3,
cex=1.5, adj=c(0,1))
segments(.365, .77, .365, .83, lwd=2)
segments(.365, .83, .625, .83, lwd=2)
segments(.625, .83, .625, .25, lwd=2)
segments(.57, .25, .675, .25, lwd=2)
parts <- seq_len(length(wrong))
if (identical(wrong, character(0))) {
parts <- 0
}
if (1 %in% parts) {
mtext("O", side = 1, cex=4, adj = .365, padj = -7.2)
mtext("o o", side = 1, cex=1, adj = .3725, padj = -28.2)
mtext("<", side = 1, cex=1, adj = .373, padj = -27.6)
mtext("__", side = 1, cex=1, adj = .373, padj = -27.2)
}
if (2 %in% parts) {
mtext("I", side = 1, cex=4, adj = .375, padj = -6.25)
mtext("I", side = 1, cex=4, adj = .375, padj = -5.5)
mtext("I", side = 1, cex=4, adj = .375, padj = -4.75)
}
if (3 %in% parts) {
segments(.37, .57, .45, .63, lwd=7)
}
if (4 %in% parts) {
segments(.37, .57, .29, .63, lwd=7)
}
if (5 %in% parts) {
segments(.37, .426, .43, .3, lwd=7)
mtext("__", side = 1, cex = 1, adj = .373,
padj = -27.2, col = "white")
mtext("O", side = 1, cex = 1.25, adj = .373, padj = -21.5,
col="red")
}
if (6 %in% parts) {
segments(.37, .426, .31, .3, lwd = 7)
mtext("o o", side = 1, cex = 1, adj = .3725,
padj = -28.2, col="white")
mtext("x x", side = 1, cex=1, adj = .3725, padj = -28.2)
mtext("You Lose", side = 1, cex=8, padj = -3,
col = "darkgreen")
mtext(paste(x2, collapse = " "), side = 1, cex=1.6, col="white")
mtext(paste(x2, collapse = " "), side = 1, cex=1.5, col="white")
mtext(paste(x2, collapse = " "), side = 1, adj = .51, cex=1.6,
col="white")
mtext(paste(x, collapse = " "), side = 1, cex=1.5)
}
if (win1 == len) {
mtext("WINNER!", side = 1, cex=8, padj = -3,
col = "green")
mtext("WINNER!", side = 1, cex=8, adj = .1, padj = -3.1,
col = "darkgreen")
}
} #end of hang.plot
guess <- function(){#start of guess function
cat("\n","Choose a letter:","\n")
y <- scan(n=1,what = character(0),quiet=T)
if (y %in% c(right, wrong)) {
stop(paste0("You've already guessed ", y))
}
if (!y %in% letters) {
stop(paste0(y, " is not a letter"))
}
if (y %in% x) {
right <<- c(right, y)
win1 <<- sum(win1, sum(x %in% y))
win <<- win1/len
message(paste0("Correct!","\n"))
} else {
wrong <<- c(wrong, y)
chance <<- length(wrong)
message(paste0("The word does not contain ", y, "\n"))
}
x2[x %in% right] <<- x[x %in% right]
print(x2, quote = FALSE)
hang.plot()
}#end of guess function
hang.plot()
while(all(win1 != len & chance < 6)){
try(guess())
}
if (win == 1) {
outcome <- "\nCongratulations! You Win!\n"
} else {
outcome <- paste("\nSorry. You loose. The word is:", x1, "\n")
}
cat(outcome)
}
This looks great on RGUI (in windows) where I created it but the plot is misconfigured in RStudio. How can I make the code plot everything in a way that lines up/looks good independent of gui/platform (my friend bryangoodrich suggested grid as a possibility)?
Try to use text() instead of mtext(). All coordinate must be reconsider. Not tested.
To follow on Alan's answer, if you insist on drawing the head as the letter "O", then you'll need to calculate the height of the character, and use text instead of mtext. For example, this works in both rgui and in RStudio (on Windows) to attach the head to the first segment
plot.new()
segments(0.365, 0.77, 0.365, 0.83, lwd = 2)
text(0.365,0.77-strheight("O", cex=4)/2,"O", cex=4)
Resizing doesn't work, but you get the idea.
I have a data set of item difficulties that correspond to items on a questionnaire that looks like this:
## item difficulty
## 1 ITEM_01_A 2.31179818
## 2 ITEM_02_B 1.95215238
## 3 ITEM_03_C 1.93479536
## 4 ITEM_04_D 1.62610855
## 5 ITEM_05_E 1.62188759
## 6 ITEM_06_F 1.45137544
## 7 ITEM_07_G 0.94255210
## 8 ITEM_08_H 0.89941812
## 9 ITEM_09_I 0.72752197
## 10 ITEM_10_J 0.61792597
## 11 ITEM_11_K 0.61288399
## 12 ITEM_12_L 0.39947791
## 13 ITEM_13_M 0.32209970
## 14 ITEM_14_N 0.31707701
## 15 ITEM_15_O 0.20902108
## 16 ITEM_16_P 0.19923607
## 17 ITEM_17_Q 0.06023317
## 18 ITEM_18_R -0.31155481
## 19 ITEM_19_S -0.67777282
## 20 ITEM_20_T -1.15013758
I want to make an item map of these items that looks similar (not exactly) to this (I created this in word but it lacks true scaling as I just eyeballed the scale). It's not really a traditional statistical graphic and so I don't really know how to approach this. I don't care what graphics system this is done in but I am more familiar with ggplot2 and base.
I would greatly appreciate a method of plotting this sort of unusual plot.
Here's the data set (I'm including it as I was having difficulty using read.table on the dataframe above):
DF <- structure(list(item = c("ITEM_01_A", "ITEM_02_B", "ITEM_03_C",
"ITEM_04_D", "ITEM_05_E", "ITEM_06_F", "ITEM_07_G", "ITEM_08_H",
"ITEM_09_I", "ITEM_10_J", "ITEM_11_K", "ITEM_12_L", "ITEM_13_M",
"ITEM_14_N", "ITEM_15_O", "ITEM_16_P", "ITEM_17_Q", "ITEM_18_R",
"ITEM_19_S", "ITEM_20_T"), difficulty = c(2.31179818110545, 1.95215237740899,
1.93479536058926, 1.62610855327073, 1.62188759115818, 1.45137543733965,
0.942552101641177, 0.899418119889782, 0.7275219669431, 0.617925967008653,
0.612883990709181, 0.399477905189577, 0.322099696946661, 0.31707700560997,
0.209021078266059, 0.199236065264793, 0.0602331732900628, -0.311554806052955,
-0.677772822413495, -1.15013757942119)), .Names = c("item", "difficulty"
), row.names = c(NA, -20L), class = "data.frame")
Thank you in advance.
Here is a quick example:
ggplot(DF, aes(x=1, y=difficulty, label = item)) +
geom_text(size = 3) +
scale_y_continuous(breaks = DF$difficulty, minor_breaks = NULL, labels = sprintf("%.02f", DF$difficulty)) +
scale_x_continuous(breaks = NULL) +
opts(panel.grid.major = theme_blank())
but sometimes two items are too narrow so overlapped. You may do like this:
m <- 0.1
nd <- diff(rev(DF$difficulty))
nd <- c(0, cumsum(ifelse(nd < m, m, nd)))
DF$nd <- rev(rev(DF$difficulty)[1] + nd)
ggplot(DF, aes(x=1, y=nd, label = item)) +
geom_text(size = 3) +
scale_y_continuous(breaks = DF$nd, labels = sprintf("%.02f", DF$difficulty), DF$difficulty, minor_breaks = NULL) +
scale_x_continuous(breaks = NULL) +
opts(panel.grid.major = theme_blank())
Here is a solution with base graphics.
# Compute the position of the labels to limit overlaps:
# move them as little as possible, but keep them
# at least .1 units apart.
library(quadprog)
spread <- function(b, eps=.1) {
stopifnot(b == sort(b))
n <- length(b)
Dmat <- diag(n)
dvec <- b
Amat <- matrix(0,nr=n,nc=n-1)
Amat[cbind(1:(n-1), 1:(n-1))] <- -1
Amat[cbind(2:n, 1:(n-1))] <- 1
bvec <- rep(eps,n-1)
r <- solve.QP(Dmat, dvec, Amat, bvec)
r$solution
}
DF <- DF[ order(DF$difficulty), ]
DF$position <- spread(DF$difficulty, .1)
ylim <- range(DF$difficulty)
plot( NA,
xlim = c(.5,2),
ylim = ylim + .1*c(-1,1)*diff(ylim),
axes=FALSE, xlab="", ylab=""
)
text(.9, DF$position, labels=round(DF$difficulty,3), adj=c(1,0))
text(1.1, DF$position, labels=DF$item, adj=c(0,0))
arrows(1,min(DF$position),1,max(DF$position),code=3)
text(1,min(DF$position),labels="Easier",adj=c(.5,2))
text(1,max(DF$position),labels="More difficult",adj=c(.5,-1))
text(.9, max(DF$position),labels="Difficulty",adj=c(1,-2))
text(1.1,max(DF$position),labels="Item", adj=c(0,-2))
My own attempt but I think I'm going to like Vincent's solution much better as it looks like my original specification.
DF <- DF[order(DF$difficulty), ]
par(mar=c(1, 1, 3, 0)+.4)
plot(rep(1:2, each=10), DF$difficulty, main = "Item Map ",
ylim = c(max(DF$difficulty)+1, min(DF$difficulty)-.2),
type = "n", xlab="", ylab="", axes=F, xaxs="i")
text(rep(1.55, 20), rev(DF$difficulty[c(T, F)]),
DF$item[c(F, T)], cex=.5, pos = 4)
text(rep(1, 20), rev(DF$difficulty[c(F, T)]),
DF$item[c(T, F)], cex=.5, pos = 4)
par(mar=c(0, 0, 0,0))
arrows(1.45, 2.45, 1.45, -1.29, .1, code=3)
text(rep(1.52, 20), DF$difficulty[c(T, F)],
rev(round(DF$difficulty, 2))[c(T, F)], cex=.5, pos = 2)
text(rep(1.44, 20), DF$difficulty[c(F, T)],
rev(round(DF$difficulty, 2))[c(F, T)], cex=.5, pos = 2)
text(1.455, .5, "DIFFICULTY", cex=1, srt = -90)
text(1.45, -1.375, "More Difficult", cex=.6)
text(1.45, 2.5, "Easier", cex=.6)
par(mar=c(0, 0, 0,0))