Fill polygons with pattern instead of color

[behrica]

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 ?

[mtennekes]

Thanks for your request! Let me guess, it's for a scientific journal that is only printed in black&white? @rlzijdeman asked this question before https://github.com/mtennekes/treemap/issues/8. My answer still applies: if someone can find out how this can be done with the grid package or one of its extensions, i.e. with grid.rect or grid.polygon, I can implement it in t(ree)map.

[timelyportfolio]

This describes one approach http://stackoverflow.com/questions/31342379/geom-bar-color-gradient-and-cross-hatches-using-gridsvg-transparency-issue. With svglite and rsvg, I could try to flesh this out, but will still be an indirect approach.

[behrica]

My use case is not black/white printing, but overlaying a polygon layer over a raster layer. One way to make it look nice could be to use pattern instead of color for the second (instead of using a semi-transparent overlay)

[behrica]

I will experiment by using the above plot (density = ....) and plot to a png file. That I could read in again to make a raster layer which could then be overlayed with the tmap.

If I get the plot resolution and projections right, this should work. I let you know.

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. Just for the case that I want to add certain elements to the map whick are not foresean in tmap (ex. arbittray annotations/text). Not sure, if there could be something in tmap to help with this. So a type of integration of tmap with ggplot2.

[behrica]

I would like to create a map like this:

[behrica]

I agree that this ia a duplicate of the feature request: mtennekes/treemap#8.

[behrica]

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.

[Robinlovelace]

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

[mtennekes]

I think this can be done with the following approach:

For each level of some categorical variable (that determines the fill pattern):

1. select polygons with that level, and call it SPDF_poly
2. create a spatial lines/points dataframe SPDF_pat with the pattern of the same size as the bounding box of SPDF_poly
3. use rgeos::gIntersection to determine the intersection of SPDF_poly and SPDF_pat.

This procedure alone doesn't take much time to implement, but it takes some time to do the overhead. To-do list:

• Create new layer tm_pattern (or add an argument pattern to tm_fill)
• Add process_pattern and follow the rest of tmap's processing functions
• Create predefined shading patterns (for step 2)
• Implement the algorithm to generate a shading pattern
• Add new legend types for both portrait and landscape
• Extent the plot_map function

I'm short on time, and hope to submit the current version to CRAN soon. Any help is welcome of course.

[Robinlovelace]

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 tm_ functions I guess. Right?

[mtennekes]

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 create_patterns that takes three arguments: pattern type, scale, and aspect ratio.

[mtennekes]

We'd better start a new branch, say pattern, for this project.

[mcSamuelDataSci]

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:

[mtennekes]

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 sf and tmap 2.0. One of the main questions is still: how to draw (sf) polygons with a pattern, also in view mode.

[Robinlovelace]

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.

[mcSamuelDataSci]

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.

[SwampThingPaul]

A workaround, for the time being, might be HatchedPolygons. You ultimately make a separate shapefile with just lines.

library(HatchedPolygons);
library(tmap);
cal.gono #spatial polygon data frame;
cal.gono.hatch<-hatched.SpatialPolygons(cal.gono,density=0.001,angle=45);
proj4string(cal.gono.hatch)<-proj4string(cal.gono);

tm_shape(cal.gono)+tm_polygon()+tm_shape(cal.gono.hatch)+tm_lines(col="grey");

[mcSamuelDataSci]

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], : dim(X) must have a positive length

Any suggestions?

Thanks

[zross]

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?

[mtennekes]

Sure. I think these are the tasks:

1. Cast an sf polygon object (sfc_MULTIPOLYGON), say shp, to an sf pattern object. This object, say patt, should be an sfc_MULTILINESTRING. One approach to do this might be: a. Create a predefined dictionary of patterns. Each pattern is a stackable tile. (Later, we can allow users to specify their own patterns.) b. Write a function that generates a pattern rectangle (using the tiles from the dictionary) of the same size as the boundig box of shp. Let's call this object rect. (We could also skip step 1a and draw rect from scratch, but then it might be more difficult to allow custom patterns.) c. patt <- sf::st_intersection(rect, shp)
2. Embed it in tmap. This is a mainly a matter of administration, which I can do.

[zross]

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 st_make_grid() which would not allow flexibility in hatching type.

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 plot() function can handle this but not tmap apparently (?). So here I'm editing the GEOMETRYCOLLECTION pieces to drop any POINT geometry. Must be an easier way than this but...

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()

[mcSamuelDataSci]

Any updates on this? Sure looks promising!

[mtennekes]

That's a good direction. Instead of st_make_grid, we want to have more options. So what I was thinking with stackable tile was a tile like

[mtennekes]

To clarify: patt is a tile which is an sf object consisting of spatial lines (in the images above, the white lines). The object rect is an sf object that consists of patt objects that are stacked horizontally and vertically such that rect is a large canvas consisting of lines that has the same bounding box as shp.

Note that we do not have to do it this way: like I wrote, we could also create rect from scratch. The advantage of tile is, I think, that it is easier to create new patterns. Otherwise we would have to create a function like st_make_grid for each pattern.

Hope it's clear now. If not, please ask, preferable within this github issue.

[zross]

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 patt objects you describe.

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)

[mtennekes]

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 create_pattern <- function(bbox, size, type) that creates some pattern inside a bounding box. As described in my previous posts, we can use st_intersection to create patterns polygon-wise.

[zross]

@mtennekes I'm slowly working on this. Below is a create_line() function. I'm working on herringbone.

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)

[zross]

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)

[Nowosad]

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")

[Nowosad]

Another approach could be inspired by the patternLayer function (see a nice blog post by @dieghernan at https://dieghernan.github.io/201912-Beautiful3/).