Related
This question already has answers here:
Create discrete color bar with varying interval widths and no spacing between legend levels
(5 answers)
Closed last year.
I'd like to break the legend into categories rather than having a continuous range of colours. Could someone kindly help me for the specific example I am using here? Below is my current trial with colour breaks at 40, 60 and 80. Thank you very much!
library(raster)
library(ggplot2)
library(maptools)
data("wrld_simpl")
#sample raster
r <- raster(ncol=10, nrow=20)
r[] <- 1:ncell(r)
extent(r) <- extent(c(-180, 180, -70, 70))
#plotting
var_df <- as.data.frame(rasterToPoints(r))
p <- ggplot() +
geom_polygon(data = wrld_simpl[wrld_simpl#data$UN!="10",],
aes(x = long, y = lat, group = group),
colour = "black", fill = "grey")
p <- p + geom_raster(data = var_df, aes(x = x, y = y, fill = layer))
p <- p + coord_equal() + theme_bw() +labs(x="", y="")
p <- p + theme(legend.key=element_blank(),
axis.text.y =element_text(size=16),
axis.text.x =element_text(size=16),
legend.text =element_text(size=12),
legend.title=element_text(size=12))
# p <- p + scale_fill_gradientn(colours = rev(terrain.colors(10)))
p <- p + scale_colour_manual(values = c("red", "blue", "green","yellow"),
breaks = c("40", "60", "80", max(var_df$layer)),
labels = c("1-40", "40-60", "60-80", "80+"))
p <- p + geom_polygon(data = wrld_simpl[wrld_simpl#data$UN!="10",],
aes(x = long, y = lat, group = group),
colour = "black", fill = NA)
p
Current continuous legend:
Example of legend with breaks:
Here you go. I took the plot_discrete_cbar() function written by #AF7 from here
library(raster)
library(ggplot2)
library(maptools)
# Plot discrete colorbar function
plot_discrete_cbar = function (
# Vector of breaks. If +-Inf are used, triangles will be added to the sides of the color bar
breaks,
palette = "Greys", # RColorBrewer palette to use
# Alternatively, manually set colors
colors = RColorBrewer::brewer.pal(length(breaks) - 1, palette),
direction = 1, # Flip colors? Can be 1 or -1
spacing = "natural", # Spacing between labels. Can be "natural" or "constant"
border_color = NA, # NA = no border color
legend_title = NULL,
legend_direction = "horizontal", # Can be "horizontal" or "vertical"
font_size = NULL,
expand_size = 1, # Controls spacing around legend plot
spacing_scaling = 1, # Multiplicative factor for label and legend title spacing
width = 0.1, # Thickness of color bar
triangle_size = 0.1 # Relative width of +-Inf triangles
) {
require(ggplot2)
if (!(spacing %in% c("natural", "constant"))) stop("Spacing must be either 'natural' or 'constant'")
if (!(direction %in% c(1, -1))) stop("Direction must be either 1 or -1")
if (!(legend_direction %in% c("horizontal", "vertical"))) {
stop("Legend_direction must be either 'horizontal' or 'vertical'")
}
breaks = as.numeric(breaks)
new_breaks = sort(unique(breaks))
if (any(new_breaks != breaks)) warning("Wrong order or duplicated breaks")
breaks = new_breaks
if (class(colors) == "function") colors = colors(length(breaks) - 1)
if (length(colors) != length(breaks) - 1) {
stop("Number of colors (", length(colors), ") must be equal to number of breaks (",
length(breaks), ") minus 1")
}
if (!missing(colors)) {
warning("Ignoring RColorBrewer palette '", palette, "', since colors were passed manually")
}
if (direction == -1) colors = rev(colors)
inf_breaks = which(is.infinite(breaks))
if (length(inf_breaks) != 0) breaks = breaks[-inf_breaks]
plotcolors = colors
n_breaks = length(breaks)
labels = breaks
if (spacing == "constant") {
breaks = 1:n_breaks
}
r_breaks = range(breaks)
if(is.null(font_size)) {
print("Legend key font_size not set. Use default value = 5")
font_size <- 5
} else {
print(paste0("font_size = ", font_size))
font_size <- font_size
}
cbar_df = data.frame(stringsAsFactors = FALSE,
y = breaks,
yend = c(breaks[-1], NA),
color = as.character(1:n_breaks)
)[-n_breaks,]
xmin = 1 - width/2
xmax = 1 + width/2
cbar_plot = ggplot(cbar_df, aes(xmin = xmin, xmax = xmax,
ymin = y, ymax = yend, fill = color)) +
geom_rect(show.legend = FALSE,
color = border_color)
if (any(inf_breaks == 1)) { # Add < arrow for -Inf
firstv = breaks[1]
polystart = data.frame(
x = c(xmin, xmax, 1),
y = c(rep(firstv, 2), firstv - diff(r_breaks) * triangle_size)
)
plotcolors = plotcolors[-1]
cbar_plot = cbar_plot +
geom_polygon(data = polystart, aes(x = x, y = y),
show.legend = FALSE,
inherit.aes = FALSE,
fill = colors[1],
color = border_color)
}
if (any(inf_breaks > 1)) { # Add > arrow for +Inf
lastv = breaks[n_breaks]
polyend = data.frame(
x = c(xmin, xmax, 1),
y = c(rep(lastv, 2), lastv + diff(r_breaks) * triangle_size)
)
plotcolors = plotcolors[-length(plotcolors)]
cbar_plot = cbar_plot +
geom_polygon(data = polyend, aes(x = x, y = y),
show.legend = FALSE,
inherit.aes = FALSE,
fill = colors[length(colors)],
color = border_color)
}
if (legend_direction == "horizontal") { # horizontal legend
mul = 1
x = xmin
xend = xmax
cbar_plot = cbar_plot + coord_flip()
angle = 0
legend_position = xmax + 0.1 * spacing_scaling
} else { # vertical legend
mul = -1
x = xmax
xend = xmin
angle = -90
legend_position = xmax + 0.2 * spacing_scaling
}
cbar_plot = cbar_plot +
geom_segment(data = data.frame(y = breaks, yend = breaks),
aes(y = y, yend = yend),
x = x - 0.05 * mul * spacing_scaling, xend = xend,
inherit.aes = FALSE) +
annotate(geom = 'text', x = x - 0.1 * mul * spacing_scaling, y = breaks,
label = labels,
size = font_size) +
scale_x_continuous(expand = c(expand_size, expand_size)) +
scale_fill_manual(values = plotcolors) +
theme_void()
if (!is.null(legend_title)) { # Add legend title
cbar_plot = cbar_plot +
annotate(geom = 'text', x = legend_position, y = mean(r_breaks),
label = legend_title,
angle = angle,
size = font_size)
}
return(cbar_plot)
}
Cut data into bins for the discrete colorbar
myvalues <- c(seq(0, 200, 40), Inf)
var_df$cuts <- cut(var_df$layer, myvalues, include.lowest = TRUE)
levels(var_df$cuts)
#> [1] "[0,40]" "(40,80]" "(80,120]" "(120,160]" "(160,200]" "(200,Inf]"
Plot the raster
p <- ggplot() +
geom_polygon(data = wrld_simpl[wrld_simpl#data$UN != "10", ],
aes(x = long, y = lat, group = group),
colour = "black", fill = "grey")
p <- p + geom_raster(data = var_df, aes(x = x, y = y, fill = cuts)) # matching cuts & fill
p <- p + coord_equal() + theme_minimal() + labs(x="", y="")
p <- p + theme(legend.key =element_blank(),
axis.text.y =element_text(size=16),
axis.text.x =element_text(size=16),
legend.text =element_text(size=12),
legend.title=element_text(size=12))
p <- p + scale_fill_brewer("Layer", palette = "YlGnBu", drop = FALSE)
p <- p + geom_polygon(data = wrld_simpl[wrld_simpl#data$UN != "10", ],
aes(x = long, y = lat, group = group),
colour = "black", fill = NA)
p <- p + theme(legend.position = "none")
Plot the discrete colorbar
dbar <- plot_discrete_cbar(myvalues,
palette = "YlGnBu",
legend_title = NULL,
spacing = "natural")
# reduce top and bottom margins
p1 <- p + theme(plot.margin = unit(c(10, 10, -35, 10), "pt"))
dbar <- dbar + theme(plot.margin = unit(c(-35, 10, -30, 10), "pt"))
Combine two plots together
# devtools::install_github('baptiste/egg')
library(egg)
ggarrange(p1, dbar, nrow = 2, ncol = 1, heights = c(1, 0.4))
Created on 2018-10-18 by the reprex package (v0.2.1.9000)
I'm writing a package that extends ggplot2. One of those extensions is a geom_arrow() that takes aesthetics mag and angle to plot vector fields by magnitude and direction. I also created a scale_mag() to manipulate the length of the arrows with the prospect of creating also a new guide. Right now both geom and scale work as expected when added together.
ggplot(geo, aes(lon, lat)) +
geom_arrow(aes(mag = mag, angle = angle)) +
scale_mag()
But if I don't add scale_mag(), it doesn't work at all. What I want is for this scale to work like scale_color(), which is added by default when the color aesthetic is present.
Here is the code as it is right now:
geom_arrow <- function(mapping = NULL, data = NULL,
stat = "arrow",
position = "identity", ...,
start = 0,
direction = 1,
# scale = 1,
min.mag = 0,
skip = 0,
skip.x = skip,
skip.y = skip,
arrow.angle = 15,
arrow.length = 0.5,
arrow.ends = "last",
arrow.type = "closed",
arrow = grid::arrow(arrow.angle, unit(arrow.length, "lines"),
ends = arrow.ends, type = arrow.type),
lineend = "butt",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
layer(geom = GeomArrow,
mapping = mapping,
data = data,
stat = stat,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
start = start,
direction = direction,
arrow = arrow,
lineend = lineend,
na.rm = na.rm,
# scale = scale,
skip.x = skip.x,
skip.y = skip.y,
min.mag = min.mag,
...)
)
}
GeomArrow <- ggplot2::ggproto("GeomArrow", Geom,
required_aes = c("x", "y"),
default_aes = ggplot2::aes(color = "black", size = 0.5, min.mag = 0,
linetype = 1, alpha = NA),
draw_key = ggplot2::draw_key_path,
draw_panel = function(data, panel_scales, coord,
arrow = arrow, lineend = lineend,
start = start, direction = direction,
preserve.dir = TRUE) {
coords <- coord$transform(data, panel_scales)
unit.delta <- "snpc"
if (preserve.dir == FALSE) {
coords$angle <- with(coords, atan2(yend - y, xend - x)*180/pi)
unit.delta <- "npc"
}
coords$dx <- with(coords, mag*cos(angle*pi/180))
coords$dy <- with(coords, mag*sin(angle*pi/180))
# from https://stackoverflow.com/questions/47814998/how-to-make-segments-that-preserve-angles-in-different-aspect-ratios-in-ggplot2
xx <- grid::unit.c(grid::unit(coords$x, "npc"),
grid::unit(coords$x, "npc") + grid::unit(coords$dx, unit.delta))
yy <- grid::unit.c(grid::unit(coords$y, "npc"),
grid::unit(coords$y, "npc") + grid::unit(coords$dy, unit.delta))
mag <- with(coords, mag/max(mag, na.rm = T))
arrow$length <- unit(as.numeric(arrow$length)*mag, attr(arrow$length, "unit"))
pol <- grid::polylineGrob(x = xx, y = yy,
default.units = "npc",
arrow = arrow,
gp = grid::gpar(col = coords$colour,
fill = scales::alpha(coords$colour, coords$alpha),
alpha = ifelse(is.na(coords$alpha), 1, coords$alpha),
lwd = coords$size*.pt,
lty = coords$linetype,
lineend = lineend),
id = rep(seq(nrow(coords)), 2))
pol
})
StatArrow <- ggplot2::ggproto("StatArrow", ggplot2::Stat,
required_aes = c("x", "y"),
default_aes = ggplot2::aes(min.mag = 0, dx = NULL, dy = NULL,
mag = NULL, angle = NULL),
compute_group = function(data, scales,
skip.x = skip.x, skip.y = skip.y,
min.mag = min.mag) {
min.mag <- data$min.mag %||% min.mag
if (is.null(data$mag) | is.null(data$angle)) {
if (is.null(data$dx) | is.null(data$dy)) stop("stat_arrow need dx, dy or mag angle (improve mesage!!)")
data$mag <- with(data, Mag(dx, dy))
data$angle <- with(data, atan2(dy, dx)*180/pi)
} else {
data$dx <- with(data, mag*cos(angle*pi/180))
data$dy <- with(data, mag*sin(angle*pi/180))
}
data <- subset(data, x %in% JumpBy(unique(x), skip.x + 1) &
y %in% JumpBy(unique(y), skip.y + 1) &
mag >= min.mag)
data$xend = with(data, x + dx)
data$yend = with(data, y + dy)
data
}
)
scale_mag <- function(length = 0.1,
max = waiver(),
default_unit = "lines") {
# if (!is.unit(length)) length <- ggplot2::unit(length, default_unit)
continuous_scale("mag",
"mag",
identity,
rescaler = rescale_mag(length, max),
guide = "none")
}
# scale_type.mag <- function(x) "vector"
rescale_mag <- function(length, max) {
function(x, from) {
if (is.waive(max)) max <- max(x, na.rm = T)
scales::rescale(x, c(0, length), c(0, max))
}
}
Finally, I find the answer!
Based on the code in ggplot2/R/scale-type.R, there should be a scale named scale_mag_continuous in the parent environment of find_scale function. Then, this scale can be find automatically.
geo <- tibble(lon = 1:10, lat = 1:10, mag = 1:10, angle = 1:10)
scale_mag_continuous <- scale_mag
ggplot(geo, aes(lon, lat)) +
geom_arrow(aes(mag = mag, angle = angle))
I added a default theme to ggplot for a work package by overloading the ggplot function, basically like this:
ggplot <- function(...) {ggplot2::ggplot(...) + your_added_thing()}
If you want it to be less obtrusive, rename your version of ggplot:
jjplot <- function (...) {ggplot2::ggplot(...) + my_added_thing()}
this page will be helpful for you.
https://gist.github.com/wch/3250485
especially, the code below:
#This tells ggplot2 what scale to look for, for yearmon
scale_type.yearmon <- function(x) "yearmon"
I have a question that expands on this one. Basically I want to add bty = "n" to a ggplot2 graph in a proper way. Emphasis on proper here because the solution in the other question almost what I want, except for this detail: I would like it if the axis line would continue until the end of the tick, not until the middle of it. First, code for the graph:
library(ggplot2)
library(grid)
graph = ggplot(faithful, aes(x=eruptions, y=waiting)) +
geom_point(shape=21) +
theme(
# tick width, a bit exaggerated as example
axis.ticks = element_line(size = 5, color = "gray")
)
graph # graph with no axis lines
# get axis limits
gb = ggplot_build(graph)
xLim = range(gb$layout$panel_ranges[[1]]$x.major_source)
yLim = range(gb$layout$panel_ranges[[1]]$y.major_source)
# add lines
graph +
geom_segment(y = -Inf, yend = -Inf, x = xLim[1], xend = xLim[2]) +
geom_segment(x = -Inf, xend = -Inf, y = yLim[1], yend = yLim[2])
So the problem is: I draw on the x-axis from 50 till 90. But, the tickmarks are centered on 50 and 90, therefore they extend by half of size = 5 on each side. ?element_line tells me that line/ border size is by default in mm. Thus I want to draw the line from 50 - 5mm / 2 until 90 + 5mm / 2. I tried (many variations of) the following:
xLim = range(gb$layout$panel_ranges[[1]]$x.major_source)
yLim = range(gb$layout$panel_ranges[[1]]$y.major_source)
uType = "npc"
uType2 = "mm"
# attempt conversion of units
xLim[1] = xLim[1] - convertWidth(unit(2.5, units = uType2),
unitTo = uType, valueOnly = TRUE)
xLim[2] = xLim[2] + convertWidth(unit(2.5, units = uType2),
unitTo = uType, valueOnly = TRUE)
yLim[1] = yLim[1] - convertHeight(unit(2.5, units = uType2),
unitTo = uType, valueOnly = TRUE)
yLim[2] = yLim[2] - convertHeight(unit(2.5, units = uType2),
unitTo = uType, valueOnly = TRUE)
# redraw graph
cairo_pdf("Rplot.pdf")
graph +
geom_segment(y = -Inf, yend = -Inf, x = xLim[1], xend = xLim[2]) +
geom_segment(x = -Inf, xend = -Inf, y = yLim[1], yend = yLim[2])
dev.off()
But no luck whatsoever. Any ideas?
I believe you'd have to write a drawDetails method or similar to do the unit calculation at drawing time for this to work.
Alternatively (and perhaps easier), you could write a custom tick grob that extends to cover the axis line.
(Note that the two axes have different line widths because of their z-order IIRC; I thought that bug had been fixed).
library(ggplot2)
library(grid)
element_grob.element_custom_x <- function (element, x = 0:1, y = 0:1, colour = NULL, size = NULL,
linetype = NULL, lineend = "butt", default.units = "npc", id.lengths = NULL,
...)
{
gp <- gpar(lwd = ggplot2:::len0_null(size * .pt), col = colour, lty = linetype,
lineend = lineend)
element_gp <- gpar(lwd = ggplot2:::len0_null(element$size * .pt), col = element$colour,
lty = element$linetype, lineend = element$lineend)
arrow <- if (is.logical(element$arrow) && !element$arrow) {
NULL
}
else {
element$arrow
}
g1 <- polylineGrob(x, y, default.units = default.units,
gp = utils::modifyList(element_gp, gp),
id.lengths = id.lengths, arrow = arrow, ...)
vertical <- length(unique(element$x)) == 1 && length(unique(element$y)) >= 1
g2 <- grid::editGrob(g1, y=y + unit(1,"mm"), gp=utils::modifyList(gp, list(col="green")), name="new")
grid::grobTree(g2, g1)
}
element_grob.element_custom_y <- function (element, x = 0:1, y = 0:1, colour = NULL, size = NULL,
linetype = NULL, lineend = "butt", default.units = "npc", id.lengths = NULL,
...)
{
gp <- gpar(lwd = ggplot2:::len0_null(size * .pt), col = colour, lty = linetype,
lineend = lineend)
element_gp <- gpar(lwd = ggplot2:::len0_null(element$size * .pt), col = element$colour,
lty = element$linetype, lineend = element$lineend)
arrow <- if (is.logical(element$arrow) && !element$arrow) {
NULL
}
else {
element$arrow
}
g1 <- polylineGrob(x, y, default.units = default.units,
gp = utils::modifyList(element_gp, gp),
id.lengths = id.lengths, arrow = arrow, ...)
g2 <- grid::editGrob(g1, x=x + unit(1,"mm"), gp=utils::modifyList(gp, list(col="green")), name="new")
grid::grobTree(g2, g1)
}
## silly wrapper to fool ggplot2
x_custom <- function(...){
structure(
list(...), # this ... information is not used, btw
class = c("element_custom_x","element_blank", "element") # inheritance test workaround
)
}
y_custom <- function(...){
structure(
list(...), # this ... information is not used, btw
class = c("element_custom_y","element_blank", "element") # inheritance test workaround
)
}
graph = ggplot(faithful, aes(x=eruptions, y=waiting)) +
geom_point(shape=21) + theme_minimal() +
theme(
axis.ticks.x = x_custom(size = 5, colour = "red") ,
axis.ticks.y = y_custom(size = 5, colour = "red") ,
axis.ticks.length = unit(2,"mm")
)
graph # graph with no axis lines
gb <- ggplot_build(graph)
xLim = range(gb$layout$panel_ranges[[1]]$x.major_source)
yLim = range(gb$layout$panel_ranges[[1]]$y.major_source)
graph +
geom_segment(y = -Inf, yend = -Inf, x = xLim[1], xend = xLim[2],lwd=2) +
geom_segment(x = -Inf, xend = -Inf, y = yLim[1], yend = yLim[2],lwd=2)
Much simpler nowadays: use the geom_rangeframe() from the package ggthemes(). I think it does exactly what you want.
Not that it's critical to my question, but here is my plot example, on top of which I'd like to add a scale bar.
ggmap(get_map(location = "Kinston, NC", zoom = 12, maptype = 'hybrid')) +
geom_point(x = -77.61198, y = 35.227792, colour = "red", size = 5) +
geom_point(x = -77.57306, y = 35.30288, colour = "blue", size = 3) +
geom_point(x = -77.543, y = 35.196, colour = "blue", size = 3) +
geom_text(x = -77.575, y = 35.297, label = "CRONOS Data") +
geom_text(x = -77.54, y = 35.19, label = "NOAA") +
geom_text(x = -77.61, y = 35.22, label = "PP Site")
There are a few things you need to do to make this happen.
First is to put your data into a data.frame():
sites.data = data.frame(lon = c(-77.61198, -77.57306, -77.543),
lat = c(35.227792, 35.30288, 35.196),
label = c("PP Site","NOAA", "CRONOS Data"),
colour = c("red","blue","blue"))
Now we can get the map for this region using the gg_map package:
require(gg_map)
map.base <- get_map(location = c(lon = mean(sites.data$lon),
lat = mean(sites.data$lat)),
zoom = 10) # could also use zoom = "auto"
We'll need the extents of that image:
bb <- attr(map.base,"bb")
Now we start figuring out the scale. First, we need a function give us the distance between two points, based on lat/long. For that, we use the Haversine formula, described by Floris at Calculate distance in (x, y) between two GPS-Points:
distHaversine <- function(long, lat){
long <- long*pi/180
lat <- lat*pi/180
dlong = (long[2] - long[1])
dlat = (lat[2] - lat[1])
# Haversine formula:
R = 6371;
a = sin(dlat/2)*sin(dlat/2) + cos(lat[1])*cos(lat[2])*sin(dlong/2)*sin(dlong/2)
c = 2 * atan2( sqrt(a), sqrt(1-a) )
d = R * c
return(d) # in km
}
The next step is to work out the points that will define our scale bar. For this example, I put something in the lower left of the plot, using the bounding box that we've already figured out:
sbar <- data.frame(lon.start = c(bb$ll.lon + 0.1*(bb$ur.lon - bb$ll.lon)),
lon.end = c(bb$ll.lon + 0.25*(bb$ur.lon - bb$ll.lon)),
lat.start = c(bb$ll.lat + 0.1*(bb$ur.lat - bb$ll.lat)),
lat.end = c(bb$ll.lat + 0.1*(bb$ur.lat - bb$ll.lat)))
sbar$distance = distHaversine(long = c(sbar$lon.start,sbar$lon.end),
lat = c(sbar$lat.start,sbar$lat.end))
Finally, we can draw the map with the scale.
ptspermm <- 2.83464567 # need this because geom_text uses mm, and themes use pts. Urgh.
map.scale <- ggmap(map.base,
extent = "normal",
maprange = FALSE) %+% sites.data +
geom_point(aes(x = lon,
y = lat,
colour = colour)) +
geom_text(aes(x = lon,
y = lat,
label = label),
hjust = 0,
vjust = 0.5,
size = 8/ptspermm) +
geom_segment(data = sbar,
aes(x = lon.start,
xend = lon.end,
y = lat.start,
yend = lat.end)) +
geom_text(data = sbar,
aes(x = (lon.start + lon.end)/2,
y = lat.start + 0.025*(bb$ur.lat - bb$ll.lat),
label = paste(format(distance,
digits = 4,
nsmall = 2),
'km')),
hjust = 0.5,
vjust = 0,
size = 8/ptspermm) +
coord_map(projection="mercator",
xlim=c(bb$ll.lon, bb$ur.lon),
ylim=c(bb$ll.lat, bb$ur.lat))
Then we save it...
# Fix presentation ----
map.out <- map.scale +
theme_bw(base_size = 8) +
theme(legend.justification=c(1,1),
legend.position = c(1,1))
ggsave(filename ="map.png",
plot = map.out,
dpi = 300,
width = 4,
height = 3,
units = c("in"))
Which gives you something like this:
The nice thing is that all of the plotting uses ggplot2(), so you can use the documentation at http://ggplot2.org to make this look how you need.
I've reworked #Andy Clifton's code to add a more precise measure of the distance, and to allow for the scale bar to be of a desired length, as opposed to depending on the positioning of the bar.
Andy's code got me 99 percent of the way, but the Haversine formula used in his code is not validated with results from other sources, although I can't find the error myself.
This first part is copied from Andy Clifton's answer above just for completeness of the code:
sites.data = data.frame(lon = c(-77.61198, -77.57306, -77.543),
lat = c(35.227792, 35.30288, 35.196),
label = c("PP Site","NOAA", "CRONOS Data"),
colour = c("red","blue","blue"))
map.base <- get_map(location = c(lon = mean(sites.data$lon),
lat = mean(sites.data$lat)),
zoom = 10)
bb <- attr(map.base,"bb")
sbar <- data.frame(lon.start = c(bb$ll.lon + 0.1*(bb$ur.lon - bb$ll.lon)),
lon.end = c(bb$ll.lon + 0.25*(bb$ur.lon - bb$ll.lon)),
lat.start = c(bb$ll.lat + 0.1*(bb$ur.lat - bb$ll.lat)),
lat.end = c(bb$ll.lat + 0.1*(bb$ur.lat - bb$ll.lat)))
The next two steps are different:
First use the distVincentyEllipsoid function from the geosphere package to calculate the distance even more preciseley than the Haversine formula:
sbar$distance <- geosphere::distVincentyEllipsoid(c(sbar$lon.start,sbar$lat.start),
c(sbar$lon.end,sbar$lat.end))
Then correct the scale bar so that is a standard length - depending on the scale of your map. In this example 20km seems like a nice reasonable choice, i.e. 20,000 meters:
scalebar.length <- 20
sbar$lon.end <- sbar$lon.start +
((sbar$lon.end-sbar$lon.start)/sbar$distance)*scalebar.length*1000
Again using Andy's code, I've only added the arrows to the geom_segment because I think it looks nicer
ptspermm <- 2.83464567 # need this because geom_text uses mm, and themes use pts. Urgh.
map.scale <- ggmap(map.base,
extent = "normal",
maprange = FALSE) %+% sites.data +
geom_point(aes(x = lon,
y = lat,
colour = colour)) +
geom_text(aes(x = lon,
y = lat,
label = label),
hjust = 0,
vjust = 0.5,
size = 8/ptspermm) +
geom_segment(data = sbar,
aes(x = lon.start,
xend = lon.end,
y = lat.start,
yend = lat.end),
arrow=arrow(angle = 90, length = unit(0.1, "cm"),
ends = "both", type = "open")) +
geom_text(data = sbar,
aes(x = (lon.start + lon.end)/2,
y = lat.start + 0.025*(bb$ur.lat - bb$ll.lat),
label = paste(format(scalebar.length),
'km')),
hjust = 0.5,
vjust = 0,
size = 8/ptspermm) +
coord_map(projection = "mercator",
xlim=c(bb$ll.lon, bb$ur.lon),
ylim=c(bb$ll.lat, bb$ur.lat))
# Fix presentation ----
map.out <- map.scale +
theme_bw(base_size = 8) +
theme(legend.justification = c(1,1),
legend.position = c(1,1))
ggsave(filename ="map.png",
plot = map.out,
dpi = 300,
width = 4,
height = 3,
units = c("in"))
I am developing a graphic with ggplot2 wherein I need to superimpose text over other graphical elements. Depending on the color of the elements underlying the text, it can be difficult to read the text. Is there a way to draw geom_text in a bounding box with a semi-transparent background?
I can do this with plotrix:
library(plotrix)
Labels <- c("Alabama", "Alaska", "Arizona", "Arkansas")
SampleFrame <- data.frame(X = 1:10, Y = 1:10)
TextFrame <- data.frame(X = 4:7, Y = 4:7, LAB = Labels)
### plotrix ###
plot(SampleFrame, pch = 20, cex = 20)
boxed.labels(TextFrame$X, TextFrame$Y, TextFrame$LAB,
bg = "#ffffff99", border = FALSE,
xpad = 3/2, ypad = 3/2)
But I do not know of a way to achieve similar results with ggplot2:
### ggplot2 ###
library(ggplot2)
Plot <- ggplot(data = SampleFrame,
aes(x = X, y = Y)) + geom_point(size = 20)
Plot <- Plot + geom_text(data = TextFrame,
aes(x = X, y = Y, label = LAB))
print(Plot)
As you can see, the black text labels are impossible to perceive where they overlap the black geom_points in the background.
Try this geom, which is slightly modified from GeomText.
GeomText2 <- proto(GeomText, {
objname <- "text2"
draw <- function(., data, scales, coordinates, ..., parse = FALSE,
expand = 1.2, bgcol = "grey50", bgfill = NA, bgalpha = 1) {
lab <- data$label
if (parse) {
lab <- parse(text = lab)
}
with(coordinates$transform(data, scales), {
tg <- do.call("mapply",
c(function(...) {
tg <- with(list(...), textGrob(lab, default.units="native", rot=angle, gp=gpar(fontsize=size * .pt)))
list(w = grobWidth(tg), h = grobHeight(tg))
}, data))
gList(rectGrob(x, y,
width = do.call(unit.c, tg["w",]) * expand,
height = do.call(unit.c, tg["h",]) * expand,
gp = gpar(col = alpha(bgcol, bgalpha), fill = alpha(bgfill, bgalpha))),
.super$draw(., data, scales, coordinates, ..., parse))
})
}
})
geom_text2 <- GeomText2$build_accessor()
Labels <- c("Alabama", "Alaska", "Arizona", "Arkansas")
SampleFrame <- data.frame(X = 1:10, Y = 1:10)
TextFrame <- data.frame(X = 4:7, Y = 4:7, LAB = Labels)
Plot <- ggplot(data = SampleFrame, aes(x = X, y = Y)) + geom_point(size = 20)
Plot <- Plot + geom_text2(data = TextFrame, aes(x = X, y = Y, label = LAB),
size = 5, expand = 1.5, bgcol = "green", bgfill = "skyblue", bgalpha = 0.8)
print(Plot)
BUG FIXED AND CODE IMPROVED
GeomText2 <- proto(GeomText, {
objname <- "text2"
draw <- function(., data, scales, coordinates, ..., parse = FALSE,
expand = 1.2, bgcol = "grey50", bgfill = NA, bgalpha = 1) {
lab <- data$label
if (parse) {
lab <- parse(text = lab)
}
with(coordinates$transform(data, scales), {
sizes <- llply(1:nrow(data),
function(i) with(data[i, ], {
grobs <- textGrob(lab[i], default.units="native", rot=angle, gp=gpar(fontsize=size * .pt))
list(w = grobWidth(grobs), h = grobHeight(grobs))
}))
gList(rectGrob(x, y,
width = do.call(unit.c, lapply(sizes, "[[", "w")) * expand,
height = do.call(unit.c, lapply(sizes, "[[", "h")) * expand,
gp = gpar(col = alpha(bgcol, bgalpha), fill = alpha(bgfill, bgalpha))),
.super$draw(., data, scales, coordinates, ..., parse))
})
}
})
geom_text2 <- GeomText2$build_accessor()
In the development version of ggplot2 package there is a new geom called geom_label() that implements this directly. Transperency can be atchieved with alpha= parameter.
ggplot(data = SampleFrame,
aes(x = X, y = Y)) + geom_point(size = 20)+
geom_label(data = TextFrame,
aes(x = X, y = Y, label = LAB),alpha=0.5)
Instead of adding a bounding box, I would suggest changing the text color to white which can be done by doing
Plot <- Plot +
geom_text(data = TextFrame, aes(x = X, y = Y, label = LAB), colour = 'white')
The other approach would be to add an alpha to geom_point to make it more transparent
Plot <- Plot + geom_point(size = 20, alpha = 0.5)
EDIT. Here is a way to generalize Chase's solution to automatically compute the bounding box. The trick is to add the width and height of text directly to the text data frame.
Here is an example
Labels <- c("Alabama", "Alaska", "Arizona", "Arkansas",
"Pennsylvania + California")
TextFrame <- data.frame(X = 4:8, Y = 4:8, LAB = Labels)
TextFrame <- transform(TextFrame,
w = strwidth(LAB, 'inches') + 0.25,
h = strheight(LAB, 'inches') + 0.25
)
ggplot(data = SampleFrame,aes(x = X, y = Y)) +
geom_point(size = 20) +
geom_rect(data = TextFrame, aes(xmin = X - w/2, xmax = X + w/2,
ymin = Y - h/2, ymax = Y + h/2), fill = "grey80") +
geom_text(data = TextFrame,aes(x = X, y = Y, label = LAB), size = 4)
Update for ggplot2 v0.9
library(ggplot2)
library(proto)
btextGrob <- function (label,x = unit(0.5, "npc"), y = unit(0.5, "npc"),
just = "centre", hjust = NULL, vjust = NULL, rot = 0, check.overlap = FALSE,
default.units = "npc", name = NULL, gp = gpar(), vp = NULL, f=1.5) {
if (!is.unit(x))
x <- unit(x, default.units)
if (!is.unit(y))
y <- unit(y, default.units)
grob(label = label, x = x, y = y, just = just, hjust = hjust,
vjust = vjust, rot = rot, check.overlap = check.overlap,
name = name, gp = gp, vp = vp, cl = "text")
tg <- textGrob(label = label, x = x, y = y, just = just, hjust = hjust,
vjust = vjust, rot = rot, check.overlap = check.overlap)
w <- unit(rep(1, length(label)), "strwidth", as.list(label))
h <- unit(rep(1, length(label)), "strheight", as.list(label))
rg <- rectGrob(x=x, y=y, width=f*w, height=f*h,
gp=gpar(fill="white", alpha=0.3, col=NA))
gTree(children=gList(rg, tg), vp=vp, gp=gp, name=name)
}
GeomText2 <- proto(ggplot2:::GeomText, {
objname <- "text2"
draw <- function(., data, scales, coordinates, ..., parse = FALSE, na.rm = FALSE) {
data <- remove_missing(data, na.rm,
c("x", "y", "label"), name = "geom_text2")
lab <- data$label
if (parse) {
lab <- parse(text = lab)
}
with(coord_transform(coordinates, data, scales),
btextGrob(lab, x, y, default.units="native",
hjust=hjust, vjust=vjust, rot=angle,
gp = gpar(col = alpha(colour, alpha), fontsize = size * .pt,
fontfamily = family, fontface = fontface, lineheight = lineheight))
)
}
})
geom_text2 <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity",
parse = FALSE, ...) {
GeomText2$new(mapping = mapping, data = data, stat = stat,position = position,
parse = parse, ...)
}
qplot(wt, mpg, data = mtcars, label = rownames(mtcars), size = wt) +
geom_text2(colour = "red")
One option is to add another layer that corresponds to the text layer. Since ggplot adds layers sequentially, place a geom_rect under the call to geom_text and it will create the illusion you're after. This is admittedly a bit of a manual process trying to figure out the appropriate size for the box, but it's the best I can come up with for now.
library(ggplot2)
ggplot(data = SampleFrame,aes(x = X, y = Y)) +
geom_point(size = 20) +
geom_rect(data = TextFrame, aes(xmin = X -.4, xmax = X + .4, ymin = Y - .4, ymax = Y + .4), fill = "grey80") +
geom_text(data = TextFrame,aes(x = X, y = Y, label = LAB), size = 4)
following baptiste v0.9 answer, here's an update with rudimentary control of the box appearance (bgfill, bgalpha, bgcol, expand_w, expand_h):
btextGrob <- function (label,x = unit(0.5, "npc"), y = unit(0.5, "npc"),
just = "centre", hjust = NULL, vjust = NULL, rot = 0, check.overlap = FALSE,
default.units = "npc", name = NULL, gp = gpar(), vp = NULL, expand_w, expand_h, box_gp = gpar()) {
if (!is.unit(x))
x <- unit(x, default.units)
if (!is.unit(y))
y <- unit(y, default.units)
grob(label = label, x = x, y = y, just = just, hjust = hjust,
vjust = vjust, rot = rot, check.overlap = check.overlap,
name = name, gp = gp, vp = vp, cl = "text")
tg <- textGrob(label = label, x = x, y = y, just = just, hjust = hjust,
vjust = vjust, rot = rot, check.overlap = check.overlap)
w <- unit(rep(1, length(label)), "strwidth", as.list(label))
h <- unit(rep(1, length(label)), "strheight", as.list(label))
rg <- rectGrob(x=x, y=y, width=expand_w*w, height=expand_h*h,
gp=box_gp)
gTree(children=gList(rg, tg), vp=vp, gp=gp, name=name)
}
GeomTextbox <- proto(ggplot2:::GeomText, {
objname <- "textbox"
draw <- function(., data, scales, coordinates, ..., parse = FALSE, na.rm = FALSE,
expand_w = 1.2, expand_h = 2, bgcol = "grey50", bgfill = "white", bgalpha = 1) {
data <- remove_missing(data, na.rm,
c("x", "y", "label"), name = "geom_textbox")
lab <- data$label
if (parse) {
lab <- parse(text = lab)
}
with(coord_transform(coordinates, data, scales),
btextGrob(lab, x, y, default.units="native",
hjust=hjust, vjust=vjust, rot=angle,
gp = gpar(col = alpha(colour, alpha), fontsize = size * .pt,
fontfamily = family, fontface = fontface, lineheight = lineheight),
box_gp = gpar(fill = bgfill, alpha = bgalpha, col = bgcol),
expand_w = expand_w, expand_h = expand_h)
)
}
})
geom_textbox <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity",
parse = FALSE, ...) {
GeomTextbox$new(mapping = mapping, data = data, stat = stat,position = position,
parse = parse, ...)
}
qplot(wt, mpg, data = mtcars, label = rownames(mtcars), size = wt) +
theme_bw() +
geom_textbox()
Update for ggplot2 1.0.1
GeomText2 <- proto(ggplot2:::GeomText, {
objname <- "text2"
draw <- function(., data, scales, coordinates, ..., parse = FALSE, na.rm = FALSE
,hjust = 0.5, vjust = 0.5
,expand = c(1.1,1.2), bgcol = "black", bgfill = "white", bgalpha = 1) {
data <- remove_missing(data, na.rm, c("x", "y", "label"), name = "geom_text")
lab <- data$label
if (parse) {
lab <- parse(text = lab)
}
with(coord_transform(coordinates, data, scales),{
sizes <- llply(1:nrow(data),
function(i) with(data[i, ], {
grobs <- textGrob(lab[i], default.units="native", rot=angle, gp=gpar(fontsize=size * .pt))
list(w = grobWidth(grobs), h = grobHeight(grobs))
})
)
w <- do.call(unit.c, lapply(sizes, "[[", "w"))
h <- do.call(unit.c, lapply(sizes, "[[", "h"))
gList(rectGrob(x, y,
width = w * expand[1],
height = h * expand[length(expand)],
just = c(hjust,vjust),
gp = gpar(col = alpha(bgcol, bgalpha), fill = alpha(bgfill, bgalpha))),
.super$draw(., data, scales, coordinates, ..., parse))
})
}
})
geom_text2 <- function (mapping = NULL, data = NULL, stat = "identity", position = "identity",parse = FALSE, ...) {
GeomText2$new(mapping = mapping, data = data, stat = stat, position = position, parse = parse, ...)
}