I'm attempting to pro-grammatically add multiple vertical polylines of specific length to contiguous polygons in R. The number and length of the polylines should be specified by the user and can range from 1 to 8 polylines and 5000 to 10000 feet long per contiguous polygons. How can I achieve this in R?
I'm able to do this manually by the use of the mapedit package for a couple of polygons but I would like to automate the process for several thousand contiguous polygons.
# Load required libraries
library(mapedit)
library(mapview)
library(dplyr)
library(sp)
# Sample polygons and polylines
geometry = structure(list(structure(list(structure(c(8.769563, 8.769563,
8.770507, 8.770507, 8.769563, 50.815273, 50.815714, 50.815714,
50.815273, 50.815273), .Dim = c(5L, 2L))), class = c("XY", "POLYGON",
"sfg")), structure(list(structure(c(8.769568, 8.769568, 8.770507,
8.770507, 8.769568, 50.814852, 50.81527, 50.81527, 50.814852,
50.814852), .Dim = c(5L, 2L))), class = c("XY", "POLYGON", "sfg"
)), structure(list(structure(c(8.769568, 8.769568, 8.770502,
8.770502, 8.769568, 50.814412, 50.814849, 50.814849, 50.814412,
50.814412), .Dim = c(5L, 2L))), class = c("XY", "POLYGON", "sfg"
)), structure(list(structure(c(8.769568, 8.769568, 8.770502,
8.770502, 8.769568, 50.814005, 50.814408, 50.814408, 50.814005,
50.814005), .Dim = c(5L, 2L))), class = c("XY", "POLYGON", "sfg"
)), structure(list(structure(c(8.770502, 8.770502, 8.771301,
8.771301, 8.770502, 50.815273, 50.815717, 50.815717, 50.815273,
50.815273), .Dim = c(5L, 2L))), class = c("XY", "POLYGON", "sfg"
)), structure(list(structure(c(8.770518, 8.770518, 8.771301,
8.771301, 8.770518, 50.814852, 50.81527, 50.81527, 50.814852,
50.814852), .Dim = c(5L, 2L))), class = c("XY", "POLYGON", "sfg"
)), structure(list(structure(c(8.770507, 8.770507, 8.771301,
8.771301, 8.770507, 50.814408, 50.814849, 50.814849, 50.814408,
50.814408), .Dim = c(5L, 2L))), class = c("XY", "POLYGON", "sfg"
)), structure(list(structure(c(8.770507, 8.770507, 8.771296,
8.771296, 8.770507, 50.814005, 50.814405, 50.814405, 50.814005,
50.814005), .Dim = c(5L, 2L))), class = c("XY", "POLYGON", "sfg"
)), structure(c(8.769794, 8.769783, 50.814785, 50.814076), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(8.770051,
8.770035, 50.814785, 50.814069), .Dim = c(2L, 2L), class = c("XY",
"LINESTRING", "sfg")), structure(c(8.770271, 8.77026, 50.814781,
50.814076), .Dim = c(2L, 2L), class = c("XY", "LINESTRING", "sfg"
))), class = c("sfc_GEOMETRY", "sfc"), precision = 0, bbox = structure(c(xmin = 8.769563,
ymin = 50.814005, xmax = 8.771301, ymax = 50.815717), class = "bbox"), crs = structure(list(
epsg = 4326L, proj4string = "+proj=longlat +datum=WGS84 +no_defs"), class = "crs"), classes = c("POLYGON",
"POLYGON", "POLYGON", "POLYGON", "POLYGON", "POLYGON", "POLYGON",
"POLYGON", "LINESTRING", "LINESTRING", "LINESTRING"), n_empty = 0L)
# Visualize geometry
mapview(geometry)
I attempted to create regularly sampled points via the spsample function inside the polygons and connecting them by lines but was unsuccessful. appreciate any help I can get.
Here's one way to create lines given a polygon. It's probably not exactly what you want, since your request is quite specific, but hopefully the code is generic enough that you cn adapt it.
library(sf)
library(purrr)
polygon <- st_polygon(list(matrix(c(1,1,2,2,1,1,0,0,1,1), ncol = 2)))
# use polygon bounding box to o compute line parameters
bb <- st_bbox(polygon)
number_of_lines <- 5
line_length <- (bb[["ymax"]] - bb[["ymin"]]) / 1.2
y_offset <- bb[["ymin"]] + (bb[["ymax"]] - bb[["ymin"]] - line_length) / 2
# compute coordinates
xs <- seq(bb[["xmin"]], bb[["xmax"]], length.out = number_of_lines)
ys <- bb[["ymin"]] + line_length
# create a linestring
lines <- purrr::map2(xs, ys, ~st_linestring(matrix(c(.x, .x, .y,y_offset), ncol = 2))) %>% st_sfc(crs = st_crs(polygon))
# view
plot(polygon)
plot(lines, col = 2, add = TRUE)
Related
I have a map of multiple rivers, I want to add an ID column to the geometry dataframe adding a grouping variable defining each of the rivers. I only have the line geometry info, no other metadata, is this possible?
An example:
dat <- structure(list(geometry = structure(list(structure(c(169.023627307075,
169.02315299228, -45.3068517761089, -45.3081870363656), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(169.01854883529,
169.018930977689, 169.02315299228, -45.3083004691879, -45.3083134946477,
-45.3081870363656), .Dim = 3:2, class = c("XY", "LINESTRING",
"sfg")), structure(c(169.02315299228, 169.0330663306, -45.3081870363656,
-45.3144702778175), .Dim = c(2L, 2L), class = c("XY", "LINESTRING",
"sfg")), structure(c(169.015997396195, 169.022945130719, -45.3119974282578,
-45.3168289670259), .Dim = c(2L, 2L), class = c("XY", "LINESTRING",
"sfg")), structure(c(169.022945130719, 169.032555385154, -45.3168289670259,
-45.3163448854193), .Dim = c(2L, 2L), class = c("XY", "LINESTRING",
"sfg")), structure(c(169.01868555271, 169.022945130719, -45.3174947235968,
-45.3168289670259), .Dim = c(2L, 2L), class = c("XY", "LINESTRING",
"sfg"))), n_empty = 0L, crs = structure(list(input = "4326",
wkt = "GEOGCS[\"GCS_WGS_1984\",\n DATUM[\"WGS_1984\",\n SPHEROID[\"WGS_84\",6378137,298.257223563]],\n PRIMEM[\"Greenwich\",0],\n UNIT[\"Degree\",0.017453292519943295],\n AUTHORITY[\"EPSG\",\"4326\"]]"), class = "crs"), class = c("sfc_LINESTRING",
"sfc"), precision = 0, bbox = structure(c(xmin = 169.015997396195,
ymin = -45.3174947235968, xmax = 169.0330663306, ymax = -45.3068517761089
), class = "bbox"))), row.names = c(NA, 6L), class = c("sf",
"data.frame"), sf_column = "geometry", agr = structure(integer(0), .Label = c("constant",
"aggregate", "identity"), class = "factor"))
library(ggplot2)
library(sf)
ggplot() +
geom_sf(data = dat, size = 1) +
coord_sf()
In this trivial example there are two "rivers" but I don't have a way of identifying them in the dataframe. I want a column like:
dat$ID <- c("A", "A", "A", "B", "B", "B")
The only way I can think of is comparing coordinate values of line ends but this doesn't seem very efficient. Any help much appreciated.
Calculating cluster IDs, based on intersection, can be done with igraph as follows:
library(sf)
library(igraph)
dat <- structure(...)
# Detect clusters
m = st_intersects(dat, sparse = FALSE)
g = graph_from_adjacency_matrix(m)
dat$id = clusters(g)$membership
dat
## Simple feature collection with 6 features and 1 field
## geometry type: LINESTRING
## dimension: XY
## bbox: xmin: 169.016 ymin: -45.31749 xmax: 169.0331 ymax: -45.30685
## geographic CRS: WGS 84
## geometry id
## 1 LINESTRING (169.0236 -45.30... 1
## 2 LINESTRING (169.0185 -45.30... 1
## 3 LINESTRING (169.0232 -45.30... 1
## 4 LINESTRING (169.016 -45.312... 2
## 5 LINESTRING (169.0229 -45.31... 2
## 6 LINESTRING (169.0187 -45.31... 2
# Plot
plot(st_geometry(dat))
text(st_coordinates(st_centroid(dat)), as.character(dat$id))
I have a fairly simple problem where I want to create a gif which loops through departure_hour and colors the lines based on link volumes. One caveat is the number of rows between states (i.e. departure_hour) may be different.
Here is the code I am trying:
vol <- ggplot() +
geom_sf(data = test, aes(color=link_volume)) +
scale_color_distiller(palette = "OrRd", direction = 1) +
ggtitle("{frame_time}") +
transition_time(departure_hour) +
ease_aes("linear") +
enter_fade() +
exit_fade()
animate(vol, fps = 10, width = 750, height = 450)
However, when I do this I am getting the error:
Error in tween_state(as.data.frame(full_set$from), as.data.frame(full_set$to),:
identical(classes, col_classes(to)) is not TRUE
First, I do not understand if the error is referring to column classes or color classes? If it is color classes am I correct in assuming that the color scales between each plot may be different and that is the reason for this error?
Second, how do I fix this error? There seems to be just one more question on this issue and it has no solution.
Sample data:
> dput(head(test,5))
structure(list(linkid = c(12698L, 26221L, 36429L, 36430L, 47315L
), departure_hour = c(14, 19, 11, 0, 18), link_volume = c(500L,
1550L, 350L, 100L, 550L), geometry = structure(list(structure(c(1065088.71736072,
1065084.18813218, 1253892.13487564, 1253935.59094818), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(1060907.62521458,
1060984.50834787, 1237578.71728528, 1237818.59111698), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(1063031.34624456,
1062955.36965935, 1241210.04281066, 1241498.76584417), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(1063031.34624456,
1063034.73081084, 1241210.04281066, 1241198.98905491), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(1058112.52771678,
1058131.02887377, 1236388.96345761, 1236342.13157851), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg"))), class = c("sfc_LINESTRING",
"sfc"), precision = 0, bbox = structure(c(xmin = 1058112.52771678,
ymin = 1236342.13157851, xmax = 1065088.71736072, ymax = 1253935.59094818
), class = "bbox"), crs = structure(list(epsg = 5070L, proj4string = "+proj=aea +lat_1=29.5 +lat_2=45.5 +lat_0=23 +lon_0=-96 +x_0=0 +y_0=0 +ellps=GRS80 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"), class = "crs"), n_empty = 0L)), sf_column = "geometry", agr = structure(c(linkid = NA_integer_,
departure_hour = NA_integer_, link_volume = NA_integer_), .Label = c("constant",
"aggregate", "identity"), class = "factor"), row.names = c(NA,
5L), class = c("sf", "data.table", "data.frame"))
I have the following map of Mexico. It shows all of its municipalities and around 400 weather stations.
I want to create a 10km buffer around each station and eventually, associate each municipality to a station that is located within each radius.
The map and the stations are stored on separate sf objects. I tired the following:
buffers <- st_buffer(stations, dist = 1)
I thought the dist argument was set to kilometers, so I tried dist = 10. Unfortunately, this returned HUGE buffers for each station. That's why I am using dist = 1, but even these buffers are as big as a state! This question, suggests I transform my stations to Irish Grid, but I couldn't replicate the accepted answer. I am now wondering what unit the dist argument is set to.
From the aforementioned question, I assume it's set to degrees. How can I set a 10km buffer around each station?
Additional info:
My CRS is set to 4326 on both objects (the Mexican map and the stations).
This is my stations data:
> dput(head(stations))
structure(list(station_number = c(1004L, 1005L, 1008L, 1012L,
1017L, 1018L), station_alt = c(1925, 1844, 2323, 1589, 2172,
2053), month = c(9L, 9L, 9L, 9L, 9L, 9L), Mean_min = c(11.6,
12.75, 12.25, 13.9666666666667, 12.9, 12.6833333333333), Mean_max = c(26.9333333333333,
26.85, 24.0833333333333, 29.0333333333333, 24.8666666666667,
26.1333333333333), months_observed = c(5L, 5L, 5L, 5L, 5L, 5L
), geometry = structure(list(structure(c(-102.199, 22.001), class = c("XY",
"POINT", "sfg")), structure(c(-102.372, 21.781), class = c("XY",
"POINT", "sfg")), structure(c(-102.135, 22.203), class = c("XY",
"POINT", "sfg")), structure(c(-102.802, 21.794), class = c("XY",
"POINT", "sfg")), structure(c(-102.444, 22.233), class = c("XY",
"POINT", "sfg")), structure(c(-102.415, 22.141), class = c("XY",
"POINT", "sfg"))), class = c("sfc_POINT", "sfc"), precision = 0, bbox = structure(c(xmin = -102.802,
ymin = 21.781, xmax = -102.135, ymax = 22.233), class = "bbox"), crs = structure(list(
epsg = NA_integer_, proj4string = NA_character_), class = "crs"), n_empty = 0L)), sf_column = "geometry", agr = structure(c(station_number = NA_integer_,
station_alt = NA_integer_, month = NA_integer_, Mean_min = NA_integer_,
Mean_max = NA_integer_, months_observed = NA_integer_), .Label = c("constant",
"aggregate", "identity"), class = "factor"), row.names = c(NA,
6L), class = c("sf", "data.frame"))
Your coordinates are long/lat, so the distance will be in degrees. You should first project to a spatial reference in meter units and then take 10 000 meters.
The manual of st_buffer says this about the dist argument:
in case dist is a units object, it should be convertible to
arc_degree if x has geographic coordinates, and to st_crs(x)$units
otherwise
If you leave the coordinates in 4326 you should be able to take something like 0.1 which should be about 11 km for Mexico, but you will see a warning message:
In st_buffer.sfc(st_geometry(x), dist, nQuadSegs, endCapStyle =
endCapStyle, : st_buffer does not correctly buffer
longitude/latitude data
So first convert to another projection (in meter) and enter the distance in meters. This should work, which uses EPSG 7801:
library(sf)
pois <- st_as_sf(stations)
st_crs(pois) <- 4326
pois <- st_transform(pois, crs = 7801)
plot(st_geometry(pois))
buff <- st_buffer(pois, dist = 10000)
plot(st_geometry(buff), add = TRUE)
Control with leaflet and the measure tool:
buff <- st_transform(buff, crs = 4326)
library(leaflet)
leaflet() %>%
addTiles() %>%
addMeasure(primaryLengthUnit = "meters") %>%
addMarkers(data = pois) %>%
addPolygons(data = buff)
I am trying to provide extra information in a table below a plotly map using event_data.
I found this: https://community.plot.ly/t/how-to-return-the-same-event-data-information-for-selected-points-even-after-modifying-the-data/5847. A good example using ggplot by adding the key column to the aes:
ggplot(mtcars, aes(mpg, wt, col = I(col), key = key))
But how can I add a key column to a scattergl plotly map in order for the key popping up in the event_data? Any help would be greatly appreciated.
R Shiny code:
library(plotly)
library(shiny)
ui <- fluidPage(
plotlyOutput("plot"),
verbatimTextOutput("event")
)
server <- function(input, output, session) {
#df sample using dput
df <- structure(list(col_group = structure(1:8, .Label = c("1", "2",
"3", "4", "5", "6", "7", "8"), class = "factor"), color = structure(c(4L,
6L, 7L, 8L, 5L, 3L, 2L, 1L), .Label = c("#1A9850", "#66BD63",
"#A6D96A", "#D73027", "#D9EF8B", "#F46D43", "#FDAE61", "#FEE08B"
), class = "factor"), geometry = structure(list(structure(c(4.52343199617246,
4.52324233358547, 4.52267342343957, 4.52224662532908, 4.52210428346744,
4.52200925015845, 4.52192088448668, 4.52180475361204, 4.52172945325391,
4.52168196905882, 4.5215535740952, 4.52095980475523, 4.52076420632298,
4.52062274547478, 51.9453195440486, 51.9453722803981, 51.945526317454,
51.9456480852256, 51.9456928353329, 51.9457296098645, 51.9457705951341,
51.9458530114811, 51.945914910501, 51.9459312169901, 51.9459510896027,
51.9459966849614, 51.9460077291392, 51.9460066867221), .Dim = c(14L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(4.4964540696277,
4.49696710232736, 51.9086692611627, 51.9084484303039), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(4.13635479859532,
4.13644010080625, 51.975098751212, 51.9751715711302), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(4.47801457239531,
4.47834576882542, 51.9300740588744, 51.9304218318716), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(4.45974369011875,
4.46029492493512, 4.46033964902157, 51.9290774018138, 51.9284345596986,
51.9283809798498), .Dim = 3:2, class = c("XY", "LINESTRING",
"sfg")), structure(c(4.43886518844695, 4.43891013390463, 4.43910559159559,
4.43913561800293, 51.93455577157, 51.9344932127658, 51.9341891712133,
51.9341444695365), .Dim = c(4L, 2L), class = c("XY", "LINESTRING",
"sfg")), structure(c(4.54844667292407, 4.55002805772657, 51.9658870347267,
51.9661409927825), .Dim = c(2L, 2L), class = c("XY", "LINESTRING",
"sfg")), structure(c(4.47522875290306, 4.47598748813623, 51.9347985281278,
51.9353886781931), .Dim = c(2L, 2L), class = c("XY", "LINESTRING",
"sfg"))), class = c("sfc_LINESTRING", "sfc"), precision = 0, bbox = structure(c(xmin = 4.13635479859532,
ymin = 51.9084484303039, xmax = 4.55002805772657, ymax = 51.9751715711302
), class = "bbox"), crs = structure(list(epsg = 4326L, proj4string = "+proj=longlat +datum=WGS84 +no_defs"), class = "crs"), n_empty = 0L),
key = c("1", "8000", "10000", "12000", "14000", "16000",
"18000", "22000")), row.names = c(1L, 8000L, 10000L, 12000L,
14000L, 16000L, 18000L, 22000L), class = c("sf", "data.frame"
), sf_column = "geometry", agr = structure(c(col_group = NA_integer_,
color = NA_integer_, key = NA_integer_), .Label = c("constant",
"aggregate", "identity"), class = "factor"))
#plotly
output$plot <- renderPlotly({
plot_geo(df, type = "scattergl", mode = "lines",
color = ~col_group, colors = rev(RColorBrewer::brewer.pal(8, name = "RdYlGn"))
)
})
#event_data
output$event <- renderPrint({
d <- event_data("plotly_click")
if (is.null(d)) "Click events appear here (double-click to clear)" else {
df_select <- df %>% tibble::rownames_to_column() %>% filter(col_group==d$curveNumber-7) %>% filter(row_number()==d$pointNumber+1)
browser()
print(df_select)
}
})
}
shinyApp(ui, server)
Solved using customdata and updated plotly package. Perhaps of use for someone else:
library(plotly)
library(shiny)
ui <- fluidPage(
plotlyOutput("plot"),
verbatimTextOutput("event")
)
server <- function(input, output, session) {
#df sample using dput
df <- structure(list(col_group = structure(1:8, .Label = c("1", "2",
"3", "4", "5", "6", "7", "8"), class = "factor"), color = structure(c(4L,
6L, 7L, 8L, 5L, 3L, 2L, 1L), .Label = c("#1A9850", "#66BD63",
"#A6D96A", "#D73027", "#D9EF8B", "#F46D43", "#FDAE61", "#FEE08B"
), class = "factor"), geometry = structure(list(structure(c(4.52343199617246,
4.52324233358547, 4.52267342343957, 4.52224662532908, 4.52210428346744,
4.52200925015845, 4.52192088448668, 4.52180475361204, 4.52172945325391,
4.52168196905882, 4.5215535740952, 4.52095980475523, 4.52076420632298,
4.52062274547478, 51.9453195440486, 51.9453722803981, 51.945526317454,
51.9456480852256, 51.9456928353329, 51.9457296098645, 51.9457705951341,
51.9458530114811, 51.945914910501, 51.9459312169901, 51.9459510896027,
51.9459966849614, 51.9460077291392, 51.9460066867221), .Dim = c(14L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(4.4964540696277,
4.49696710232736, 51.9086692611627, 51.9084484303039), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(4.13635479859532,
4.13644010080625, 51.975098751212, 51.9751715711302), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(4.47801457239531,
4.47834576882542, 51.9300740588744, 51.9304218318716), .Dim = c(2L,
2L), class = c("XY", "LINESTRING", "sfg")), structure(c(4.45974369011875,
4.46029492493512, 4.46033964902157, 51.9290774018138, 51.9284345596986,
51.9283809798498), .Dim = 3:2, class = c("XY", "LINESTRING",
"sfg")), structure(c(4.43886518844695, 4.43891013390463, 4.43910559159559,
4.43913561800293, 51.93455577157, 51.9344932127658, 51.9341891712133,
51.9341444695365), .Dim = c(4L, 2L), class = c("XY", "LINESTRING",
"sfg")), structure(c(4.54844667292407, 4.55002805772657, 51.9658870347267,
51.9661409927825), .Dim = c(2L, 2L), class = c("XY", "LINESTRING",
"sfg")), structure(c(4.47522875290306, 4.47598748813623, 51.9347985281278,
51.9353886781931), .Dim = c(2L, 2L), class = c("XY", "LINESTRING",
"sfg"))), class = c("sfc_LINESTRING", "sfc"), precision = 0, bbox = structure(c(xmin = 4.13635479859532,
ymin = 51.9084484303039, xmax = 4.55002805772657, ymax = 51.9751715711302
), class = "bbox"), crs = structure(list(epsg = 4326L, proj4string = "+proj=longlat +datum=WGS84 +no_defs"), class = "crs"), n_empty = 0L),
key = c("1", "8000", "10000", "12000", "14000", "16000",
"18000", "22000")), row.names = c(1L, 8000L, 10000L, 12000L,
14000L, 16000L, 18000L, 22000L), class = c("sf", "data.frame"
), sf_column = "geometry", agr = structure(c(col_group = NA_integer_,
color = NA_integer_, key = NA_integer_), .Label = c("constant",
"aggregate", "identity"), class = "factor"))
#plotly
output$plot <- renderPlotly({
plot_geo(df, type = "scattergl", mode = "lines",
customdata = ~key,
color = ~col_group, colors = rev(RColorBrewer::brewer.pal(8, name = "RdYlGn"))
)
})
#event_data
output$event <- renderPrint({
d <- event_data("plotly_click")
if (is.null(d)) "Click events appear here (double-click to clear)" else {
df_select <- df[df$key %in% d$customdata,]
print(df_select)
}
})
}
shinyApp(ui, server)
I have a region with sub regions. For each sub region I have a simple ggplot, that I want to put into the center of each region.
I am using a leaflet package, so my code looks like this:
employees_spdf <- structure(list(ID = structure(c(7L, 8L, 4L, 3L, 10L, 1L, 9L,
6L, 2L, 5L), .Label = c("75006", "78280", "91370", "92110", "92420",
"93270", "93440", "95000", "95330", "95400"), class = "factor"),
n = c(10L, 79L, 99L, 16L, 55L, 94L, 25L, 40L, 51L, 44L),
geometry = structure(list(structure(c(2.423864, 48.95034085
), class = c("XY", "POINT", "sfg")), structure(c(2.05650642,
49.0277569), class = c("XY", "POINT", "sfg")), structure(c(2.30575224,
48.90353573), class = c("XY", "POINT", "sfg")), structure(c(2.25171264,
48.75044317), class = c("XY", "POINT", "sfg")), structure(c(2.4076232,
49.00203584), class = c("XY", "POINT", "sfg")), structure(c(2.33267081,
48.84896818), class = c("XY", "POINT", "sfg")), structure(c(2.32290084,
49.02966528), class = c("XY", "POINT", "sfg")), structure(c(2.53124065,
48.938607), class = c("XY", "POINT", "sfg")), structure(c(2.07605224,
48.77307843), class = c("XY", "POINT", "sfg")), structure(c(2.16026445,
48.84105162), class = c("XY", "POINT", "sfg"))), class = c("sfc_POINT",
"sfc"), precision = 0, bbox = structure(c(xmin = 2.05650642,
ymin = 48.75044317, xmax = 2.53124065, ymax = 49.02966528
), class = "bbox"), crs = structure(list(epsg = 4326L, proj4string = "+proj=longlat
+datum=WGS84 +no_defs"), class = "crs"), n_empty = 0L)), sf_column = "geometry", agr
= structure(c(ID = NA_integer_,
n = NA_integer_), .Label = c("constant", "aggregate", "identity"
), class = "factor"), row.names = c(380L, 433L, 312L, 257L, 464L,
6L, 457L, 364L, 156L, 341L), class = c("sf", "data.frame"))
getImage <- function(n, ncol=10, proba = 1) {
require(ggthemes)
require(ggplot2)
require(dplyr)
num <- 1:n
x <- num%%ncol
y <- num%/%ncol
df <- data.frame(x=x,y=y)
df[nrow(df),] <- c(0,0)
df <- df %>% arrange(y,x)
df$dispo <- as.factor(c(rep(1,round(n*proba)),rep(0,(n-round(n*proba)))))
ymax <- ifelse(n>ncol*10,n/ncol+1,ncol+1)
#if we have a few points, let's center them
if (n< ncol*10) df$y <- df$y + (ncol-(max(df$y)))/2
g<- ggplot(df,aes(x=x,y=y, color=dispo))+
# geom_point(shape="\UC6C3", colour="red",size=5)+
geom_point(size=10,show.legend = F)+
xlim(-1,ncol+1) + ylim(-1,ymax)+
theme_void()+
scale_fill_manual(values = c("green", "red"))
g
}
plots <- lapply(employees_spdf$n,function(x) getImage(x,proba = .66))
for (i in 1:nrow(employees_spdf)) {
filename <- paste("./tmp/",employees_spdf[i,]$ID,".png",sep="")
ggsave(filename = filename,
plot = plots[[i]],
device = "png",
width = 5, height = 5,
units = "in", bg="transparent")}
filenames <- unlist(lapply(employees_spdf$ID, function(x) paste(paste("./tmp/",x,".png",sep=""))))
empIcons <- icons(
iconUrl = filenames,
iconWidth = 128,
iconHeight = 128
)
leaflet() %>%
addTiles() %>%
addMarkers(data=employees_spdf,
icons=empIcons)
The bottleneck here is eventually a need to save each ggplot as a file, read it and then use it as an icon. For 500+ subregions it takes quite a while to load...
The core of the issue as far as I undesrtand is that a leaflet MakeIcon function can work only whith files and I cannot pass a list of ggplot objects to it. That way it would have worked much faster I believe...
The solution here could be saving a ggplot for each region before the application loads and read them on the fly, however I thought there might be a more elegant option. Do you know one?