Related
I am trying to make an animated plot where new traces are introduced, the traces are animated, and the axes are then rescaled. I am having trouble getting these things to work together. A reprex is below. It works except when I have both Animate Traces and Rescale Axis, then the axis rescaling gets reset on every iteration.
Using Proxy Interface in Plotly/Shiny to dynamically change data
https://community.plot.ly/t/how-to-efficiently-restyle-update-modify-plot-containing-frames/5553
https://plot.ly/javascript/plotlyjs-function-reference/
https://plot.ly/javascript/animations/
It's rather hard to follow the Plotly documentation. I couldn't get addFrames, relayout, restyle, react, or update to work for me. I've had the most luck with animate. I would greatly appreciate any help, I've been struggling with this for two weeks already.
# plotly_add_anim13.R
library(shiny)
library(plotly)
library(dplyr)
library(purrr)
ui <- fluidPage(
checkboxInput("add", "Add Trace", TRUE),
checkboxInput("animate", "Animate Traces", FALSE),
checkboxInput("rescale", "Rescale Axis", FALSE),
plotlyOutput("plot")
)
server <- function(input, output, session){
my <- reactiveValues(
fnumber = NA, # frame number
frame = NA, # frame data list
ntraces = NA, # number of traces
xrange = NA # xaxis range
)
speed = 1000 # redraw interval in milliseconds
output$plot <- renderPlotly({
isolate({
cat("renderPlotly\n")
my$fnumber <- 1
my$ntraces <- 2
f <- as.character(my$fnumber)
x <- runif(2)
y <- rep(runif(1), 2)
t <- c("A", "B")
ids0 <- paste0(my$ntraces-2, letters[1:2])
ids1 <- paste0(my$ntraces-1, letters[1:2])
my$xrange <- c(0,1)
# https://community.plot.ly/t/how-to-efficiently-restyle-update-modify-plot-containing-frames/5553
my$frame <- list(
name = f,
data = list(
list(x=x, y=y, frame=f, ids=ids0, type="scatter", mode="lines", showlegend=FALSE),
list(x=x, y=y, frame=f, ids=ids1, type="scatter", mode="text", text=t, showlegend=FALSE)
),
traces = as.list(as.integer(c(my$ntraces-2, my$ntraces-1))),
layout = list(xaxis=list(range=my$xrange, zeroline=FALSE),
yaxis=list(range=c(0,1), tickmode="array", tickvals=seq(0,1,0.2), ticktext=seq(0,1,0.2)))
)
p <- plot_ly()
p <- do.call(add_trace, prepend(my$frame$data[[1]], list(p)))
p <- do.call(add_trace, prepend(my$frame$data[[2]], list(p)))
p <- do.call(layout, prepend(my$frame$layout, list(p)))
p <- animation_opts(p, frame=speed, transition=speed)
p
})
})
proxy <- plotlyProxy("plot", session=session)
# https://shiny.rstudio.com/reference/shiny/0.14/reactiveTimer.html
autoInvalidate <- reactiveTimer(speed*2)
observeEvent(autoInvalidate(), {
# req(NULL)
# https://stackoverflow.com/questions/50620360/using-proxy-interface-in-plotly-shiny-to-dynamically-change-data
# https://community.plot.ly/t/how-to-efficiently-restyle-update-modify-plot-containing-frames/5553
# https://plot.ly/javascript/animations/#frame-groups-and-animation-modes
# https://plot.ly/javascript/animations/
if (input$add){
cat("add trace\n")
my$fnumber <- my$fnumber + 1
my$ntraces <- my$ntraces + 2
f <- as.character(my$fnumber)
x <- runif(2)
y <- rep(runif(1), 2)
t <- c("A", "B")
ids0 <- paste0(my$ntraces-2, letters[1:2])
ids1 <- paste0(my$ntraces-1, letters[1:2])
my$frame$name <- f
my$frame$data[[my$ntraces-1]] <- list(x=x, y=y, frame=f, ids=ids0, type="scatter", mode="lines", showlegend=FALSE)
my$frame$data[[my$ntraces-0]] <- list(x=x, y=y, frame=f, ids=ids1, type="scatter", mode="text", text=t, showlegend=FALSE)
my$frame$traces <- as.list(as.integer(1:my$ntraces - 1))
plotlyProxyInvoke(proxy, "addTraces",
list(
my$frame$data[[my$ntraces-1]],
my$frame$data[[my$ntraces-0]]
))
plotlyProxyInvoke(proxy, "animate",
# frameOrGroupNameOrFrameList
list(
name = my$frame$name,
data = my$frame$data,
traces = my$frame$traces
),
# animationAttributes
list(
frame=list(duration=0),
transition=list(duration=0)
)
)# animate
}
if (input$animate){
cat("animate traces\n")
my$fnumber <- my$fnumber + 1
f <- as.character(my$fnumber)
traces <- 1:my$ntraces - 1
for (i in seq(0, my$ntraces-2, 2)){
x <- runif(2)
y <- rep(runif(1), 2)
t <- c("A", "B")
ids0 <- paste0(i, letters[1:2])
ids1 <- paste0(i+1, letters[1:2])
my$frame$data[[i+1]] <- list(x=x, y=y, frame=f, ids=ids0, type="scatter", mode="lines", showlegend=FALSE)
my$frame$data[[i+2]] <- list(x=x, y=y, frame=f, ids=ids1, type="scatter", mode="text", text=t, showlegend=FALSE)
}
my$frame$name <- f
plotlyProxyInvoke(proxy, "animate",
# frameOrGroupNameOrFrameList
list(
name = my$frame$name,
data = my$frame$data,
traces = my$frame$traces
),
# animationAttributes
list(
frame=list(duration=speed),
transition=list(duration=speed)
)
)# animate
}
if (input$rescale){
cat("animate layout\n")
my$fnumber <- my$fnumber + 1
f <- as.character(my$fnumber)
my$xrange <- runif(2)*0.1+c(-0.1,1)
my$frame$name <- f
my$frame$layout <- list(xaxis=list(range=my$xrange))
plotlyProxyInvoke(proxy, "animate",
# frameOrGroupNameOrFrameList
list(
name = my$frame$name,
data = my$frame$data,
traces = my$frame$traces,
layout = my$frame$layout
),
# animationAttributes
list(
frame=list(duration=speed),
transition=list(duration=speed)
)
) # animate
}
}) # observeEvent
}
shinyApp(ui, server)
With facet_zoom() from the ggforce package one can create nice zooms to highlight certain regions of a plot. Unfortunately, when zooming in on the y axis the original plot is always on the right side.
Is there a way to place the original plot on the left?
This would feel more intuitive to first look at the main plot and then at the zoomed region. As an example I would like to swap the position of the two facets in this plot:
(No reproducible example added, since I believe this is a question about the existence of a certain functionality.)
I've tweaked the current code for FacetZoom on GitHub to swop the horizontal order from [zoom, original] to [original, zoom]. The changes aren't complicated, but they are scattered throughout draw_panels() function's code, so the full code is rather long.
Result:
# example 1, with split = FALSE, horizontal = TRUE (i.e. default settings)
p1 <- ggplot(mtcars, aes(x = mpg, y = disp, colour = factor(cyl))) +
geom_point() +
theme_bw()
p1 + ggtitle("Original") + facet_zoom(y = disp > 300)
p1 + ggtitle("Modified") + facet_zoom2(y = disp > 300)
# example 2, with split = TRUE
p2 <- ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
geom_point() +
theme_bw()
p2 + ggtitle("Original") +
facet_zoom(xy = Species == "versicolor", split = TRUE)
p2 + ggtitle("Modified") +
facet_zoom2(xy = Species == "versicolor", split = TRUE)
Code used (I've commented out the original code, where modified code is used, & indicated the packages for functions from other packages):
library(ggplot)
library(ggforce)
library(grid)
# define facet_zoom2 function to use FacetZoom2 instead of FacetZoom
# (everything else is the same as facet_zoom)
facet_zoom2 <- function(x, y, xy, zoom.data, xlim = NULL, ylim = NULL,
split = FALSE, horizontal = TRUE, zoom.size = 2,
show.area = TRUE, shrink = TRUE) {
x <- if (missing(x)) if (missing(xy)) NULL else lazyeval::lazy(xy) else lazyeval::lazy(x)
y <- if (missing(y)) if (missing(xy)) NULL else lazyeval::lazy(xy) else lazyeval::lazy(y)
zoom.data <- if (missing(zoom.data)) NULL else lazyeval::lazy(zoom.data)
if (is.null(x) && is.null(y) && is.null(xlim) && is.null(ylim)) {
stop("Either x- or y-zoom must be given", call. = FALSE)
}
if (!is.null(xlim)) x <- NULL
if (!is.null(ylim)) y <- NULL
ggproto(NULL, FacetZoom2,
shrink = shrink,
params = list(
x = x, y = y, xlim = xlim, ylim = ylim, split = split, zoom.data = zoom.data,
zoom.size = zoom.size, show.area = show.area,
horizontal = horizontal
)
)
}
# define FacetZoom as a ggproto object that inherits from FacetZoom,
# with a modified draw_panels function. the compute_layout function references
# the version currently on GH, which is slightly different from the CRAN
# package version.
FacetZoom2 <- ggproto(
"FacetZoom2",
ggforce::FacetZoom,
compute_layout = function(data, params) {
layout <- rbind( # has both x & y dimension
data.frame(name = 'orig', SCALE_X = 1L, SCALE_Y = 1L),
data.frame(name = 'x', SCALE_X = 2L, SCALE_Y = 1L),
data.frame(name = 'y', SCALE_X = 1L, SCALE_Y = 2L),
data.frame(name = 'full', SCALE_X = 2L, SCALE_Y = 2L),
data.frame(name = 'orig_true', SCALE_X = 1L, SCALE_Y = 1L),
data.frame(name = 'zoom_true', SCALE_X = 1L, SCALE_Y = 1L)
)
if (is.null(params$y) && is.null(params$ylim)) { # no y dimension
layout <- layout[c(1,2, 5:6),]
} else if (is.null(params$x) && is.null(params$xlim)) { # no x dimension
layout <- layout[c(1,3, 5:6),]
}
layout$PANEL <- seq_len(nrow(layout))
layout
},
draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord,
data, theme, params) {
if (is.null(params$x) && is.null(params$xlim)) {
params$horizontal <- TRUE
} else if (is.null(params$y) && is.null(params$ylim)) {
params$horizontal <- FALSE
}
if (is.null(theme[['zoom']])) {
theme$zoom <- theme$strip.background
}
if (is.null(theme$zoom.x)) {
theme$zoom.x <- theme$zoom
}
if (is.null(theme$zoom.y)) {
theme$zoom.y <- theme$zoom
}
axes <- render_axes(ranges, ranges, coord, theme, FALSE)
panelGrobs <- ggforce:::create_panels(panels, axes$x, axes$y)
panelGrobs <- panelGrobs[seq_len(length(panelGrobs) - 2)]
if ('full' %in% layout$name && !params$split) {
panelGrobs <- panelGrobs[c(1, 4)]
}
# changed coordinates in indicator / lines to zoom from
# the opposite horizontal direction
if ('y' %in% layout$name) {
if (!inherits(theme$zoom.y, 'element_blank')) {
zoom_prop <- scales::rescale(
y_scales[[2]]$dimension(ggforce:::expansion(y_scales[[2]])),
from = y_scales[[1]]$dimension(ggforce:::expansion(y_scales[[1]])))
indicator <- polygonGrob(
x = c(0, 0, 1, 1), # was x = c(1, 1, 0, 0),
y = c(zoom_prop, 1, 0),
gp = gpar(col = NA, fill = alpha(theme$zoom.y$fill, 0.5)))
lines <- segmentsGrob(
x0 = c(1, 1), x1 = c(0, 0), # was x0 = c(0, 0), x1 = c(1, 1)
y0 = c(0, 1), y1 = zoom_prop,
gp = gpar(col = theme$zoom.y$colour,
lty = theme$zoom.y$linetype,
lwd = theme$zoom.y$size,
lineend = 'round'))
indicator_h <- grobTree(indicator, lines)
} else {
indicator_h <- zeroGrob()
}
}
if ('x' %in% layout$name) {
if (!inherits(theme$zoom.x, 'element_blank')) {
zoom_prop <- scales::rescale(x_scales[[2]]$dimension(ggforce:::expansion(x_scales[[2]])),
from = x_scales[[1]]$dimension(ggforce:::expansion(x_scales[[1]])))
indicator <- polygonGrob(c(zoom_prop, 1, 0), c(1, 1, 0, 0),
gp = gpar(col = NA, fill = alpha(theme$zoom.x$fill, 0.5)))
lines <- segmentsGrob(x0 = c(0, 1), y0 = c(0, 0), x1 = zoom_prop, y1 = c(1, 1),
gp = gpar(col = theme$zoom.x$colour,
lty = theme$zoom.x$linetype,
lwd = theme$zoom.x$size,
lineend = 'round'))
indicator_v <- grobTree(indicator, lines)
} else {
indicator_v <- zeroGrob()
}
}
if ('full' %in% layout$name && params$split) {
space.x <- theme$panel.spacing.x
if (is.null(space.x)) space.x <- theme$panel.spacing
space.x <- unit(5 * as.numeric(convertUnit(space.x, 'cm')), 'cm')
space.y <- theme$panel.spacing.y
if (is.null(space.y)) space.y <- theme$panel.spacing
space.y <- unit(5 * as.numeric(convertUnit(space.y, 'cm')), 'cm')
# change horizontal order of panels from [zoom, original] to [original, zoom]
# final <- gtable::gtable_add_cols(panelGrobs[[3]], space.x)
# final <- cbind(final, panelGrobs[[1]], size = 'first')
# final_tmp <- gtable::gtable_add_cols(panelGrobs[[4]], space.x)
# final_tmp <- cbind(final_tmp, panelGrobs[[2]], size = 'first')
final <- gtable::gtable_add_cols(panelGrobs[[1]], space.x)
final <- cbind(final, panelGrobs[[3]], size = 'first')
final_tmp <- gtable::gtable_add_cols(panelGrobs[[2]], space.x)
final_tmp <- cbind(final_tmp, panelGrobs[[4]], size = 'first')
final <- gtable::gtable_add_rows(final, space.y)
final <- rbind(final, final_tmp, size = 'first')
final <- gtable::gtable_add_grob(final, list(indicator_h, indicator_h),
c(2, 6), 3, c(2, 6), 5,
z = -Inf, name = "zoom-indicator")
final <- gtable::gtable_add_grob(final, list(indicator_v, indicator_v),
3, c(2, 6), 5,
z = -Inf, name = "zoom-indicator")
heights <- unit.c(
unit(max_height(list(axes$x[[1]]$top, axes$x[[3]]$top)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$x[[1]]$bottom, axes$x[[3]]$bottom)), 'cm'),
space.y,
unit(max_height(list(axes$x[[2]]$top, axes$x[[4]]$top)), 'cm'),
unit(params$zoom.size, 'null'),
unit(max_height(list(axes$x[[2]]$bottom, axes$x[[4]]$bottom)), 'cm')
)
# swop panel width specifications according to the new horizontal order
widths <- unit.c(
# unit(max_width(list(axes$y[[3]]$left, axes$y[[4]]$left)), 'cm'),
# unit(params$zoom.size, 'null'),
# unit(max_height(list(axes$y[[3]]$right, axes$y[[4]]$right)), 'cm'),
# space.x,
# unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
# unit(1, 'null'),
# unit(max_height(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm')
unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm'),
space.x,
unit(max_width(list(axes$y[[3]]$left, axes$y[[4]]$left)), 'cm'),
unit(params$zoom.size, 'null'),
unit(max_height(list(axes$y[[3]]$right, axes$y[[4]]$right)), 'cm')
)
final$heights <- heights
final$widths <- widths
} else {
if (params$horizontal) {
space <- theme$panel.spacing.x
if (is.null(space)) space <- theme$panel.spacing
space <- unit(5 * as.numeric(convertUnit(space, 'cm')), 'cm')
heights <- unit.c(
unit(max_height(list(axes$x[[1]]$top, axes$x[[2]]$top)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$x[[1]]$bottom, axes$x[[2]]$bottom)), 'cm')
)
# change horizontal order of panels from [zoom, original] to [original, zoom]
# first <- gtable::gtable_add_cols(panelGrobs[[2]], space)
# first <- cbind(final, panelGrobs[[1]], size = 'first')
final <- gtable::gtable_add_cols(panelGrobs[[1]], space)
final <- cbind(final, panelGrobs[[2]], size = "first")
final$heights <- heights
# swop panel width specifications according to the new horizontal order
# unit(c(params$zoom.size, 1), 'null')
final$widths[panel_cols(final)$l] <- unit(c(1, params$zoom.size), 'null')
final <- gtable::gtable_add_grob(final, indicator_h, 2, 3, 2, 5,
z = -Inf, name = "zoom-indicator")
} else {
space <- theme$panel.spacing.y
if (is.null(space)) space <- theme$panel.spacing
space <- unit(5 * as.numeric(convertUnit(space, 'cm')), 'cm')
widths <- unit.c(
unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm')
)
final <- gtable::gtable_add_rows(panelGrobs[[1]], space)
final <- rbind(final, panelGrobs[[2]], size = 'first')
final$widths <- widths
final$heights[panel_rows(final)$t] <- unit(c(1, params$zoom.size), 'null')
final <- gtable::gtable_add_grob(final, indicator_v, 3, 2, 5,
z = -Inf, name = "zoom-indicator")
}
}
final
}
)
Note: create_panels and expansion are un-exported functions from the ggforce package, so I referenced them with triple colons. This isn't robust for writing packages, but should suffice as a temporary workaround.
Update 30 Oct 2019: A suggestion for those seeing errors like Invalid 'type' (list) of argument after trying to use this solution as-is. The issue is likely due to updates made to the ggforcepackage since this solution was developed. To get the code in this solution working again, install the version of ggforce that was available when the solution was developed. This can be done with the devtools package pointing to the 4008a2e commit:
devtools::install_github("thomasp85/ggforce", ref = '4008a2e')
I want to export my dataframe to a pdf file. Dataframe is pretty large, so it is causing problems while exporting. I used gridExtra package as specified here writing data frame to pdf table but it did not work for my dataframe as it contains a lot of data.
Any ideas how it can be achieved?
Code:
library(gridExtra)
df <- data.frame(replicate(10,sample(0:1,1000,rep=TRUE)))
pdf(file = "df2.pdf")
grid.table(df)
dev.off()
#Baqir, you can try solution given on this link:
https://thusithamabotuwana.wordpress.com/2016/01/02/creating-pdf-documents-with-rrstudio/
It will be like this:
library(grid)
library(gridExtra)
df <- data.frame(replicate(10,sample(0:1,1000,rep=TRUE)))
dim(df)
maxrow = 35
npages = ceiling(nrow(df)/maxrow)
pdf("test.pdf", height = 11, width = 8.5)
idx = seq(1, maxrow)
grid.table(df[idx,],rows = NULL)
for(i in 2:npages){
grid.newpage();
if(i*maxrow <= nrow(df)){
idx = seq(1+((i-1)*maxrow), i * maxrow)
}
else{
idx = seq(1+((i-1)*maxrow), nrow(df))
}
grid.table(df[idx, ],rows = NULL)
}
dev.off()
Hope this works!
#Pryore, I found some part of the solution from the link:
link
Here is the code for header and footer.
Hope this works!
makeHeader <- function(headerText= "your header", size= 1, color= grey(.5))
{
require(grid)
pushViewport(viewport())
grid.text(label= headerText,
x = unit(1,"npc") - unit(110, "mm"),
y = unit(270.8, "mm"),
gp=gpar(cex= size, col=color))
popViewport()
}
makeFootnote <- function(footnoteText= "your footnote",
size= 1, color= grey(.5))
{
require(grid)
pushViewport(viewport())
grid.text(label= footnoteText ,
x = unit(1,"npc") - unit(27, "mm"),
y = unit(3, "mm"),
gp=gpar(cex= size, col=color))
popViewport()
}
library(grid)
library(gridExtra)
df <- data.frame(replicate(10,sample(0:1,1000,rep=TRUE)))
dim(df)
maxrow = 35
npages = ceiling(nrow(df)/maxrow)
pdf("trial.pdf", height = 11, width = 8.5)
idx = seq(1, maxrow)
grid.table(df[idx,],rows = NULL)
for(i in 1:npages){
grid.newpage();
makeFootnote()
makeHeader()
if(i*maxrow <= nrow(df)){
idx = seq(1+((i-1)*maxrow), i * maxrow)
}
else{
idx = seq(1+((i-1)*maxrow), nrow(df))
}
grid.table(df[idx, ],rows = NULL)
}
dev.off()
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 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))