4

Is there any way to check if a simple features geometry is contiguous in R? I'm creating some maps with ggplot2, which works fine with single-polygon contiguous units, in other words, countries with no islands or far-off territories. For example, Latvia works fine: enter image description here

But Portugal gets messy:

enter image description here

And countries with far-off territories are a disaster (this is the Netherlands): enter image description here

I'm guessing this is a problem with filtering the geometries for non-contiguous parts and then filling them separately. Is there a function somewhere that does this?

Edit with example of Portugal

(sorry, the images need to be downloaded separately, not 100% reproducible)

library(rnaturalearth)
library(rnaturalearthhires)
library(dplyr)
library(purrr)
library(tidyr)
library(scales)
library(magrittr)
library(png)
# > packageVersion("ggplot2")
# [1] ‘2.2.1.9000’
#devtools::install_github("tidyverse/ggplot2")
library(ggplot2)
library(sf) 
library(sp)


############ flag_fill function #############
flag_fill <- function(df){
  # establish boundaries; rescale to boundaries; filter into polygon
  # df must have columns 'geometry' and 'flag_image'
  df <- as_data_frame(df) %>% st_as_sf()

  # establish bounding boxes
  xmin <- map(df$geometry, st_bbox) %>% map_dbl("xmin")
  xmax <- map(df$geometry, st_bbox) %>% map_dbl("xmax")
  ymin <- map(df$geometry, st_bbox) %>% map_dbl("ymin")
  ymax <- map(df$geometry, st_bbox) %>% map_dbl("ymax")

  # check for alpha value
  alpha_check <- function(flag_image){
    if(dim(flag_image)[3] > 3) hasalpha <- TRUE else hasalpha <- FALSE
  }
  alph <- map_lgl(df$flag_image, alpha_check)

  # matrix of colours
  NumRow <- map_dbl(df$flag_image, function(x) dim(x)[1])
  NumCol <- map_dbl(df$flag_image, function(x) dim(x)[2])
  matrixList <- vector("list", nrow(df))
  matrixList <- mapply(matrix, matrixList, data = "#00000000", 
                       nrow = NumRow, ncol = NumCol, byrow = FALSE)

  matrixList <- map2(df$flag_image, alph, function(x, y) {
    rgb(x[,,1], x[,,2], x[,,3],
        ifelse(y, x[,,4], 1)
    ) %>% 
      matrix(ncol = dim(x)[2], nrow = dim(x)[1])
  })

  df_func <- function(DF){
    suppressWarnings(
      DF <- DF %>% 
        set_colnames(value = 1:ncol(.)) %>% 
        mutate(Y = nrow(.):1) %>% 
        gather(X, color, -Y) %>% 
        select(X, Y, color) %>%
        mutate(X = as.integer(X))
    )
    return(DF)
  }

  matrixList <- map(matrixList, as.data.frame)
  matrixList <- map(matrixList, df_func)
  # resize
  for(m in 1:length(matrixList)){
    matrixList[[m]]$X <- rescale(matrixList[[m]]$X, 
                                 to = c(xmin[[m]], xmax[[m]]))
    matrixList[[m]]$Y <- rescale(matrixList[[m]]$Y, 
                                 to = c(ymin[[m]], ymax[[m]]))
  }

  # filter into polygon
  latlonList <- map(df$geometry, st_coordinates)
  for(ll in 1:length(latlonList)){
    latlonList[[ll]] <- latlonList[[ll]][, 1:2]
  }
  poly_check <- function(x, y){
    x <- x[point.in.polygon(x$X, x$Y, 
                            y[, 1], 
                            y[, 2]
    ) %>% 
      as.logical, ]
    return(x)
  }
  matrixList <- Map(poly_check, matrixList, latlonList)

  # put back in dataframe:
  df <- df %>% 
    mutate(latlon = latlonList, plot_image = matrixList)

  return(df)
}

