#' Draw a map
#'
#' This function creates a map based on the data of polygon coordinates.
#' Cartograms can be made by providing appropriate coordinates generated by
#' \code{\link{cart_polygon}}.
#'
#' Common interactions are documented in \code{\link{common_key_press}}.
#' Currently the brushing may be slightly different with other plots: when a
#' region contains multiple sub-regions (polygons), and the whole region will be
#' brushed if any of the sub-regions is brushed.
#'
#' The other feature is that a map can be linked to other datasets so that
#' colors and the brushed status can be obtained from an additional data. This
#' is useful due to the special format of map data: usually it is a waste of
#' memory to store colors for every single boundary points in each region.
#' @param data the map data created by \code{\link{map_qdata}}
#' @param linkto a mutaframe to link to so that the colors and the brushed
#' status are in sync with this data
#' @param linkby the variable in the \code{linkto} data to be used as a linking
#' variable (see \code{\link{link_cat}})
#' @param unibrushcolor whether to use multiple colors for the brush, i.e.,
#' whether to transparentize the unbrushed polygons.
#' @param googleMap whether to have a google map background. The packages
#' \pkg{ggmap} and \pkg{RgoogleMaps} must be installed.
#' @param place a mutaframe created by \code{\link{qdata}} indicating the
#' locations that will be shown on the map.
#' @param path a mutaframe of locations created by \code{\link{qdata}}. A path
#' will be drawn on the map in the order of the mutaframe.
#' @param text a mutaframe of locations and names.
#' @param cartostep a value between 0 and 1. When a cartogram is drawn, the left
#' arrow and right arrow can be used to evolve the map between the original
#' map and the cartogram. cartostep controls the evolving speed.
#' @inheritParams qbar
#' @return A map
#' @export
#' @author Heike Hofmann, Yihui Xie, and Xiaoyue Cheng
#' @example inst/examples/qmap-ex.R
qmap = function(
data, linkto = NULL, linkby = NULL, main = '', xlim = NULL, ylim = NULL,
unibrushcolor = TRUE, googleMap = FALSE, place = NULL, path = NULL, text = NULL,
cartostep = 0.05, ...
) {
data = check_data(data)
if (is.null(md <- attr(data, 'MapData')))
stop('data must be created from map_qdata()')
b = brush(data)
b$select.only = TRUE; b$draw.brush = FALSE # a selection brush
b$alpha = 1
z = as.list(match.call()[-1])
## initialize meta
meta = Map.meta$new(
alpha = 1, main = main, active = TRUE, drag.mode = FALSE, cartopar = 1,
group = cumsum(is.na(md$x) & is.na(md$y)) + 1
)
## compute coordinates/axes-related stuff
compute_coords = function() {
r = cbind(
if (is.null(xlim)) range(md$x, na.rm = TRUE, finite = TRUE) else xlim,
if (is.null(ylim)) range(md$y, na.rm = TRUE, finite = TRUE) else ylim
)
meta$limits = extend_ranges(r)
}
compute_coords()
meta$start.range = as.vector(meta$limits)
compute_colors = function() {
meta$border = data$.border
if (is.null(linkto)) {
meta$color = if (googleMap) {alpha(data$.color, 0)} else {data$.color}
} else {
if (is.null(linkby)) stop("must specify a linking variable in 'linkto'")
tmp = tapply(linkto$.color, linkto[, as.character(z$linkby)], `[`, 1)
# use labels to find colors
meta$color = if (googleMap) {alpha (tmp[data$labels], 0.5)} else {tmp[data$labels]}
}
}
compute_colors()
## initialize brush size (1/15 of the layer size)
meta$brush.size = c(1, -1) * apply(meta$limits, 2, diff) / 15
## draw points
main_draw = function(layer, painter) {
qdrawPolygon(
painter, md$x, md$y, stroke = meta$border,
fill = if (unibrushcolor) {meta$color} else {alpha(meta$color,0.3)}
)
# draw warning lines, if points are outside the drawing area r is current range
#
# binary array with one column for each variable shouldn't need to check for
# every single draw, but I'm not sure where the boundaries are changed -
# compute coord is not called for every zooms e.g.
meta$outofbounds <- meta$limits
meta$outofbounds[1,1] <- min(md$x, na.rm=T) < meta$limits[1,1]
meta$outofbounds[2,1] <- max(md$x, na.rm=T) > meta$limits[2,1]
meta$outofbounds[1,2] <- min(md$y, na.rm=T) < meta$limits[1,2]
meta$outofbounds[2,2] <- max(md$y, na.rm=T) > meta$limits[2,2]
if (sum(meta$outofbounds) > 0) {
# at least one boundary is too tight
if (meta$outofbounds[1,1]) qdrawSegment(
painter, meta$limits[1,1], meta$limits[1,2], meta$limits[1,1], meta$limits[2,2],
stroke = "red"
)
if (meta$outofbounds[1,2]) qdrawSegment(
painter, meta$limits[1,1], meta$limits[1,2], meta$limits[2,1], meta$limits[1,2],
stroke = "red"
)
# just to make sure that the right hand side and top line show up - they
# get clipped at the limits, so only half of it shows.
qlineWidth(painter) = 4
if (meta$outofbounds[2,2]) qdrawSegment(
painter, meta$limits[1,1], meta$limits[2,2], meta$limits[2,1], meta$limits[2,2],
stroke = "red"
)
if (meta$outofbounds[2,1]) qdrawSegment(
painter, meta$limits[2,1], meta$limits[1,2], meta$limits[2,1], meta$limits[2,2],
stroke = "red"
)
}
}
## draw brushed points
brush_draw = function(layer, painter) {
idx = selected(data)
if (any(idx)) {
i = meta$group %in% which(idx)
if (unibrushcolor) {
brush_color = alpha(b$color, b$alpha) # transparent brush
qdrawPolygon(painter, md$x[i], md$y[i], stroke = NA, fill = brush_color)
} else {
ii = if (is.na(md$x[i][1])) which(i)[-1] else i
qdrawPolygon(painter, md$x[ii], md$y[ii], stroke = NA, fill = meta$color[idx])
}
} else if (!unibrushcolor) {
qdrawPolygon(painter, md$x, md$y, stroke = meta$border, fill = meta$color)
}
draw_brush(layer, painter, data, meta)
}
## draw Google maps
if (googleMap) {
meta$googlemaprange = data.frame(ll.lon=0,ur.lon=0,ll.lat=0,ur.lat=0)
meta$googlecolor = rep('white',1280*1280)
meta$googlex = meta$googley = rep(0, 1280*1280)
meta$googlezoom = -1
google_draw = function(layer,painter) {
bound=as.matrix(meta$limits)
googlezoom1=min(RgoogleMaps::MaxZoom(bound[,1], bound[,2], c(640, 640)))
googlezoom2=round(log(360/max(diff(bound[,1]),diff(bound[,2])),1.8))
googlezoom=min(googlezoom1,googlezoom2)
rangecond=any(meta$googlemaprange$ll.lon>c(0.9,0.1)%*%bound[,1],
meta$googlemaprange$ur.lon<c(0.1,0.9)%*%bound[,1],
meta$googlemaprange$ll.lat>c(0.9,0.1)%*%bound[,2],
meta$googlemaprange$ur.lat<c(0.1,0.9)%*%bound[,2])
if (meta$googlezoom!=googlezoom | rangecond) {
meta$googlezoom=googlezoom
message("Extracting the Google map...")
map=ggmap::get_googlemap(center = c(lon = mean(bound[,1]), lat = mean(bound[,2])),zoom = meta$googlezoom, scale = 2, ...)
meta$googlemaprange=attr(map, "bb")
meta$googlecolor=as.vector(map[1:1280, 1:1280])
realxy=RgoogleMaps::XY2LatLon(list(lat=mean(bound[,2]),lon=mean(bound[,1]),zoom=meta$googlezoom),seq(-320,319.5,0.5),seq(-320,319.5,0.5))
reallocat=expand.grid(realxy[,2],rev(realxy[,1]))
meta$googlex=reallocat$Var1
meta$googley=reallocat$Var2
}
googleidx=(findInterval(meta$googlex,bound[,1],rightmost.closed=TRUE)==1 &
findInterval(meta$googley,bound[,2],rightmost.closed=TRUE)==1)
drawgooglecolor=meta$googlecolor[googleidx]
qdrawGlyph(painter, qglyphSquare(x = min(diff(bound[,1]),diff(bound[,2]))/sqrt(sum(googleidx))),
meta$googlex[googleidx], meta$googley[googleidx],
stroke = drawgooglecolor, fill = drawgooglecolor)
}
}
## draw path
if (!is.null(path)) {
path = check_data(path)
path_draw = function(layer,painter) {
idx = visible(path)
qlineWidth(painter) <- median(path$.size[idx])
qdrawLine(painter, path[idx,1], path[idx,2], stroke = path$.color[idx][1])
}
}
## draw points
if (!is.null(place)) {
place = check_data(place)
place_draw = function(layer,painter) {
idx = visible(place)
if (all(place$.size==place$.size[1])) {
qdrawGlyph(painter, qglyphCircle(r = place$.size[1]),
place[idx,1], place[idx,2],
stroke = place$.border[idx], fill = place$.color[idx])
} else {
qdrawCircle(painter, place[idx,1], place[idx,2], r = place$.size[idx],
stroke = place$.border[idx], fill = place$.color[idx])
}
}
}
## draw text
if (!is.null(text)) {
text = check_data(text)
text_draw = function(layer,painter) {
idx = visible(text)
qdrawText(painter, text[idx,3], text[idx,1], text[idx,2],
color = text$.color[idx], ...)
}
}
## events
brush_mouse_press = function(layer, event) {
meta$drag.mode = (any(meta$limits[1,] > meta$start.range[c(1,3)]) ||
any(meta$limits[2,] < meta$start.range[c(2,4)])) &&
event$button() == Qt$Qt$LeftButton
if (meta$drag.mode) {
meta$start = as.numeric(event$pos())
b$cursor <- 18L
} else {
common_mouse_press(layer, event, data, meta)
}
}
brush_mouse_move = function(layer, event) {
if (event$button() != Qt$Qt$NoButton) b$cursor <- 0L
if (meta$drag.mode) {
meta$pos = as.numeric(event$pos())
meta$limits = meta$limits + matrix(rep(-meta$pos+meta$start,each=2),nrow=2)
qupdate(layer.main)
if (googleMap) qupdate(layer.google)
if (!is.null(path)) qupdate(layer.path)
if (!is.null(place)) qupdate(layer.place)
if (!is.null(text)) qupdate(layer.text)
return()
}
rect = qrect(update_brush_size(meta, event))
hits = layer$locate(rect) + 1
if (length(hits)) {
hits = data$labels %in% unique(data$labels[hits])
}
selected(data) = mode_selection(selected(data), hits, mode = b$mode)
common_mouse_move(layer, event, data, meta)
}
brush_mouse_release = function(layer, event) {
brush_mouse_move(layer, event)
if (!meta$drag.mode) common_mouse_release(layer, event, data, meta)
}
key_press = function(layer, event) {
common_key_press(layer, event, data, meta)
if (ncol(md)==6 & !googleMap & is.null(path) & is.null(place) & is.null(text)
& length(i <- which(match_key(c('Left', 'Right'))))) {
cartopar = max(0, min(1, c(-1, 1)[i] * cartostep + meta$cartopar))
if (cartopar != meta$cartopar) {
meta$cartopar = cartopar
md$x = md$finalx * meta$cartopar + md$origx * (1 - meta$cartopar)
md$y = md$finaly * meta$cartopar + md$origy * (1 - meta$cartopar)
compute_coords()
meta$start.range = as.vector(meta$limits)
layer.main$invalidateIndex()
}
}
}
key_release = function(layer, event) {
common_key_release(layer, event, data, meta)
}
mouse_wheel = function(layer, event) {
pos = as.numeric(event$pos())
lim = meta$limits
p = (pos - lim[1, ]) / (lim[2, ] - lim[1, ]) # proportions to left/bottom
meta$limits = extend_ranges(
meta$limits, -sign(event$delta()) * 0.1 * c(p[1], 1 - p[1], p[2], 1 - p[2])
)
if (googleMap) qupdate(layer.google)
if (!is.null(path)) qupdate(layer.path)
if (!is.null(place)) qupdate(layer.place)
if (!is.null(text)) qupdate(layer.text)
}
identify_hover = function(layer, event) {
if (!b$identify) return()
b$cursor = 2L
meta$pos = as.numeric(event$pos())
hits = layer$locate(identify_rect(meta)) + 1
if (length(hits)) {
hits = which(data$labels %in% unique(data$labels[hits]))
}
meta$identified = hits
qupdate(layer.identify)
}
identify_draw = function(layer, painter) {
if (!b$identify || !length(idx <- meta$identified)) return()
if (any(idx)) {
meta$identify.labels = paste(unique(data$labels[idx]), collapse = '\n')
draw_identify(layer, painter, data, meta)
i = meta$group %in% idx
qdrawPolygon(painter, md$x[i], md$y[i], stroke = b$color, fill = NA)
}
}
## create layers
scene = qscene()
layer.root = qlayer(scene)
layer.main = qlayer(
paintFun = main_draw,
mousePressFun = brush_mouse_press, mouseReleaseFun = brush_mouse_release,
mouseMoveFun = brush_mouse_move, hoverMoveFun = identify_hover,
keyPressFun = key_press, keyReleaseFun = key_release,
wheelFun = mouse_wheel,
focusInFun = function(layer, event) {
common_focus_in(layer, event, data, meta)
}, focusOutFun = function(layer, event) {
common_focus_out(layer, event, data, meta)
},
limits = qrect(meta$limits), clip = TRUE, cache = TRUE
)
layer.brush = qlayer(paintFun = brush_draw, limits = qrect(meta$limits))
layer.identify = qlayer(paintFun = identify_draw, limits = qrect(meta$limits))
layer.title = qmtext(meta = meta, side = 3)
layer.root[0, 0] = layer.title
if (googleMap) {
layer.google = qlayer(paintFun = google_draw, limits = qrect(meta$limits),
clip = TRUE, cache = TRUE)
layer.root[1, 0] = layer.google
}
layer.root[1, 0] = layer.main
layer.root[1, 0] = layer.brush
layer.root[1, 0] = layer.identify
if (!is.null(path)) {
layer.path = qlayer(paintFun = path_draw, limits = qrect(meta$limits),
clip = TRUE, cache = TRUE)
layer.root[1, 0] = layer.path
}
if (!is.null(place)) {
layer.place = qlayer(paintFun = place_draw, limits = qrect(meta$limits),
clip = TRUE, cache = TRUE)
layer.root[1, 0] = layer.place
}
if (!is.null(text)) {
layer.text = qlayer(paintFun = text_draw, limits = qrect(meta$limits),
clip = TRUE, cache = TRUE)
layer.root[1, 0] = layer.text
}
layer.root[1, 1] = qlayer()
## set sizes of layers (arrange the layout)
set_layout = function() {
fix_dimension(layer.root,
row = list(id = 0, value = prefer_height(meta$main)),
column = list(id = 1, value = 10))
}
set_layout()
## layout is dynamic (listen to changes in xlab/ylab/xlabels/ylabels...)
meta$mainChanged$connect(set_layout)
## finally create the view and set window title
view = qplotView(scene = scene)
view$setWindowTitle(paste("Map:", as.character(z$data)))
## listeners on the data (which column updates which layer(s))
d.idx = add_listener(data, function(i, j) {
idx = which(j == c('.brushed', '.color', '.border'))
if (length(idx) < 1) {
compute_coords()
layer.main$invalidateIndex(); qupdate(layer.main)
return()
} else idx = c(1, 2, 2)[idx]
switch(idx, qupdate(layer.brush), {
compute_colors(); qupdate(layer.main)
})
})
if (!is.null(linkto)) {
id = link_cat(linkto, as.character(z$linkby), data, 'labels')
}
## when layer is destroyed, remove the listener from data
qconnect(layer.main, 'destroyed', function(x) {
## b$colorChanged$disconnect(b.idx)
remove_listener(data, d.idx)
if (!is.null(linkto)) {
remove_link(linkto, id[1]); remove_link(data, id[2])
}
})
## when b$cursor is changed, update cursor on screen
b$cursorChanged$connect(function() {
set_cursor(view, b$cursor)
})
## these layers have the same limits from meta$limits
sync_limits(
meta, layer.main, layer.brush, layer.identify,
if (googleMap) layer.google,
if (!is.null(path)) layer.path,
if (!is.null(place)) layer.place,
if (!is.null(text)) layer.text
)
## simulate brushing
meta$manual.brush = function(pos) {
brush_mouse_move(layer = layer.main, event = list(pos = function() pos))
}
## attach meta to the returned value (for post-processing or debugging)
attr(view, 'meta') = meta
view
}
Map.meta = setRefClass(
"Map_meta", contains = "CommonMeta",
fields = properties(list(
group = 'numeric', start.range = 'numeric', drag.mode = 'logical',
outofbounds = 'matrix', googlezoom = 'integer', googlemaprange = 'data.frame',
googlecolor = 'character', googlex = 'numeric', googley = 'numeric',
cartopar = 'numeric'
))
)
#' Create data for drawing maps
#'
#' This function converts maps data in the \pkg{maps} package to a suitable
#' format for \pkg{cranvas}. Optionally it transforms the data to make
#' cartograms.
#'
#' The function \code{\link[maps]{map}} is used to convert maps data to a list,
#' then the region names are stored in a mutaframe created by
#' \code{\link{qdata}}; the polygon coordinates are stored in an attribute
#' \code{MapData}. If multiple polygons belong to the same upper-level region,
#' the column \code{labels} will store the upper-level region names.
#' @param database see \code{\link[maps]{map}}
#' @param regions see \code{\link[maps]{map}}
#' @inheritParams qdata
#' @param cartogram whether to transform the map data in order to create a
#' cartogram; if \code{TRUE}, the shape of the cartogram will be determined by
#' the \code{size} parameter in the data (i.e. \code{data$.size}); see
#' \code{\link{cart_polygon}} for details
#' @param ... passed to \code{\link{cart_polygon}}
#' @return A mutaframe of region names and labels, with an attribute
#' \code{MapData} containing the coordinates of polygons.
#' @author Yihui Xie and Xiaoyue Cheng
#' @export
#' @examples library(cranvas); map_qdata('state'); map_qdata('county', 'iowa')
map_qdata = function(
database, regions = '.', color = 'gray50', border = 'gray90', size = 4,
cartogram = FALSE, label = NULL, ...
) {
library(maps)
df = map(database, regions, plot = FALSE, fill = TRUE)
## usually ':' is the separator but sometimes it is ','
if (length(label) == length(df$names))
message('Self-defined labels will build a link between brushed and',
'unbrushed areas which share the same label.')
labels = if (length(label) == length(df$names)) {
label
} else if (any(grepl(':', df$names, fixed = TRUE))) {
sapply(strsplit(df$names, ':', fixed = TRUE), `[`, 1)
} else if (any(grepl(',', df$names, fixed = TRUE))) {
sapply(strsplit(df$names, ',', fixed = TRUE), `[`, 1)
} else df$names
mf = qdata(data.frame(names = df$names, labels = labels, stringsAsFactors = FALSE),
color = color, border = border, size = size, ...)
xy = as.data.frame(df[1:2])
if (cartogram && length(size) > 1 && !near_constant(size)) {
## FIXME: cartogram() depends on the magnitude of size!!! so I did not use mf$.size
xy = cart_polygon(xy$x, xy$y, df$names, size, ...)
xy$origx = df$x
xy$origy = df$y
xy$finalx = xy$x
xy$finaly = xy$y
xy = as.mutaframe(xy)
}
attr(mf, 'MapData') = xy
mf
}
#' Calculate coordinates of transformed polygons to make cartograms
#'
#' Based on the given sizes of polygons, this function calculates the
#' transformed coordinates using the \pkg{Rcartogram} package.
#' @param x,y the x and y coordinates of original polygons (polygons are
#' separated by \code{NA}'s)
#' @param name the names of original polygons
#' @param size the size vector of polygons (length must be equal to the number
#' of polygons, i.e. the number of \code{NA}'s plus 1)
#' @param nrow,ncol numbers to define a grid for the cartogram algorithm (see
#' references in \pkg{Rcartogram}); this can affect the convergence and speed
#' of the algorithm, so may need to be adjusted for a few times
#' @param blank.init weight to fill the NA's of the grids between the range
#' of density. It will control the diffusing/shrinking within the boundary.
#' @param sea.init weight between the range of density to fill in the sea.
#' It will control the diffusing/shrinking out of the map boundary.
#' @param sea.width a positive multiplier to pass to the argument \code{sea}
#' in function \code{\link[Rcartogram]{addBoundary}}.
#' @param blur a non-negative value passed to \code{\link[Rcartogram]{cartogram}}
#' @return A data frame of two columns \code{x} and \code{y} (coordinates of
#' transformed polygons)
#' @author Yihui Xie and Xiaoyue Cheng
#' @export
#' @example inst/examples/cart_polygon-ex.R
cart_polygon = function(x, y, name, size, nrow = 100, ncol = 100, blank.init=0, sea.init=0, sea.width=1, blur=0) {
library(Rcartogram)
if (length(size) != sum(is.na(x)) + 1)
stop("the length of 'size' vector must be the same as the number of polygons")
if (sea.width <= 0) {
message("sea.width must be greater than 0. Set to be 1.")
sea.width = 1
}
if (blur < 0) {
message("blur must be non-negative. Set to be 0.")
blur = 0
}
xlim = range(x, na.rm = TRUE); ylim = range(y, na.rm = TRUE)
dx = c(0, diff(xlim)/1000); dy = c(0, diff(ylim)/1000) # to construct query rectangle
gridsize = gridcount = gridrecog = matrix(NA, nrow = nrow, ncol = ncol)
gx = seq(xlim[1], xlim[2], length = ncol); gy = seq(ylim[1], ylim[2], length = nrow)
## we use Qt to query the sizes for grid points
h = qlayer(paintFun = function(layer, painter) {
qdrawPolygon(painter, x, y)
}, limits = qrect(xlim, ylim))
## generate the population density matrix (time consuming)
message(paste('Generating the',nrow,'x',ncol,'population density grid...'))
pb = txtProgressBar(min = 0, max = nrow, style = 3)
on.exit(close(pb))
for (i in seq_len(nrow)) {
for (j in seq_len(ncol)) {
hit = h$locate(qrect(gx[j] + dx, gy[i] + dy))
if (length(hit)) gridsize[i, j] = size[hit[1] + 1]; gridrecog[i,j] = name[hit[1]+1]
}
setTxtProgressBar(pb, i)
}
#gridrecog[is.na(gridrecog)] = 0
gridcount = matrix(sapply(gridrecog, function(x){sum(gridrecog==x,na.rm=TRUE)}),nrow=nrow(gridrecog))
gridcount[is.na(gridsize)] = 1
# fill NA's with 1% less than min; add margin with min too later
gridsize[is.na(gridsize)] = min(gridsize, na.rm = TRUE)
tmp=as.vector(gridsize)/as.vector(gridcount)
tmp[is.na(gridrecog)] = sum(range(tmp[!is.na(gridrecog)])*c(1-blank.init,blank.init))
grid = matrix(tmp,nrow=nrow,ncol = ncol)
grid = addBoundary(grid, sea=sea.width, land.mean = sum(range(grid)*c(1-sea.init,sea.init)))
extra = attr(grid, 'extra') # extra rows/cols added
message(paste('Calculating cartogram coordinates for a',dim(grid)[1],'x',dim(grid)[2],'matrix...'))
res = cartogram(grid, zero=TRUE, blur=blur, sea=NA)
pred = predict(res, (x - xlim[1]) / (diff(xlim)) * (ncol - 1) + 1 + extra[1],
(y - ylim[1]) / (diff(ylim)) * (nrow - 1) + 1 + extra[2])
data.frame(x = (pred$x - extra[1] - 1) / (ncol - 1) * diff(xlim) + xlim[1],
y = (pred$y - extra[2] - 1) / (nrow - 1) * diff(ylim) + ylim[1])
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.