i am creating overlapping labels in a textGrob
txt <- rep("Hi there",2)
grid.newpage()
fg <- frameGrob()
tg <- textGrob(label = txt,x = c(0.25,0.4),y=c(0.5,0.5))
fg <- packGrob(fg, tg)
grid.draw(fg)
then i take the same textGrob and find the text bounds, convertUnit and draw the tight boxes around the text and plot again i get boxes that dont overlap.
What is the correct way to define tg_bounds in order to reproduce the overlap?
tg_bounds <- function(tg,lab,theta){
bounds <- grid:::grid.Call(grid:::L_textBounds,
grDevices::as.graphicsAnnot(tg$label[lab]),
tg$x[lab],
tg$y[lab],
resolveHJust(tg$just, tg$hjust),
resolveVJust(tg$just,tg$vjust),
tg$rot, theta)
bounds <- unit(bounds, "inches")
convertUnit(bounds,unitTo = attr(tg$x,'unit'),valueOnly = TRUE)
}
bounds1 <- do.call('rbind',lapply(seq(1,360,1),tg_bounds,tg = tg,lab = 1))
bounds2 <- do.call('rbind',lapply(seq(1,360,1),tg_bounds,tg = tg,lab = 2))
plot(bounds1[,1],bounds1[,2],type='line',xlim = c(0,.5),ylim = c(0.4,.5))
lines(bounds2[,1],bounds2[,2])
Related
I am trying to combine two ggplot objects with patchwork - two plots with different subsets of data, but the same x variable (and therefore same unit). I would like to align the plots according to the x values - Each x unit should have the same physical width in the final plot.
This is very easy when actually plotting the entire width of the larger data set (see plot below) - but I struggle to plot only parts of the data and keeping the same alignment.
library(ggplot2)
library(patchwork)
library(dplyr)
p1 <-
ggplot(mtcars, aes(mpg)) +
geom_density(trim = TRUE) +
scale_x_continuous(limits = c(10,35))
p2 <-
ggplot(filter(mtcars, mpg < 20), aes(mpg)) +
geom_histogram(binwidth = 1, boundary = 1) +
scale_x_continuous(limits = c(10,35))
p1/p2
Created on 2019-08-07 by the reprex package (v0.3.0)
The desired output
That's photoshopped
adding coord_cartesian(xlim = c(10,(20 or 35)), clip = 'off'), and/or changing scale_x limits to c(0,(20 or 35)) doesn't work.
patchwork also won't let me set the widths of both plots when they are in two rows, which makes sense in a way. So I could create an empty plot for the second row and set the widths for those, but this seems a terrible hack and I feel there must be a much easier solution.
I am not restricted to patchwork, but any solution allowing to use it would be very welcome.
I modified the align_plots function from the cowplot package for this, so that its plot_grid function can now support adjustments to the dimensions of each plot.
(The main reason I went with cowplot rather than patchwork is that I haven't had much tinkering experience with the latter, and overloading common operators like + makes me slightly nervous.)
Demonstration of results
# x / y axis range of p1 / p2 have been changed for illustration purpose
p1 <- ggplot(mtcars, aes(mpg, 1 + stat(count))) +
geom_density(trim = TRUE) +
scale_x_continuous(limits = c(10,35)) +
coord_cartesian(ylim = c(1, 3.5))
p2 <- ggplot(filter(mtcars, mpg >= 15 & mpg < 30), aes(mpg)) +
geom_histogram(binwidth = 1, boundary = 1)
plot_grid(p1, p2, ncol = 1, align = "v") # plots in 1 column, x-axes aligned
plot_grid(p1, p2, nrow = 1, align = "h") # plots in 1 row, y-axes aligned
Plots in 1 column (x-axes aligned for 15-28 range):
Plots in 1 row (y-axes aligned for 1 - 3.5 range):
Caveats
This hack assumes the plots that the user intends to align (either horizontally or vertically) have reasonably similar axes of comparable magnitude. I haven't tested it on more extreme cases.
This hack expects simple non-faceted plots in Cartesian coordinates. I'm not sure what one could expect from aligning faceted plots. Similarly, I'm not considering polar coordinates (what's there to align?) or map projections (haven't looked into this, but they feel rather complicated).
This hack expects the gtable cell containing the plot panel to be in the 7th row / 5th column of the gtable object, which is based on my understanding of how ggplot objects are typically converted to gtables, and may not survive changes to the underlying code.
Code
Modified version of cowplot::align_plots:
align_plots_modified <- function (..., plotlist = NULL, align = c("none", "h", "v", "hv"),
axis = c("none", "l", "r", "t", "b", "lr", "tb", "tblr"),
greedy = TRUE) {
plots <- c(list(...), plotlist)
num_plots <- length(plots)
grobs <- lapply(plots, function(x) {
if (!is.null(x)) as_gtable(x)
else NULL
})
halign <- switch(align[1], h = TRUE, vh = TRUE, hv = TRUE, FALSE)
valign <- switch(align[1], v = TRUE, vh = TRUE, hv = TRUE, FALSE)
vcomplex_align <- hcomplex_align <- FALSE
if (valign) {
# modification: get x-axis value range associated with each plot, create union of
# value ranges across all plots, & calculate the proportional width of each plot
# (with white space on either side) required in order for the plots to align
plot.x.range <- lapply(plots, function(x) ggplot_build(x)$layout$panel_params[[1]]$x.range)
full.range <- range(plot.x.range)
plot.x.range <- lapply(plot.x.range,
function(x) c(diff(c(full.range[1], x[1]))/ diff(full.range),
diff(x)/ diff(full.range),
diff(c(x[2], full.range[2]))/ diff(full.range)))
num_widths <- unique(lapply(grobs, function(x) {
length(x$widths)
}))
num_widths[num_widths == 0] <- NULL
if (length(num_widths) > 1 || length(grep("l|r", axis[1])) > 0) {
vcomplex_align = TRUE
warning("Method not implemented for faceted plots. Placing unaligned.")
valign <- FALSE
}
else {
max_widths <- list(do.call(grid::unit.pmax,
lapply(grobs, function(x) {x$widths})))
}
}
if (halign) {
# modification: get y-axis value range associated with each plot, create union of
# value ranges across all plots, & calculate the proportional width of each plot
# (with white space on either side) required in order for the plots to align
plot.y.range <- lapply(plots, function(x) ggplot_build(x)$layout$panel_params[[1]]$y.range)
full.range <- range(plot.y.range)
plot.y.range <- lapply(plot.y.range,
function(x) c(diff(c(full.range[1], x[1]))/ diff(full.range),
diff(x)/ diff(full.range),
diff(c(x[2], full.range[2]))/ diff(full.range)))
num_heights <- unique(lapply(grobs, function(x) {
length(x$heights)
}))
num_heights[num_heights == 0] <- NULL
if (length(num_heights) > 1 || length(grep("t|b", axis[1])) > 0) {
hcomplex_align = TRUE
warning("Method not implemented for faceted plots. Placing unaligned.")
halign <- FALSE
}
else {
max_heights <- list(do.call(grid::unit.pmax,
lapply(grobs, function(x) {x$heights})))
}
}
for (i in 1:num_plots) {
if (!is.null(grobs[[i]])) {
if (valign) {
grobs[[i]]$widths <- max_widths[[1]]
# modification: change panel cell's width to a proportion of unit(1, "null"),
# then add whitespace to the left / right of the plot's existing gtable
grobs[[i]]$widths[[5]] <- unit(plot.x.range[[i]][2], "null")
grobs[[i]] <- gtable::gtable_add_cols(grobs[[i]],
widths = unit(plot.x.range[[i]][1], "null"),
pos = 0)
grobs[[i]] <- gtable::gtable_add_cols(grobs[[i]],
widths = unit(plot.x.range[[i]][3], "null"),
pos = -1)
}
if (halign) {
grobs[[i]]$heights <- max_heights[[1]]
# modification: change panel cell's height to a proportion of unit(1, "null"),
# then add whitespace to the bottom / top of the plot's existing gtable
grobs[[i]]$heights[[7]] <- unit(plot.y.range[[i]][2], "null")
grobs[[i]] <- gtable::gtable_add_rows(grobs[[i]],
heights = unit(plot.y.range[[i]][1], "null"),
pos = -1)
grobs[[i]] <- gtable::gtable_add_rows(grobs[[i]],
heights = unit(plot.y.range[[i]][3], "null"),
pos = 0)
}
}
}
grobs
}
Utilising the above modified function with cowplot package's plot_grid:
# To start using (in current R session only; effect will not carry over to subsequent session)
trace(cowplot::plot_grid, edit = TRUE)
# In the pop-up window, change `grobs <- align_plots(...)` (at around line 27) to
# `grobs <- align_plots_modified(...)`
# To stop using
untrace(cowplot::plot_grid)
(Alternatively, we can define a modified version of plot_grid function that uses align_plots_modified instead of cowplot::align_plots. Results would be the same either way.)
Here is an option with grid.arrange that does not use a blank plot, but requires a manual of adjustment of:
plot margin
x axis expansion
number of decimal places in y axis labels
library(ggplot2)
library(dplyr)
library(gridExtra)
p1 <-
ggplot(mtcars, aes(mpg)) +
geom_density(trim = TRUE) +
scale_x_continuous(limits = c(10,35), breaks=seq(10,35,5), expand = expand_scale(add=c(0,0)))
p2 <-
ggplot(filter(mtcars, mpg < 20), aes(mpg)) +
geom_histogram(binwidth = 1, boundary = 1) +
scale_x_continuous(limits = c(10,20), breaks=seq(10,20,5), expand = expand_scale(add=c(0,0))) +
scale_y_continuous(labels = scales::number_format(accuracy = 0.01)) +
theme(plot.margin = unit(c(0,1,0,0), "cm"))
grid.arrange(p1, p2,
layout_matrix = rbind(c(1, 1), c(2, NA))
)
Should make this plot:
I'm trying to connect every point in my array with all other points in this array using line segment and write some text slightly above this lines. So, I want to achieve next:
I already tried to use segments() and lines() functions, but I don't know how can I do exactly what I described.
And as I said, now I have only array of coordinates and array of strings which I want to write.
How can I achieve this(It will be good if I will need to use only standard R libraries)?
UPD:
dataset.csv:
,A,B,C
A,0,1,2
B,1,0,3
C,2,3,0
script.r:
myDataset <- read.csv("dataset.csv")
row.names(myDataset) <- myDataset[, 1]
myDataset <- myDataset[, -1]
d <- dist(myDataset)
fit <- cmdscale(d,eig=TRUE, k=2)
x <- fit$points[,1]
y <- fit$points[,2]
Here's an example that uses combn to generate combinations of two points and then draw lines between them and to compute distances and write them in the middle too.
#DATA
set.seed(42)
df = data.frame(x = rnorm(4), y = rnorm(4))
#DRAW POINTS
plot(df)
#DRAW LINES
combn(1:NROW(df), 2, function(x)
lines(df[x,]), simplify = FALSE)
#WRITE TEXT
combn(1:NROW(df), 2, function(x)
text(x = mean(df[x,1]), #calculate center point x-value in the line
y = mean(df[x,2]), #calculate center point y-value in the line
labels = round(dist(df[x,]), 2), #calculate distance to write
srt = 180 * atan(diff(df[x, 2])/diff(df[x,1]))/pi, #calculate rotation angle of text
pos = 3, #place text slightly above given x and y
font = 2), #bold text
simplify = FALSE)
UPDATE
myDataset <- read.csv(strip.white = TRUE, stringsAsFactors = FALSE, header = TRUE, text = ",A,B,C
A,0,1,2
B,1,0,3
C,2,3,0")
row.names(myDataset) <- myDataset[, 1]
myDataset <- myDataset[, -1]
d <- dist(myDataset)
fit <- cmdscale(d,eig=TRUE, k=2)
x <- fit$points[,1]
y <- fit$points[,2]
df = data.frame(x, y)
#DRAW POINTS
plot(df, asp = 1)
text(x = df[,1], y = df[,2], labels = rownames(df), pos = 1)
#Create a list of combination of indices
temp = combn(1:NROW(df), 2, simplify = FALSE)
#DRAW LINES
sapply(temp, function(i) lines(df[i,]))
#WRITE TEXT
sapply(temp, function(x)
text(x = mean(df[x,1]), #calculate center point x-value in the line
y = mean(df[x,2]), #calculate center point y-value in the line
labels = myDataset[cbind(which(row.names(myDataset) == row.names(df)[x[1]]),
which(colnames(myDataset) == row.names(df)[x[2]]))],
srt = 180 * atan(diff(df[x, 2])/diff(df[x,1]))/pi, #calculate rotation angle of text
pos = 3, #place text slightly above given x and y
font = 2), #bold text
simplify = FALSE)
Trying to achieve this with graphics primitives (such as lines) is bound to be a pain.
Use a dedicated library for graph plotting instead, e.g. ggraph. The “Edges” vignette has an example with edge labels:
ggraph(simple, layout = 'graphopt') +
geom_edge_link(aes(label = type),
angle_calc = 'along',
label_dodge = unit(2.5, 'mm'),
arrow = arrow(length = unit(4, 'mm')),
end_cap = circle(3, 'mm')) +
geom_node_point(size = 5)
The one drawback: ggraph doesn’t allow you to explicitly set the node positions; however, you can manipulate them manually.
I've found a way to plot 3D bar chart (ggplot2 3D Bar Plot). Thank you #jbaums
However, is there a way to change the bottom facet to a map? So I can clearly visualize, for example, the population density using bar chart on a map to show the differences between different parts? Thank you in advance. plotting 3D bars on top of the map
Here's one way
# Plotting 3D maps using OpenStreetMap and RGL. For info see:
# http://geotheory.co.uk/blog/2013/04/26/plotting-3d-maps-with-rgl/
map3d <- function(map, ...){
if(length(map$tiles)!=1){stop("multiple tiles not implemented") }
nx = map$tiles[[1]]$xres
ny = map$tiles[[1]]$yres
xmin = map$tiles[[1]]$bbox$p1[1]
xmax = map$tiles[[1]]$bbox$p2[1]
ymin = map$tiles[[1]]$bbox$p1[2]
ymax = map$tiles[[1]]$bbox$p2[2]
xc = seq(xmin,xmax,len=ny)
yc = seq(ymin,ymax,len=nx)
colours = matrix(map$tiles[[1]]$colorData,ny,nx)
m = matrix(0,ny,nx)
surface3d(xc,yc,m,col=colours, ...)
return(list(xc=xc, yc=yc, colours=colours))
}
require(rgl)
require(OpenStreetMap)
map <- openproj(openmap(c(52.5227,13.2974),c(52.4329,13.5669), zoom = 10))
set.seed(1)
n <- 30
bbox <- unlist(map$bbox, use.names = F)
x <- do.call(runif, c(list(n), as.list(bbox[c(1,3)])))
y <- do.call(runif, c(list(n), as.list(bbox[c(4,2)])))
z <- runif(n, 0, .1)
m <- rbind(cbind(x,y,z=0), cbind(x,y,z))
m <- m[as.vector(mapply(c, 1:n, (n+1):(2*n))),]
open3d(windowRect=c(100,100,800,600))
coords <- map3d(map, lit=F)
segments3d(m, col="red", add=T)
which gives you something like:
And another way, which you can extend to use box3D to maybe make it more look like your example:
library(plot3D)
with(coords, {
image3D(
z = 0, x = xc, y = yc, colvar = colours, zlim = c(0,max(z)),
scale=F, theta = 0, bty="n")
segments3D(x,y,rep(0,length(x)),x,y,z, col="red", add=T)
})
I am trying to create an image showing a scatter plot and a heat map side by side. I create the scatter plot with geom_point and the heatmap with heatmap.2. I then use grid.draw to put them in the same image HOWEVER I cannot get the images to be the same size. How can I make sure they are the same height (this is important as they are ordered the same way and match each other)?
The code I have is:
grab_grob <- function(){
grid.echo()
grid.grab()
}
g1 <- ggplot(x, aes(x=VIPscore, y=reorder(metabolite, VIPscore))) + geom_point(colour="blue") + labs(y="", x="VIP score")
heatmap.2(xhm, cexRow=0.5, cexCol=1, Colv=FALSE, Rowv = FALSE, keep.dendro = FALSE, trace="none", key=FALSE, lwid = c(0.5, 0.5), col=heat.colors(ncol(xhm)))
g2 <- grab_grob()
grid.newpage()
lay <- grid.layout(nrow = 1, ncol=2)
pushViewport(viewport(layout = lay))
print(g1,vp=viewport(layout.pos.row = 1, layout.pos.col = 1))
grid.draw(editGrob(g2, vp=viewport(layout.pos.row = 1, layout.pos.col = 2, clip=TRUE)))
upViewport(1)
I have also tried the geom_tile (instead of heatmap.2) followed by grid.arrange; although the images now match in size colors are awful - they look flat across my data set.
A package called plotly might be of help here. Check out their API docs
library(plotly)
df <- data.frame(x = 1:1000,
y = rnorm(1000))
p1 <- plot_ly(df, x = x, y = y, mode = "markers")
p2 <- plot_ly(z = volcano, type = "heatmap")%>% layout(title = "Scatterplot and Heatmap Subplot")
subplot(p1, p2)
A drop-in solution could be to use the package "ComplexHeatmap".
https://bioconductor.org/packages/release/bioc/vignettes/ComplexHeatmap/inst/doc/s4.heatmap_annotation.html
is there an comfortable way to set the legend/key label inside the rectanlge in latice plots: (although overplot/overlayer lines, points, rectangles in keys would be nice)
library(lattice)
barchart(yield ~ variety | site, data = barley,
groups = year, layout = c(1,6), stack = TRUE,
auto.key = list(space = "right"),
ylab = "Barley Yield (bushels/acre)",
scales = list(x = list(rot = 45)))
Well, there's no really automatic way, but it can be done. Here are a couple of options I came up with. Both construct a legend 'grob' and pass it in via the barchart()'s legend= argument. The first solution uses the nifty gtable package to construct a table grob. The second is a bit more programmatic, and uses grid's own frameGrob() and packGrob() functions to construct a similar legend.
Option 1: Construct legend using gtable()
library(lattice)
library(grid)
library(gtable)
## Extract group labels and their colors for use in gtable
ll <- levels(barley[["year"]])
cc <- trellis.par.get("superpose.polygon")[["col"]][seq_along(ll)]
## Prepare a grob for passing in to legend.
## Set up a two cell gtable , and 'paint' then annotate both cells
## (Note: this could be further "vectorized", as, e.g., at
## http://stackoverflow.com/a/18033613/980833)
gt <- gtable(widths = unit(1.5,"cm"), heights = unit(rep(.7,2), "cm"))
gt <- gtable_add_grob(gt, rectGrob(gp=gpar(fill=cc[1])), 1, 1, name=1)
gt <- gtable_add_grob(gt, textGrob(ll[1]), 1, 1, name=2)
gt <- gtable_add_grob(gt, rectGrob(gp=gpar(fill=cc[2])), 2, 1, name=1)
gt <- gtable_add_grob(gt, textGrob(ll[2]), 2, 1, name=2)
## Plot barchart with legend
barchart(yield ~ variety | site, data = barley,
groups = year, layout = c(1,6), stack = TRUE,
legend = list(right=list(fun=gt)),
ylab = "Barley Yield (bushels/acre)",
scales = list(x = list(rot = 45)))
Option 2: Construct legend by packing a frameGrob()
library(lattice)
library(grid)
## A function for making grobs with text on a colored background
labeledRect <- function(text, color) {
rg <- rectGrob(gp=gpar(fill=color))
tg <- textGrob(text)
gTree(children=gList(rg, tg), cl="boxedTextGrob")
}
## A function for constructing a legend consisting of several
## labeled rectangles
legendGrob <- function(labels, colors) {
gf <- frameGrob()
border <- unit(c(0,0.5,0,0.5), "cm")
for (i in seq_along(labels)) {
gf <- packGrob(gf, labeledRect(labels[i], colors[i]),
width = 1.1*stringWidth(labels[i]),
height = 1.5*stringHeight(labels[i]),
col = 1, row = i, border = border)
}
gf
}
## Use legendGrob() to prepare the legend
ll <- levels(barley[["year"]])
cc <- trellis.par.get("superpose.polygon")[["col"]][seq_along(ll)]
gf <- legendGrob(labels=ll, colors=cc)
## Put it all together
barchart(yield ~ variety | site, data = barley,
groups = year, layout = c(1,6), stack = TRUE,
legend = list(right=list(fun=gf)),
ylab = "Barley Yield (bushels/acre)",
scales = list(x = list(rot = 45)))