######## flag_plot function #############
flag_plot <- function(df){
  # takes a dataframe with column 'state' for country or state,
  # and plot_image, the result of flag_fill(), as well as 'color',
  # also the result of flag_fill()
  p <- ggplot() 
  df_list <- unique(df$state)
  for (i in seq_along(df_list)){
    DF <- df$plot_image[[i]]
    p <- p + geom_tile(data = DF,
                       aes(x = X, y = Y), 
                       fill = DF$color)
  }
  p + xlab(NULL) + ylab(NULL) +
    geom_sf(data = df, size = .2, alpha = 0.01) +
    theme(panel.background = element_blank(),
          panel.border = element_blank(),
          axis.text = element_blank(),
          panel.grid.major = element_line(colour = "white"), # hack from 
          #https://github.com/tidyverse/ggplot2/issues/2071
          axis.ticks = element_blank(),
          axis.line = element_blank())
}

######## data #########
globe <- countries10 %>% st_as_sf() %>% 
  filter(!is.na(ISO_A2)) %>% 
  select(state = SUBUNIT, iso = ISO_A2, continent = CONTINENT,
         region = SUBREGION, geometry) %>% 
  mutate(iso = tolower(iso))

####### images #########
# pngs can be downloaded from here: https://github.com/hjnilsson/country-flags
# using png image 250px as working directory 
country_list <- dir() %>% gsub("\\.png", '', .) %>% 
  .[which(!. %in% globe$iso)] %>% as_data_frame() %>% rename(iso = value)
globe <- left_join(globe, country_list) %>% 
  mutate(flag_image = list(array(NA, c(1, 1, 3))))
flags <- paste0(globe$iso, ".png")
for(i in 1:nrow(globe)){
  globe$flag_image[[i]] <- readPNG(source = flags[[i]])
}

######## plot: 
globe %>% filter(state %in% c("Portugal")) %>% 
  flag_fill() %>% 
  flag_plot()
1

1 Answer 1

6

The problem is not in sf, but in geom_tile(). When we have islands, we have many polygons, but this code is treating them as one single polygon.

You can fix that storing the group column in the latlonList

for(ll in 1:length(latlonList)){
    latlonList[[ll]] <- latlonList[[ll]][, c(1, 2, 4)]
}

and the poly_check() function to calculate the point in polygon inside the groups

  poly_check <- function(x, y) {

    island_list <- y %>% 
      as_tibble() %>% 
      group_by(L2) %>% 
      nest() %>% 
      pull(data)

    lists <- map(island_list, ~{
      y <- as.matrix(.x)
      x[point.in.polygon(x$X, x$Y, y[, 1], y[, 2]) %>% as.logical, ]
    })
    bind_rows(lists, .id = ".id")
  }

(I think this function can be simplified using do().

Finally, we need do add group = .id inside the geom_tile() function.

  for (i in seq_along(df_list)){
    DF <- df$plot_image[[i]]
    p <- p + geom_tile(data = DF, aes(x = X, y = Y, group = .id), 
                       fill = DF$color)
  }

The complete code is here

library(rnaturalearth)
library(rnaturalearthhires)
library(dplyr)
library(purrr)
library(tidyr)
library(scales)
library(magrittr)
library(png)
# > packageVersion("ggplot2")
# [1] ‘2.2.1.9000’
#devtools::install_github("tidyverse/ggplot2")
library(ggplot2)
library(sf) 
library(sp)


############ flag_fill function #############
flag_fill <- function(df){

  # establish boundaries; rescale to boundaries; filter into polygon
  # df must have columns 'geometry' and 'flag_image'
  df <- as_data_frame(df) %>% st_as_sf()

  # establish bounding boxes
  xmin <- map(df$geometry, st_bbox) %>% map_dbl("xmin")
  xmax <- map(df$geometry, st_bbox) %>% map_dbl("xmax")
  ymin <- map(df$geometry, st_bbox) %>% map_dbl("ymin")
  ymax <- map(df$geometry, st_bbox) %>% map_dbl("ymax")

  # check for alpha value
  alpha_check <- function(flag_image){
    if(dim(flag_image)[3] > 3) hasalpha <- TRUE else hasalpha <- FALSE
  }
  alph <- map_lgl(df$flag_image, alpha_check)

  # matrix of colours
  NumRow <- map_dbl(df$flag_image, function(x) dim(x)[1])
  NumCol <- map_dbl(df$flag_image, function(x) dim(x)[2])
  matrixList <- vector("list", nrow(df))
  matrixList <- mapply(matrix, matrixList, data = "#00000000", 
                       nrow = NumRow, ncol = NumCol, byrow = FALSE)

  matrixList <- map2(df$flag_image, alph, function(x, y) {
    rgb(x[,,1], x[,,2], x[,,3], ifelse(y, x[,,4], 1)) %>% 
      matrix(ncol = dim(x)[2], nrow = dim(x)[1])
  })

  df_func <- function(DF){
    suppressWarnings(
      DF <- DF %>% 
        set_colnames(value = 1:ncol(.)) %>% 
        mutate(Y = nrow(.):1) %>% 
        gather(X, color, -Y) %>% 
        select(X, Y, color) %>%
        mutate(X = as.integer(X))
    )
    return(DF)
  }

  matrixList <- map(matrixList, as.data.frame)
  matrixList <- map(matrixList, df_func)
  # resize
  for(m in 1:length(matrixList)){
    matrixList[[m]]$X <- rescale(matrixList[[m]]$X, to = c(xmin[[m]], xmax[[m]]))
    matrixList[[m]]$Y <- rescale(matrixList[[m]]$Y, to = c(ymin[[m]], ymax[[m]]))
  }

  # filter into polygon
  latlonList <- map(df$geometry, st_coordinates)



  for(ll in 1:length(latlonList)){
    latlonList[[ll]] <- latlonList[[ll]][, c(1, 2, 4)]
  }
  poly_check <- function(x, y) {

    island_list <- y %>% 
      as_tibble() %>% 
      group_by(L2) %>% 
      nest() %>% 
      pull(data)

    lists <- map(island_list, ~{
      y <- as.matrix(.x)
      x[point.in.polygon(x$X, x$Y, y[, 1], y[, 2]) %>% as.logical, ]
    })
    bind_rows(lists, .id = ".id")
  }
  matrixList <- Map(poly_check, matrixList, latlonList)

  # put back in dataframe:
  df <- df %>% 
    mutate(latlon = latlonList, plot_image = matrixList)

  return(df)
}

######## flag_plot function #############
flag_plot <- function(df){
  # takes a dataframe with column 'state' for country or state,
  # and plot_image, the result of flag_fill(), as well as 'color',
  # also the result of flag_fill()

  p <- ggplot() 
  df_list <- unique(df$state)

  for (i in seq_along(df_list)){
    DF <- df$plot_image[[i]]
    p <- p + geom_tile(data = DF, aes(x = X, y = Y, group = .id), 
                       fill = DF$color)
  }

  p + xlab(NULL) + ylab(NULL) +
    geom_sf(data = df, size = .2, alpha = 0.01) +
    theme(panel.background = element_blank(),
          panel.border = element_blank(),
          axis.text = element_blank(),
          panel.grid.major = element_line(colour = "white"), # hack from 
          #https://github.com/tidyverse/ggplot2/issues/2071
          axis.ticks = element_blank(),
          axis.line = element_blank())
}

######## data #########
globe <- countries10 %>% 
  st_as_sf() %>% 
  filter(!is.na(ISO_A2)) %>% 
  select(state = SUBUNIT, iso = ISO_A2, continent = CONTINENT,
         region = SUBREGION, geometry) %>% 
  mutate(iso = tolower(iso))

####### images #########
# pngs can be downloaded from here: https://github.com/hjnilsson/country-flags
# using png image 250px as working directory 
country_list <- dir() %>% 
  gsub("\\.png", '', .) %>% 
  .[which(!. %in% globe$iso)] %>% 
  as_data_frame() %>% 
  rename(iso = value)
globe <- left_join(globe, country_list) %>% 
  mutate(flag_image = list(array(NA, c(1, 1, 3))))
flags <- paste0(globe$iso, ".png")
for(i in 1:nrow(globe)) {
  globe$flag_image[[i]] <- readPNG(source = flags[[i]])
}

######## plot: 
globe %>% filter(state %in% c("Portugal")) %>% 
  flag_fill() %>% 
  flag_plot()

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.