Fill polygons with pattern instead of color #49
Comments
|
Thanks for your request! Let me guess, it's for a scientific journal that is only printed in black&white? |
|
This describes one approach http://stackoverflow.com/questions/31342379/geom-bar-color-gradient-and-cross-hatches-using-gridsvg-transparency-issue. With |
|
My use case is not black/white printing, but overlaying a polygon layer over a raster layer. |
|
I will experiment by using the above plot (density = ....) and plot to a png file. If I get the plot resolution and projections right, this should work. This might be usefull in general. Before starting to use tmap, I was a bit concerned that I cannot easely overlay an arbitrary ggplot2 generated layer/plot with tmap. |
|
I would like to create a map like this:
|
|
I agree that this ia a duplicate of the feature request: |
|
I closed this by mistake. I think this feature would be important for tmap as patterns are available in the base plot system, but not in tmap. If I want patterns, I needed to use base plot, which would be a pity. |
|
Second that @behrica it will be very useful for my work also. The closest I've seen is this, but not sure how this could be implemented in tmaps's architecture: How to do cross hatching using grid: http://stackoverflow.com/questions/26110160/how-to-apply-cross-hatching-to-a-polygon-using-the-grid-graphical-system?lq=1 Cross hatching with spplot: http://stackoverflow.com/questions/21677489/fill-geospatial-polygons-with-pattern-r |
|
I think this can be done with the following approach: For each level of some categorical variable (that determines the fill pattern):
This procedure alone doesn't take much time to implement, but it takes some time to do the overhead. To-do list:
I'm short on time, and hope to submit the current version to CRAN soon. Any help is welcome of course. |
|
This sounds like a plan! Unfortunately short on time also but hope to chip in energy. 1st step if one were to contribute would be to see tmap's source code for the |
|
Yep (see https://github.com/mtennekes/tmap/blob/master/pkg/R/tm_layers.R), and accordingly, think about what parameters you want to specify. Another easy stand-alone step for contributors would be to create predefined pattern rectangles. It would be a function, say |
|
We'd better start a new branch, say |
|
Just checking to see if there was any movement on this? I would love to have this functionality in tmap so that I could lay a light pattern on top of, say, counties, where the rates are, say, high, but the measure is unstable. Like was done here, for example:
|
|
To be honest, it has a low priority for me (compared to the other feature requests). If someone has time to work on the implementation, I'll be happy to help. My comment above (https://github.com/mtennekes/tmap/issues/49#issuecomment-190596234) is a little outdated, since the introduction of |
|
I think a view mode implementation would be harder and less useful so a starter could be on just a plot mode implementation. Wish I had time, a fun mini-project. |
|
Thanks for the response. I am pretty sure I don't have the skill to help with this, and have bandwidth issues, but if anything comes up where there is a specific way I can help, please let me know. |
|
A workaround, for the time being, might be HatchedPolygons. You ultimately make a separate shapefile with just lines. |
|
Hi SwampThingPaul- Anything obvious that I am doing wrong. My "map.1" is a "SpatialPolygonsDataFrame" and works fine with plot or tmap, etc. If I use your code as suggested, just to get started, I get the error message below: cal.gono.hatch<-hatched.SpatialPolygons(map.1,density=0.001,angle=45); Error in apply(lines.hatch, 1, function(x) Line(cbind(c(x[1], x[3]), c(x[2], : Any suggestions? Thanks |
|
tmap is one of my favorite packages! @mcSamuelDataSci are looking into tackling this issue. @mtennekes you mention that this comment is outdated given sf and updates in tmap. I know it's a lot to ask since you indicated this is a relatively low priority for you, but any chance you'd be willing to share your thoughts on the best way to approach this given the current state of tmap. A few bullet points perhaps -- like the previous (but outdated) comment? |
|
Sure. I think these are the tasks:
|
|
I'm not sure what you're referring to with "stackable tile". Putting a few of your suggestions into actual code. Here I'm using library(tmap)
nc = st_read(system.file("shape/nc.shp", package="sf"))
some_counties <- dplyr::filter(nc, substring(NAME, 1, 1) %in% c("A", "B"))
gridvals <- sf::st_make_grid(some_counties, n = c(30, 30)) %>%
sf::st_cast("MULTILINESTRING")
res <- sf::st_intersection(some_counties, gridvals)
tm_shape(nc) +
tm_polygons("SID79")+
tm_shape(res)+
tm_lines()Note 2020-02-06: I got a report that the code above was no longer working. This is due to the intersection creating some GEOMETRYCOLLECTION geometries with points in them. The library(tmap)
nc = st_read(system.file("shape/nc.shp", package="sf"))
some_counties <- dplyr::filter(nc, substring(NAME, 1, 1) %in% c("A", "B"))
gridvals <- sf::st_make_grid(some_counties, n = c(30, 30)) %>%
sf::st_cast("MULTILINESTRING")
res <- sf::st_intersection(some_counties, gridvals)
cleangeom <- map(res$geometry, function(geom){
# if it's a geometrycollection break it down
if(st_geometry_type(geom) == "GEOMETRYCOLLECTION"){
geom <- purrr::map(geom, function(x){
# if a piece of the geometrycollection is not a line then drop it
if(!st_geometry_type(x) %in% c("LINESTRING", "MULTILINESTRING")) return(NULL)
x
}) %>%
purrr::keep(~!is.null(.)) %>% # drop nulls
st_multilinestring()
}
return(geom)
}) %>%
st_as_sfc()
res$geometry <- cleangeom
tm_shape(nc) +
tm_polygons("SID79")+
tm_shape(res)+
tm_lines()
|
|
Any updates on this? Sure looks promising! |
|
That's a good direction. Instead of |
|
To clarify: Note that we do not have to do it this way: like I wrote, we could also create Hope it's clear now. If not, please ask, preferable within this github issue. |
|
I'm guessing you had something far, far simpler in mind. I'm not sure how you were envisioning creating the herringbone (or related patterns). The code below does such a thing, but you can see that there are some gymnastics! In any case, once projections are addressed, these could be the basis for the two create_line <- function(starting_value, ending_value, segment_length, gap_length, starting_place, horizontal = TRUE){
total_length <- segment_length + gap_length
n_rep <- ceiling(abs(starting_value - ending_value)/total_length)
if(starting_value<ending_value){
vals <- starting_value + c(0, cumsum(rep(c(segment_length, gap_length), n_rep)))
} else{
vals <- starting_value - c(0, cumsum(rep(c(segment_length, gap_length), n_rep)))
}
l <- length(vals)
if(l%%2 != 0) vals <- vals[-length(vals)]
vals <- matrix(vals, ncol = 2, byrow = TRUE)
#browser()
purrr::map(1:nrow(vals), function(i){
if(horizontal){
st_linestring(rbind(c(vals[i, 1], starting_place), c(vals[i,2], starting_place)))
}else{
st_linestring(rbind(c(starting_place, vals[i, 1]), c(starting_place, vals[i,2])))
}
})
}
create_line(0, 30, 3, 1, 0, TRUE)%>% st_multilinestring() %>% plot(axes = TRUE)
create_line(1, 30, 3, 1, -1, TRUE)%>% st_multilinestring() %>% plot(axes = TRUE, add = TRUE)
create_line(2, 30, 3, 1, -2, TRUE)%>% st_multilinestring() %>% plot(axes = TRUE, add = TRUE)
create_line(-1, -30, 3, 1, 1, FALSE)%>% st_multilinestring() %>% plot(axes = TRUE, add = TRUE)
create_line(2, -30, 3, 1, 2, FALSE)%>% st_multilinestring() %>% plot(axes = TRUE, add = TRUE)
create_line(5, -30, 3, 1, 3, FALSE)%>% st_multilinestring() %>% plot(axes = TRUE, add = TRUE)
create_line(8, -30, 3, 1, 4, FALSE)%>% st_multilinestring() %>% plot(axes = TRUE, add = TRUE)
hori <- map2(0:40, 0:-40, function(x,y){
create_line(x, 50, 3, 1, y, TRUE)
}) %>% unlist(recursive = FALSE)
hori %>% st_multilinestring() %>% plot(axes = TRUE)
tmp <- seq(-40, 50, by = 3)
vert <- map2(tmp, 1:length(tmp), function(x,y){
create_line(x, -30, 3, 1, y, FALSE)
}) %>% unlist(recursive = FALSE)
fin <- st_multilinestring(c(hori, vert))
poly <- st_polygon(list(rbind(c(15,0), c(30,0), c(30, -10), c(15, -10), c(15,0))))
herringbone <- st_intersection(fin, poly)
poly_line <- st_multilinestring(poly)
fin <- st_multilinestring(c(herringbone, poly_line))
plot(fin)
rot = function(a) matrix(c(cos(a), sin(a), -sin(a), cos(a)), 2, 2)
fin_rot <- fin %>% st_geometry()
fin_rot <- fin_rot*rot(0.75)
plot(fin_rot)
|
|
That's definitely the right direction! Building on your ideas, what I have in mind is: # This function creates a line starting from (x, y) at angle (angle).
# dash_pattern is a numeric vector that specifies the dashing pattern. E.g. c(300, 100)
# means that the first line segment is 300 units, than a gap of 100 units.
# This pattern is repeated.
# The line should start at either the top or the left edge of the bounding box;
# in other words, either x = 0 or y = 0.
# The bounding box bbox is needed to determine when the line ends,
# and to crop the line.
create_line <- function(bbox, x, y, angle, dash_pattern) {
}# This function creates a herringbone.
create_herringbone <- function(bbox, size) {
# Iterate over the x-axis with stepsize (size * sqrt(2)). For each iteration,
# use create_line. Since the lines have 45 degree angle,
# you'll need to start at a negative x value.
# dash_pattern is alternating between c(size * 3, size) and c(size, size, size * 2)
# Likewise, iterate over the y-axis.
# Here the dash_pattern is always c(size * 3, size)
}Not sure you fully understand it. It's hard to explain without having good-old pencil and paper... Feel free to use your own approach. The goal should be a master function |
|
@mtennekes I'm slowly working on this. Below is a Coincidentally as I was working on herringbone just now, I was listening to this song in which they say "Ohhhhhh…That suit’s pure herringbone" :) seq_alt <- function(x, y, j, z){
if(j >= y) {return(x)}else{
s1 <- seq(x, y, j+z)
s2 <- seq(x+j, y, j+z)
return(sort(c(s1, s2)))
}
}
create_line <- function(bbox, x, y, angle, dash_pattern = c(0.3, 0.1)) {
# x and y dist to point on eastern edge
xdist_e <- bbox['xmax']-x
ydist_e <- xdist_e * tan(angle * pi/180)
# x and y dist to point on western edge
xdist_w <- x - bbox['xmin']
ydist_w <- xdist_w/tan(angle * pi/180)
target_pt_east <- st_point(c(bbox['xmax'], y + ydist_e))
target_pt_west <- st_point(c(bbox['xmin'], y - ydist_w))
ls <- st_linestring(c(target_pt_west, target_pt_east)) %>%
st_sfc()
ls <- st_crop(ls, bbox)
seqvals <- seq_alt(0, 1, dash_pattern[1], dash_pattern[2])
if(length(seqvals)%%2 == 1 & !1%in%seqvals) seqvals <- c(seqvals, 1)
if(length(seqvals)%%2 == 1 & 1%in%seqvals) seqvals <- seqvals[seqvals!=1]
multipoint <- st_line_sample(ls, sample = c(seqvals))
point <- multipoint %>%
st_cast("POINT")
ls_with_breaks <- point %>%
st_sf()%>%
mutate(id = rep(1:(length(point)/2), each = 2)) %>%
group_by(id) %>%
summarise(m = mean(id)) %>%
st_cast("LINESTRING") %>%
st_union()
ls_with_breaks
}
# Example
box1 <- st_polygon(list(rbind(c(0,0), c(0,1), c(1,1), c(1,0), c(0,0))))
bbox1 <- st_bbox(box1)
my_line <- create_line(bbox1, 0.5, 0.5, 100)
plot(box1)
plot(my_line, add = TRUE, col = "red")
my_line <- create_line(bbox1, 0.5, 0.5, 30, dash_pattern = c(0.1, 0.1))
plot(box1)
plot(my_line, add = TRUE, col = "red", lwd = 2)
|
|
I must be making this drastically more complex than it needs to be. I'm having trouble with the create_pattern() function and getting the herringbone to work. I'm still working but here is the create line at the moment. create_line <- function(bbox, x = bbox['xmin'], y = bbox['ymin'], angle = 45, dash_pattern = c(0.3, 0.1)) {
if(any(dash_pattern > 1 | dash_pattern < 0))
stop("dash_pattern requires a vector of length 2 and both values need to be between 0 and 1")
if(!(angle >= 0 & angle <= 360))
stop("angle must be between 0 and 360 (inclusive)")
if(angle == 0)
angle <- 360
#browser()
if(x == 1.3){
#browser()
}
thecrs <- st_crs(bbox)
xmax <- bbox['xmax']
xmin <- bbox['xmin']
xdist_tot <- abs(xmax-xmin)
dash_pattern_rel <- dash_pattern * xdist_tot
if(angle<90){
# x and y dist to point on eastern edge
xdist_e <- xmax- x
ydist_e <- xdist_e * tan(angle * pi/180)
# x and y dist to point on western edge
xdist_w <- x - xmin
ydist_w <- xdist_w/tan(angle * pi/180)
target_pt_east <- sf::st_point(c(round(xmax, 5), round(y + ydist_e, 5)))
target_pt_west <- sf::st_point(c(x,y))
}else{
xdist_e <- x-xmin
ydist_e <- abs(xdist_e * tan(angle * pi/180))
# x and y dist to point on western edge
xdist_w <- xmax - x
ydist_w <- abs(xdist_w/tan(angle * pi/180))
target_pt_east <- sf::st_point(c(round(xmin, 5), round(y + ydist_e, 5)))
target_pt_west <- sf::st_point(c(x,y))
}
ls <- sf::st_linestring(c(target_pt_west, target_pt_east)) %>%
sf::st_sfc(crs = thecrs)
ls <- sf::st_crop(ls, st_as_sfc(bbox))
if(!"sfc_LINESTRING" %in% class(ls))
return()
#stop("The x, y and angle combination will produce a line outside the bounding box")
length_ls <- st_length(ls)
seqvals <- seq_alt(0, length_ls, dash_pattern_rel[1], dash_pattern_rel[2])/length_ls
if(length(seqvals)%%2 == 1 & !1%in%seqvals) seqvals <- c(seqvals, 1)
if(length(seqvals)%%2 == 1 & 1%in%seqvals) seqvals <- seqvals[seqvals!=1]
multipoint <- sf::st_line_sample(ls, sample = c(seqvals))
point <- multipoint %>%
sf::st_cast("POINT")
ls_with_breaks <- point %>%
sf::st_sf()%>%
dplyr::mutate(id = rep(1:(length(point)/2), each = 2)) %>%
dplyr::group_by(id) %>%
dplyr::summarise(m = mean(id)) %>%
sf::st_cast("LINESTRING") %>%
sf::st_union()
ls_with_breaks %>%
st_sf()
}# An example
size <- 0.2
box1 <- st_polygon(list(rbind(c(0,0), c(0,2), c(2,2), c(2,0), c(0,0))))
bbox1 <- st_bbox(box1)
cosval <- cos(45 * pi/180) * 2* size
sinval <- sin(45 * pi/180) * 2* size
maxvals <- bbox1[['xmax']]/size
xvals <- -10:maxvals * size
xvals[seq(2, length(xvals), by = 2)] <- xvals[seq(2, length(xvals), by = 2)] + cosval
yvals <- rep(c(0, sinval), length.out = length(xvals))
lines1 <- purrr::map2(xvals, yvals, function(x, y){
create_line(bbox1, x = x, y = y, angle = 45)
})
lines1 <- purrr::keep(lines1, function(x) !is.null(x))
lines1 <- purrr::reduce(lines1, rbind)
plot(st_as_sfc(bbox1))
plot(lines1, add = TRUE)
|
|
There is a new hacky solution using @coolbutuseless packages: # # install.packages("devtools")
# install_github("coolbutuseless/poissoned") # Generate points via poisson disk sampling
# install_github("coolbutuseless/svgpatternsimple") # This package
# devtools::install_github("coolbutuseless/lofi") # Colour encoding
# devtools::install_github("coolbutuseless/minisvg") # SVG creation
# devtools::install_github("coolbutuseless/devout") # Device interface
# devtools::install_github("coolbutuseless/devoutsvg") # This package
library(svgpatternsimple)
library(devoutsvg)
f = svgpatternsimple::encode_pattern_params_as_hex_colour
colours = c(
A = f(pattern_name = 'hatch' , spacing = 7, fill_fraction = 0.2, angle = 45),
B = f(pattern_name = 'dot' , spacing = 4, fill_fraction = 0.8, angle = 0),
C = f(pattern_name = 'hex' , spacing = 8, fill_fraction = 0.7)
)
library(tmap)
data(World, metro, rivers)
World$cat = as.factor(sample(1:3, size = nrow(World), replace = TRUE))
svgout(filename = "example.svg", pattern_pkg = 'svgpatternsimple')
tm_shape(World) +
tm_polygons("cat", style = "cat", palette = colours)
invisible(dev.off())
library(magick)
svg_image = image_read_svg("example.svg", width = 850)
image_write(svg_image, path = "example.png", format = "png")
|
|
Another approach could be inspired by the |
|
Hi @Nowosad , I have just created a PR to include
|
|
Great work @dieghernan! It would be nice to extend it for tmap. |
|
This may be relevant for a tmap (grid-based) solution: https://twitter.com/coolbutuseless/status/1228979536231948288 This is apparently not depending on devoutsvg |
Just a quick reminder, the new version of |
|
@dieghernan it would be great to have that feature in tmap! |
|
Great work @dieghernan! library(tmap)
library(sf)
library(tidyverse)
library(cartography)
data(World)
patterns <- c("diamond","grid","hexagon","horizontal", "vertical",
"zigzag","left2right","right2left","circle")
Continent_sfc <- do.call(c, lapply(1:nlevels(World$continent), function(i) {
World %>%
filter(continent == levels(World$continent)[i]) %>%
hatchedLayer(mode = "sfc", pattern = patterns[i], density = 1)
}))
Continent_patterns <- st_sf(geometry = Continent_sfc,
continent = levels(World$continent))
tm_shape(World) +
tm_fill("continent") +
tm_shape(Continent_patterns) +
tm_lines(col = "grey50") +
tm_shape(World) +
tm_borders(col = "black")Created on 2020-05-04 by the reprex package (v0.3.0.9001) It also works well in view mode. This definitely goes in the right direction, but we'll need some effort for a good implementation into tmap. General functionality:
Implementation:
|
|
Just chiming in that this is great, and very helpful. Thank you all.
Michael
…On Mon, May 4, 2020 at 3:15 AM mtennekes ***@***.***> wrote:
Great work @dieghernan <https://github.com/dieghernan>!
An example with tmap:
library(tmap)
library(sf)
library(tidyverse)
library(cartography)
data(World)
patterns <- c("diamond","grid","hexagon","horizontal", "vertical",
"zigzag","left2right","right2left","circle")
Continent_sfc <- do.call(c, lapply(1:nlevels(World$continent), function(i) {
World %>%
filter(continent == levels(World$continent)[i]) %>%
hatchedLayer(mode = "sfc", pattern = patterns[i], density = 1)
}))
Continent_patterns <- st_sf(geometry = Continent_sfc,
continent = levels(World$continent))
tm_shape(World) +
tm_fill("continent") +
tm_shape(Continent_patterns) +
tm_lines(col = "grey50") +
tm_shape(World) +
tm_borders(col = "black")
<https://camo.githubusercontent.com/2f848b5ab013267a9a08fce0b906a9b0314e9da1/68747470733a2f2f692e696d6775722e636f6d2f51414b555566422e706e67>
Created on 2020-05-04 by the reprex package <https://reprex.tidyverse.org>
(v0.3.0.9001)
It also works well in view mode.
This definitely goes in the right direction, but we'll need some effort
for a good implementation into tmap.
General functionality:
- I noticed that some patterns are more dense than others (e.g.
diagonal lines are denser than horizontal/vertical ones). From a
methodological point of view, patterns should be perceived approximately
equally dense.
- How hard is it for co-developers to implement new patterns? E.g.,
the one that @zross <https://github.com/zross> made (see above)?
Implementation:
- I am not a big fan of putting cartography into the imports list of
tmap, because tmap is already bulky, and cartography will add other
packages (including sp and raster). So ideally, we would have to
migrate hatchedLayer (or the part of that function that is responsible
for the patterns) to another, low-level package. Alternatively,
cartography can be placed into the suggestions list of tmap, which
means that a user who decides to use patterns is required to have
cartography installed.
- Most implementation work, apart from the two issues mentioned above,
will be on my side, since it is it nothing more than fitting it into the
tmap pipeline. A challenge will be the legend (which will only work in plot
mode), since the legend rectangles are not sf objects. There will be
some sort of implementation trick to do this.
- I think we need to add the following arguments to tm_fill:
- pattern. The new aesthetic (out of the existing aesthetics, it
will be most similar to shape from tm_symbols, albeit a little
simpler, since shape can also take glpyhs)
- patterns. The 'palette' of patterns. Default could be as defined
in the example above. The name could be confusing. Alternatively, we could
name it pattern.palette. However, tm_symbols also has shape and
shapes...
- pattern.density. Similar to density from hatchedLayer.
- The standard legend control parameters legend.pattern.show etc.
—
You are receiving this because you were mentioned.
Reply to this email directly, view it on GitHub
<https://github.com/mtennekes/tmap/issues/49#issuecomment-623379220>, or
unsubscribe
<https://github.com/notifications/unsubscribe-auth/AEYFE6HW3MN6KVDPGTPXWCDRP2IV7ANCNFSM4B4HDTRA>
.
|
|
Thanks for the tmap implementation, @mtennekes . Is there a way to add pattern boxes to the legend? |
ghost
mentioned this issue
|
@mtennekes, a potentially nice feature to add to the above requests is to have a fill/pattern for the NA. This would be useful in black and white figures where you can use a pattern to clearly differentiate the NA if the grayscale is suitable for filling the geolocations. |
|
Maybe this could be useful here - https://coolbutuseless.github.io/2021/07/01/r-v4.1.0-grid-graphics-new-feature-patterns/. |
|
@mtennekes: another potentially nice feature to add is to have a pattern for negative/positive values. This would be useful in black and white figures (if PI don't want to pay for color in journal). Thank you! |
I would lik to make layers like this:
https://www.google.it/url?sa=i&rct=j&q=&esrc=s&source=images&cd=&cad=rja&uact=8&ved=0ahUKEwjt9Nn015DLAhVLnRoKHePnAoMQjRwIBw&url=http%3A%2F%2Fstackoverflow.com%2Fquestions%2F21677489%2Ffill-geospatial-polygons-with-pattern-r&psig=AFQjCNEuKaSmbfZl5kI97ll5z26jhPYvbQ&ust=1456413141848808
So patterns instead of colors.
I believe this is currently not possible.
I can do those with plot(spdf, density = ...), but I did not manage to overlay this plot over the tmap layers. Is there a wy to do this ?
The text was updated successfully, but these errors were encountered: