Building Quadrants in Rshiny - r

I wanna build quadrants on my leaflet as part of my quadrat analysis. currently I have my tessalation object and im trying to draw the tiles on my leaflet. My code is below
library(spatstat)
library(leaflet)
firms_ppp <- ppp(x=cbd_points#coords[,1],y=cbd_points#coords[,2], window =
window)
qc <- quadratcount(firms_ppp)
qc.nu <- as.numeric(qc)
qc.tess <- as.tess(qc)
colorpal4 <- colorNumeric("red",c(min(qc.nu, na.rm = TRUE),max(qc.nu, na.rm = TRUE)))
for (j in 1:length(qc.tess$window$yrange)) {
for (i in 1:length(qc.tess$window$xrange[i])) {
leaflet() %>%
addRectangles(lng1 = qc.tess$window$xrange[i], lng2 = qc.tess$window$xrange[i+1],
lat1 = rev(qc.tess$window$yrange)[j], lat2 = rev(qc.tess$window$yrange)[j+1],
color = colorpal4(qc.nu[j+(i-1)*(length(qc.tess$window$yrange)-1)]),
popup = paste("<h3>",qc.nu[j+(i-1)*(length(qc.tess$window$yrange)-1)],"</h3>")
)
}
}
Any idea how I can build the quadrants? I tried with tiles as well but I cant seem to get it to work too! Pls Help!!

With 2 helping functions found here, which convert a Tesselation object into SpatialPolygons, you can achieve something like this:
library(spatstat)
library(leaflet)
library(sp)
## FUNCTIONS #####################
owin2Polygons <- function(x, id="1") {
stopifnot(is.owin(x))
x <- as.polygonal(x)
closering <- function(df) { df[c(seq(nrow(df)), 1), ] }
pieces <- lapply(x$bdry,
function(p) {
Polygon(coords=closering(cbind(p$x,p$y)),
hole=spatstat.utils::is.hole.xypolygon(p)) })
z <- Polygons(pieces, id)
return(z)
}
tess2SP <- function(x) {
stopifnot(is.tess(x))
y <- tiles(x)
nom <- names(y)
z <- list()
for(i in seq(y))
z[[i]] <- owin2Polygons(y[[i]], nom[i])
return(SpatialPolygons(z))
}
## DATA #####################
cbd_points <- data.frame(
long = runif(100,15,19),
lat = runif(100,40,50)
)
window <- owin(c(0,20), c(30,50))
firms_ppp <- ppp(x=cbd_points$long, y=cbd_points$lat, window = window)
qc <- quadratcount(firms_ppp)
qc.nu <- as.numeric(qc)
qc.tess <- as.tess(qc)
colorpal4 <- colorNumeric("red",c(min(qc.nu, na.rm = TRUE),max(qc.nu, na.rm = TRUE)))
PolyGrid <- tess2SP(qc.tess)
PolyGridDF <- SpatialPolygonsDataFrame(PolyGrid, data = data.frame(ID = 1:length(PolyGrid)), match.ID = F)
## SHINY ########################
library(shiny)
ui <- fluidPage(
leafletOutput("map")
)
server <- function(input, output, session) {
output$map <- renderLeaflet({
pal = colorFactor("viridis", as.character(PolyGridDF$ID))
leaflet() %>%
addTiles() %>%
addPolygons(data=PolyGridDF,
label = as.character(PolyGridDF$ID),
color = ~pal(as.character(PolyGridDF$ID)))
})
}
shinyApp(ui, server)

Related

I can't get get the DT package to work correctly on Rshiny

I'm currently working on an Rshiny webapp to use for some simple classification. Currently, I've been working on creating a table that contains the CCR and MCR of both the CART and LDA methods on the data. My aim is then to highlight the column of the MCR and CCR of the best method (the method with the highest CCR... or lowest MCR). I have ran the code and viewed that it works correctly using the Viewer Pane. However, when I load the app, I obtain the error 'data' must be 2-dimensional (e.g. data frame or matrix).
Here is my code:
data <- read.csv("Fatality-task2.csv")
data$Rate <- as.factor(data$Rate)
library(shiny)
library(dplyr)
library(ggplot2)
library(markdown)
library(gtsummary)
library(ggdendro)
library(factoextra)
library(mclust)
library(cluster)
library(rpart)
library(rpart.plot)
library(DT)
#library(MASS)
glimpse(data)
#################################################################
ui <- fluidPage(
navbarPage("",
tabPanel("Data Exploration",
sidebarLayout(
sidebarPanel(
selectInput("variable",
"Variable",
colnames(data)),
selectInput("rate",
"Rate",
levels(data$Rate))
),
mainPanel(
tableOutput("table"),
plotOutput("plot")
)
)
),
tabPanel("Classification tools",
sidebarLayout(
sidebarPanel(
sliderInput("train.prop",
"Training data proportion",
min = 0.4,
max = 0.8,
step = 0.1,
value = 0.6),
radioButtons("prune",
"Pruning option",
choices = c("view pruned tree",
"view unpruned tree"))
),
mainPanel(
DTOutput("table2"),
plotOutput("plot2")
)
)
)
)
)
#################################################################
server <- function(input, output) {
output$table <- renderTable({
req(input$variable,input$rate)
data <- data %>%
filter(Rate == input$rate) %>%
dplyr::select(input$variable) %>%
summary() %>%
as.data.frame() %>%
tidyr::separate(Freq, c("Stat", "Value"), sep=":") %>%
tidyr::pivot_wider(names_from =Stat, values_from = Value)
data <- data[, -c(1,2)]
})
output$plot <- renderPlot({
req(input$variable)
if (input$variable == "jaild" | input$variable == "Rate"){
ggplot(data, aes(x = Rate, fill = .data[[as.name(input$variable)]])) +
geom_bar(position = "dodge", width = 0.7) +
if (input$variable == "Rate"){
theme(legend.position = "none")
}
} else {
ggplot(data, aes(x = Rate, y = .data[[as.name(input$variable)]], fill = Rate)) +
geom_boxplot() +
theme(legend.position = "none")
}
})
output$plot2 <- renderPlot({
req(input$train.prop,input$prune)
set.seed(1234)
n <- nrow(data)
ind1 <- sample(c(1:n), round(n*as.numeric(input$train.prop)))
ind2 <- sample(c(1:n)[-ind1], length(c(1:n)[-ind1]))
train.data <- data[ind1,]
valid.data <- data[ind2,]
fit.tree <- rpart(Rate~., data = train.data, method = "class")
ptree <- prune(fit.tree, cp = fit.tree$cptable[which.min(fit.tree$cptable[,"xerror"]),"CP"])
if (input$prune == "view pruned tree"){
rpart.plot(ptree, uniform =TRUE)
} else {
rpart.plot(fit.tree)
}
})
output$table2 <- DT::renderDT({
library(MASS)
set.seed(1234)
n <- nrow(data)
ind1 <- sample(c(1:n), round(n*0.6))
#ind2 <- sample(c(1:n)[-ind1], length(c(1:n)[-ind1]))
ind2 <- setdiff(c(1:n), ind1)
train.data <- data[ind1,]
valid.data <- data[ind2,]
#################################
### fit cart model
fit.tree <- rpart(Rate~., data = train.data, method = "class")
### prune the tree
ptree <- prune(fit.tree, cp = fit.tree$cptable[which.min(fit.tree$cptable[,"xerror"]),"CP"])
### predict using the validation data on the pruned tree
pred <- predict(ptree, newdata = valid.data[,-6], type = "class")
### lda
#lda.model <- lda(train.data[,-6], train.data[,6])
lda.model <- lda(Rate~., data = train.data)
lda.pred <- predict(lda.model, newdata = valid.data[,-6])
### create a classification table
length(lda.model)
x <- pred == valid.data[,6]
CCR <- length(x[x == TRUE])/nrow(valid.data)
MCR <- 1 - CCR
CR <- c(CCR, MCR)
z <- lda.pred$class == valid.data[,6]
lda.CCR <- length(z[z == TRUE])/nrow(valid.data)
lda.MCR <- 1 - lda.CCR
lda.CR <- c(lda.CCR, lda.MCR)
y <- cbind(CR, lda.CR)
y <- as.data.frame(y)
colnames(y) <- c("CART", "LDA")
rownames(y) <- c("CCR", "MCR")
#y
DT::datatable(y, options=list(dom = "t")) %>%
formatRound(columns = c(1,2), digits = 6) %>%
formatStyle(columns = colnames(y[which.max(y[1,])]), background = "green")
#colnames(y[1])
#colnames(y[which.max(y[1,])])
},
rownames = TRUE)
}
?formatStyle
?formatRound()
#################################################################
shinyApp(ui, server)
and here is some of my data:
"beertax","jaild","vmiles","unrate","perinc","Rate"
1.53937947750092,"no",7.23388720703125,14.3999996185303,10544.15234375,1
1.78899073600769,"no",7.83634765625,13.6999998092651,10732.7978515625,1
1.71428561210632,"no",8.262990234375,11.1000003814697,11108.791015625,1
1.65254235267639,"no",8.7269169921875,8.89999961853027,11332.626953125,1
1.60990703105927,"no",8.952853515625,9.80000019073486,11661.5068359375,1
1.55999994277954,"no",9.1663017578125,7.80000019073486,11944,1
1.50144362449646,"no",9.6743232421875,7.19999980926514,12368.6240234375,1
0.214797139167786,"yes",6.81015673828125,9.89999961853027,12309.0693359375,1
0.206422030925751,"yes",6.58749462890625,9.10000038146973,12693.8076171875,1
0.296703308820724,"yes",6.70997021484375,5,13265.93359375,1
0.381355941295624,"yes",6.7712626953125,6.5,13726.6953125,1
0.371517032384872,"yes",8.1290078125,6.90000009536743,14107.3271484375,1
0.360000014305115,"yes",9.370654296875,6.19999980926514,14241,1
0.346487015485764,"yes",9.815720703125,6.30000019073486,14408.0849609375,1
0.650358021259308,"no",7.20850048828125,9.80000019073486,10267.302734375,1
0.67545872926712,"no",7.1759169921875,10.1000003814697,10433.486328125,1
0.598901093006134,"no",7.08481982421875,8.89999961853027,10916.4833984375,1
0.577330529689789,"no",7.25391796875,8.69999980926514,11149.3642578125,1
0.562435507774353,"no",7.4689990234375,8.69999980926514,11399.380859375,1
0.545000016689301,"no",7.66583056640625,8.10000038146973,11537,1
0.52454286813736,"no",8.02462548828125,7.69999980926514,11760.3466796875,1
0.107398569583893,"no",6.8586767578125,9.89999961853027,15797.1357421875,0
0.103211015462875,"no",7.21629150390625,9.69999980926514,15970.18359375,0
0.0989011004567146,"no",7.61917578125,7.80000019073486,16590.109375,0
0.0953389853239059,"no",7.87406689453125,7.19999980926514,16985.169921875,0
0.0928792580962181,"no",8.03491015625,6.69999980926514,17356.037109375,0
0.0900000035762787,"no",8.18063330078125,5.80000019073486,17846,0
0.0866217538714409,"no",8.531990234375,5.30000019073486,18049.0859375,0
0.214797139167786,"no",7.742841796875,7.69999980926514,15082.3388671875,1
0.206422030925751,"no",7.65606298828125,6.59999990463257,15131.880859375,1
0.197802200913429,"no",7.7078525390625,5.59999990463257,15486.8134765625,0
0.190677970647812,"no",8.09220947265625,5.90000009536743,15569.9150390625,0
0.185758516192436,"no",8.13137451171875,7.40000009536743,15616.0986328125,0
0.180000007152557,"no",8.18202783203125,7.69999980926514,15605,0
0.173243507742882,"no",8.3807685546875,6.40000009536743,15845.04296875,0
0.224343672394753,"no",6.4400537109375,6.90000009536743,17255.369140625,0
0.233563080430031,"no",6.57004296875,6,17744.265625,0
0.248010993003845,"no",6.68019287109375,4.59999990463257,18760.439453125,0
0.239078402519226,"yes",6.97921484375,4.90000009536743,19312.5,0
I know the code works properly - I just want it to be able to run properly on the app. Please help!

Smooth animation of axis change in R shiny plotly animation

I am writing a small shiny app to interactively display filtered data. I want to animate the transition in the data and in the axis bounds. No matter what I do I can't get the axis bounds to animate smoothly. Does anyone know how to do this?
# herd testing shiny app
version <- "v0.2"
library(shiny)
library(shinyjs)
library(readr)
library(dplyr)
library(stringr)
library(plotly)
library(purrr)
# notin function
"%notin%" <- function(x,y)!("%in%"(x,y))
# avoid as.numeric coercion warnings
as_numeric <- function(x, default=NA_real_){
suppressWarnings(if_else(is.na(as.numeric(x)), default, as.numeric(x)))
}
as_integer <- function(x, default=NA_integer_){
suppressWarnings(if_else(is.na(as.integer(x)), default, as.integer(x)))
}
# range including zero and handling NA
zrange <- function(x){
c(min(c(0, x), na.rm=TRUE), max(c(0, x), na.rm=TRUE))
}
# test data for reprex
data <- data.frame(
herd = rep(LETTERS, each=10),
year = rep(2010:2019, times=26),
count = sample(c(NA, 0:10), 260, TRUE),
percent = sample(c(NA, 0:10), 260, TRUE)/100
)
herds <- unique(data$herd)
herds1 <- sample(herds, 1)
# some colours
zzgreen <- "#69BE28"
zzblue <- "#009AA6"
ui <- fluidPage(
cat("run ui function\n"),
theme = shinythemes::shinytheme("spacelab"), # kinda similar to DairyNZ and plotly
align="center",
# https://www.w3schools.com/css/default.asp
fluidRow(
column(3,
strong("Select Herd:", style="font-size: 14px;"),
br(""),
textInput("herd", label="Enter Herd Code:", value=herds1)
),
column(9,
align="left",
strong("Herd Tests:", style="font-size: 14px;"),
plotlyOutput("count_plot", height="auto"),
strong("DNA Verified:", style="font-size: 14px;"),
plotlyOutput("perc_plot", height="auto")
)
),
fluidRow(
align="right",
em(version)
)
) # fluidPage
server <- function(input, output, session){
cat("run server function\n")
my <- reactiveValues(
herd = herds1,
frame = 0,
data = filter(data, herd==herds1),
speed = 500,
plist = list()
) # reactiveValues
observeEvent(input$herd, {
req(input$herd %in% herds)
my$herd <- input$herd
my$frame <- my$frame + 1
cat("new herd", input$herd, "new frame", my$frame, "calc plist\n")
# filter data
my$data <- data %>%
filter(herd==my$herd)
print(my$data)
# get existing list
pl <- my$plist
# herd test count data
pl[[1]] <- list(x=my$data$year,
y=my$data$count,
frame=my$frame,
name = "Herd Test Count",
showlegend=TRUE,
color=I(zzblue),
type="scatter",
mode="lines+markers")
# percent DNA verified data
pl[[2]] <- list(x=my$data$year,
y=my$data$percent*100,
frame=my$frame,
name = "Percent Verified",
showlegend=TRUE,
color=I(zzgreen),
type="scatter",
mode="lines+markers")
# https://plot.ly/r/multiple-axes/
# herd test count axis
pl[[3]] <- list(
title = list(text=my$herd),
xaxis=list(title=list(text="<b>Year</b>"),
tick0=min(my$data$year),
dtick=1,
range=range(my$data$year),
zeroline=FALSE,
type="linear"),
yaxis=list(title=list(text="<b>Herd Test Count</b>"),
zeroline=TRUE,
range=zrange(my$data$count),
type="linear"))
cat("range", zrange(my$data$count), "\n")
# percent DNA verified axis
pl[[4]] <- list(
xaxis=list(title=list(text="<b>Year</b>"),
tick0=min(my$data$year),
dtick=1,
range=range(my$data$year),
zeroline=FALSE,
type="linear"),
yaxis=list(title=list(text="<b>Percent Verified</b>"),
zeroline=TRUE,
range=zrange(my$data$percent*100),
type="linear"))
cat("range", zrange(my$data$percent*100), "\n")
# animation options
pl[[5]] <- list(frame=my$speed,
transition=my$speed,
redraw=FALSE,
mode="next")
pl[[6]] <- list(frame=0,
transition=0,
redraw=FALSE,
mode="next")
my$plist <- pl
})
output$count_plot <- renderPlotly({
cat("initial count_plot\n")
isolate({
# https://stackoverflow.com/questions/39019212/suppress-plotly-warnings-in-shiny-app
store_warn <- getOption("warn"); options(warn=-1)
pl <- my$plist
p <- plot_ly()
p <- do.call(add_trace, prepend(pl[[1]], list(p)))
p <- do.call(layout, prepend(pl[[3]], list(p)))
p <- do.call(animation_opts, prepend(pl[[5]], list(p)))
# restore warnings, delayed so plot is completed
shinyjs::delay(100, options(warn=store_warn))
p
})
}) # renderPlotly
count_plot_proxy <- plotlyProxy("count_plot", session=session)
output$perc_plot <- renderPlotly({
cat("initial perc_plot\n")
isolate({
# https://stackoverflow.com/questions/39019212/suppress-plotly-warnings-in-shiny-app
store_warn <- getOption("warn"); options(warn=-1)
pl <- my$plist
p <- plot_ly()
p <- do.call(add_trace, prepend(pl[[2]], list(p)))
p <- do.call(layout, prepend(pl[[4]], list(p)))
p <- do.call(animation_opts, prepend(pl[[5]], list(p)))
# restore warnings, delayed so plot is completed
shinyjs::delay(100, options(warn=store_warn))
p
})
}) # renderPlotly
perc_plot_proxy <- plotlyProxy("perc_plot", session=session)
observeEvent(my$herd, {
cat("new herd", my$herd, "update plots\n")
pl <- my$plist
# plotlyProxyInvoke(count_plot_proxy, "animate",
# list(
# name = as.character(my$frame),
# layout = pl[[3]]
# ),
# pl[[5]]
# )
plotlyProxyInvoke(count_plot_proxy, "animate",
list(
name = as.character(my$frame),
data = pl[1],
traces = as.list(as.integer(0)),
layout = pl[[3]]
),
pl[[5]]
)
# plotlyProxyInvoke(count_plot_proxy, "relayout",
# update = pl[3])
# plotlyProxyInvoke(perc_plot_proxy, "animate",
# list(
# name = as.character(my$frame),
# layout = pl[[4]]
# ),
# pl[[5]]
# )
plotlyProxyInvoke(perc_plot_proxy, "animate",
list(
name = as.character(my$frame),
data = pl[2],
traces = as.list(as.integer(0)),
layout = pl[[4]]
),
pl[[5]]
)
# plotlyProxyInvoke(count_plot_proxy, "relayout",
# update = pl[3])
}) # observeEvent
} # server
# run app
shinyApp(ui, server)
Thanks so much for your help, I am adding extra text here so that SO allows me to post this.

Ploting image in shiny R

I am starting to play with shinny apps and I am getting the following error when I try to run the code. The output$myrgb and output$mynrgvariables are not being ploted.
I think the issue is realted to the way I am closing the brackets but I have tried several alternatives and the issue is still happening.
Any idea?
library(shiny)
library(leaflet)
library(dbplyr)
library(raster)
library(rgdal)
ui<-fluidPage(
titlePanel("Calculation"),
"SHORT DESCRIPTION ---- ",
"Study area location",
textInput(inputId = "mypath", label = "Path to Sentinel images"),
leafletOutput("mymap",height = 1000),
imageOutput(outputId = "myrgb"),
imageOutput(outputId = "mynrg"),
imageOutput(outputId = "ndvi")
)
server<-function(input, output) {
output$mymap <- renderLeaflet({
m <- leaflet() %>%
addTiles() %>%
setView(lng=-60.143, lat=-19.9052, zoom=7)
m
# Load images
bands<-c("B((0[2348]_10m)).jp2$")
S2<-list.files(input$mypath, full.names = TRUE, pattern = ".SAFE")
S2<-list.files(S2, recursive = TRUE, full.names = TRUE, pattern=bands)
S2<-lapply(1:length(S2), function (x) {raster(S2[x])})
S2<-stack(S2)
utmcoor<-SpatialPoints(cbind(xmin(S2[[1]]),ymax(S2[[1]])), proj4string=CRS(proj4string(S2[[1]]))) # prepare UTM coordinates matrix
longlatcoor<-spTransform(utmcoor,CRS("+proj=longlat +datum=WGS84")) # converting
utmcoor2<-SpatialPoints(cbind(xmax(S2[[1]]),ymin(S2[[1]])), proj4string=CRS(proj4string(S2[[1]]))) # prepare UTM coordinates matrix abajo derecha
longlatcoor2<-spTransform(utmcoor2,CRS("+proj=longlat +datum=WGS84")) # converting
lng1<-xmin(longlatcoor) # extract coordinates to variable
lng2<-xmin(longlatcoor2)
lat1<-ymin(longlatcoor)
lat2<-ymin(longlatcoor2)
leaflet() %>% addTiles() %>% # Add coordinates to map
addRectangles(
lng1=lng1, lat1=lat1,
lng2=lng2, lat2=lat2,
fillColor = "transparent")
})
output$myrgb <- renderPlot({plotRGB(S2, r=3, g=2, b=1, scale=maxValue(S2[[1]]), stretch="lin")})
output$mynrg <- renderPlot({plotRGB(S2, r=4, g=3, b=2, scale=maxValue(S2[[1]]), stretch="lin")})
}
shinyApp( ui=ui, server=server)
EDIT ---
ERROR: object of type 'closure' is not subsettable
It's hard to help without your files. But you should do something like that. Use a reactive conductor to pass the raster object.
server<-function(input, output) {
Raster <- reactive({
bands <- c("B((0[2348]_10m)).jp2$")
S2 <- list.files(input$mypath, full.names = TRUE, pattern = ".SAFE")
S2 <- list.files(S2, recursive = TRUE, full.names = TRUE, pattern=bands)
S2 <- lapply(1:length(S2), function (x) {raster(S2[x])})
stack(S2)
})
output$mymap <- renderLeaflet({
m <- leaflet() %>%
addTiles() %>%
setView(lng=-60.143, lat=-19.9052, zoom=7)
S2 <- Raster()
utmcoor<-SpatialPoints(cbind(xmin(S2[[1]]),ymax(S2[[1]])), proj4string=CRS(proj4string(S2[[1]]))) # prepare UTM coordinates matrix
longlatcoor<-spTransform(utmcoor,CRS("+proj=longlat +datum=WGS84")) # converting
utmcoor2<-SpatialPoints(cbind(xmax(S2[[1]]),ymin(S2[[1]])), proj4string=CRS(proj4string(S2[[1]]))) # prepare UTM coordinates matrix abajo derecha
longlatcoor2<-spTransform(utmcoor2,CRS("+proj=longlat +datum=WGS84")) # converting
lng1<-xmin(longlatcoor) # extract coordinates to variable
lng2<-xmin(longlatcoor2)
lat1<-ymin(longlatcoor)
lat2<-ymin(longlatcoor2)
m %>% # Add coordinates to map
addRectangles(
lng1=lng1, lat1=lat1,
lng2=lng2, lat2=lat2,
fillColor = "transparent")
})
output$myrgb <- renderPlot({
S2 <- Raster()
plotRGB(S2, r=3, g=2, b=1, scale=maxValue(S2[[1]]), stretch="lin")
})
output$mynrg <- renderPlot({
S2 <- Raster()
plotRGB(S2, r=4, g=3, b=2, scale=maxValue(S2[[1]]), stretch="lin")
})
}

Drawing journey path using leaflet in R

I am creating a Shiny dashboard with a dataframe of start longitude/latitude and end longitude/latitude cooridnated that I have plotted in R using the leaflet package:
`m=leaflet()%>%
addTiles() %>%
addMarkers(lng=(data$Start_long[i:j]), lat=(data$Start_lat[i:j]),popup="Start") %>%
addCircleMarkers(lng=(data$End_long[i:j]), lat=(data$End_lat[i:j]),popup="End",clusterOptions=markerClusterOptions())`
I was wondering if there was a way to join the start and end coordinated by public transport routes (maybe through google maps API or in-library functions or failing that, join the coordinates by a straight line?
You can use my googleway package to both get the directions/routes, and plot it on a Google map
To use Google's API you need a valid key for each API you want to use. In this case you'll want a directions key, and for plotting the map you'll want a maps javascript key
(You can generate one key and enable it for both APIs if you wish)
To call the Directions API and plot it in R, you can do
library(googleway)
api_key <- "your_directions_api_key"
map_key <- "your_maps_api_key"
## set up a data.frame of locations
## can also use 'lat/lon' coordinates as the origin/destination
df_locations <- data.frame(
origin = c("Melbourne, Australia", "Sydney, Australia")
, destination = c("Sydney, Australia", "Brisbane, Australia")
, stringsAsFactors = F
)
## loop over each pair of locations, and extract the polyline from the result
lst_directions <- apply(df_locations, 1, function(x){
res <- google_directions(
key = api_key
, origin = x[['origin']]
, destination = x[['destination']]
)
df_result <- data.frame(
origin = x[['origin']]
, destination = x[['destination']]
, route = res$routes$overview_polyline$points
)
return(df_result)
})
## convert the results to a data.frame
df_directions <- do.call(rbind, lst_directions)
## plot the map
google_map(key = map_key ) %>%
add_polylines(data = df_directions, polyline = "route")
And similarly in a Shiny app
library(shiny)
library(shinydashboard)
library(googleway)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
textInput(inputId = "origin", label = "Origin"),
textInput(inputId = "destination", label = "Destination"),
actionButton(inputId = "getRoute", label = "Get Rotue"),
google_mapOutput("myMap")
)
)
server <- function(input, output){
api_key <- "your_directions_api_key"
map_key <- "your_maps_api_key"
df_route <- eventReactive(input$getRoute,{
print("getting route")
o <- input$origin
d <- input$destination
return(data.frame(origin = o, destination = d, stringsAsFactors = F))
})
output$myMap <- renderGoogle_map({
df <- df_route()
print(df)
if(df$origin == "" | df$destination == "")
return()
res <- google_directions(
key = api_key
, origin = df$origin
, destination = df$destination
)
df_route <- data.frame(route = res$routes$overview_polyline$points)
google_map(key = map_key ) %>%
add_polylines(data = df_route, polyline = "route")
})
}
shinyApp(ui, server)
You can addPolylines() to the map.
It takes two vectors as arguments, one for the lat and one for the lng, where each row is a 'waypoint'.
It's difficult to help you without knowing the structure of your data.
MRE:
library(leaflet)
cities <- read.csv(textConnection("
City,Lat,Long,Pop
Boston,42.3601,-71.0589,645966
Hartford,41.7627,-72.6743,125017
New York City,40.7127,-74.0059,8406000
Philadelphia,39.9500,-75.1667,1553000
Pittsburgh,40.4397,-79.9764,305841
Providence,41.8236,-71.4222,177994
"))
leaflet() %>%
addTiles() %>%
addPolylines(lat = cities$Lat, lng = cities$Long)
I use "for loop" to solve such problem,just draw polylines one by one.
(sorry for my Chinese expression ^_^)
for examply :
for(i in 1:nrow(sz)){
if(i<=nrow(sz) ){
a <- as.numeric(c(sz[i,c(8,10)]));
b <- as.numeric(c(sz[i,c(9,11)]));
A <- A %>% addPolylines(a,b,group=NULL,weight = 1,color = "brown",
stroke = TRUE,fill = NULL,opacity = 0.8)}
or like a more complex one
for(j in 0:23){if(j<=23)
#j--切每小时数据
j1 <- as.character(paste(j,"点",sep=''))
sz <- sz121[sz121$h==j,]
sz_4 <- sz121[sz121$bi_state==4 &sz121$h==j ,]
sz_8 <- sz121[sz121$bi_state==8&sz121$h==j,]
#还原A
A <- leaflet(sz121) %>% amap() %>% addLabelOnlyMarkers(~s_lon,~s_lat) %>%
addLegend(title=j1,colors=NULL,labels =NULL,position="topleft")
A <- A %>%addCircleMarkers(data=sz_8,~s_lon,~s_lat,color="orange",fill=TRUE,fillColor = "red", opacity = 1,fillOpacity=0.8,
weight =1,radius = 10) %>%addCircleMarkers(data=sz_4,~s_lon,~s_lat,color="black",fill=TRUE,fillColor = "red",
opacity = 1,fillOpacity=0.8,weight =5,radius = 10 ) %>%
addCircleMarkers(data=sz_8,~e_lon,~e_lat,color="orange",fill=TRUE,fillColor = "blue", opacity = 1,fillOpacity=0.8,weight=1,radius = 10) %>%
addCircleMarkers(data=sz_4,~e_lon,~e_lat,color="black",fill=TRUE,fillColor = "blue", opacity = 1,fillOpacity=0.8,weight =5,radius = 10 )
for(i in 1:nrow(sz)){
#i--画路径
if(i<=nrow(sz) ){
a <- as.numeric(c(sz[i,c(8,10)]));
b <- as.numeric(c(sz[i,c(9,11)]));
A <- A %>% addPolylines(a,b,group=NULL,weight = 1,color = "brown",stroke = TRUE,fill = NULL,opacity = 0.8)
}
if(i==nrow(sz)){print(A)}
}
Sys.sleep(3)
}

Best way to draw on leaflet map in R

I want to draw several things on a leaflet map (through Shiny/R)
I initialize the map like this
map = leaflet() %>% addProviderTiles("Stamen.TonerLite") %>% setView(-1.5, 53.4, 9)
output$myMap = renderLeaflet(map)
Then, depending on what is clicked in the App I ether want to draw Markers or a Polygon
sp <- reactiveValues()
ep <- reactiveValues()
area <- reactiveValues()
area$mp <- matrix(...) # empty matrix with 2 cols named lat/lng
observeEvent(input$map_click, {
coords <- input$map_click
if ( (!is.null(as.integer(input$button)) && (!is.null(coords))) ) {
if (as.integer(input$button) == 1) {
sp[["lat"]] <- coords$lat
sp[["lng"]] <- coords$lng
} else if (as.integer(input$button) == 2) {
ep[["lat"]] <- coords$lat
ep[["lng"]] <- coords$lng
} else if (as.integer(input$button) == 3) {
cm <- matrix(data = c(coords$lat, coords$lng), nrow = 1, ncol = 2)
area$mp <- rbind(area$mp, cm)
} else {
print("Kawum!")
}
})
What I cannot get into my head is how to draw something now on the leaflet map.
What is group ID, what is layer ID. Where comes leafletProxy into play?
How would I, depending on which if else statement kicks in, send the data to leaflet and add a marker or a polygon?
Any help or pointing into the right direction is highly appreciated!
Maybe this can clarify things:
library(shiny)
library(leaflet)
ui <- shinyUI(fluidPage(
actionButton("button", "Change style!"),
leafletOutput("myMap")
))
server <- function(input, output){
map = leaflet() %>% addProviderTiles("Stamen.TonerLite") %>% setView(-1.5, 53.4, 9)
output$myMap = renderLeaflet(map)
sp <- reactiveValues()
ep <- reactiveValues()
area <- reactiveValues()
observeEvent(sp$lat, {
leafletProxy("myMap") %>% addMarkers(lat = sp$lat, lng = sp$lng)
})
observeEvent(ep$lat, {
leafletProxy("myMap") %>% addCircles(lat = ep$lat, lng = ep$lng)
})
observeEvent(area$mp, {
leafletProxy("myMap") %>% addPolygons(lat = area$mp[ , 1], lng = area$mp[ , 2])
})
observeEvent(input$myMap_click, {
coords <- input$myMap_click
if ( (!is.null(input$button) && (!is.null(coords))) ) {
if (input$button %% 4 == 1) {
sp[["lat"]] <- coords$lat
sp[["lng"]] <- coords$lng
} else if (input$button %% 4 == 2) {
ep[["lat"]] <- coords$lat
ep[["lng"]] <- coords$lng
} else if (input$button %% 4 == 3) {
cm <- matrix(data = c(coords$lat, coords$lng), nrow = 1, ncol = 2)
area$mp <- if(!is.null(area$mp)){rbind(area$mp, cm)}else{cm}
} else {
print("Kawum!")
}
}
})
}
shinyApp(ui, server)
First thing, the click event needs to be named after the output element. So input$myMap_click gives you the coords. Second, the leaflet proxy is designed to draw points, things etc. into existing maps. Imagine you'd always re-render the map to do leaflet() %>% addMarkers(...). leafletProxy just needs the output element's name and draws the markers on top of it.
The code above shows some things you can do with that. E.g. using the polygons.
Try using it and comment, if there is something unclear.

Resources