How to rotate 3D Plotly continuous for R shiny App - r

I am trying to create a constant rotating 3D scatter plotly so that I can put it in my R shiny app. However, I can't seem to get it to constantly rotate (like this: https://codepen.io/etpinard/pen/mBVVyE).
I don't want to save it to an image/gif just directly use in my App. Can anyone provide any help to get it continuously rotating (I have little experience with Python)? I've tried this in the Viewer screen of R studio, but it doesn't rotate there.
library(plotly)
library(ggplot2)
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N,min= 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x,y,z)
for (i in seq(0,100, by=0.1)){
cam.zoom = 2
ver.angle = 0
graph <- plot_ly()%>%
add_trace(type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~x,
y = ~y,
z = ~z) %>%
layout(scene = list(
camera = list(
eye = list(
x = cos(i)*cam.zoom,
y = sin(i)*cam.zoom,
z = 0.3
),
center = list(
x = 0,
y = 0,
z = 0
)
)
)
)
graph
}
I am very new to plotly, so any help would be greatly appreciated.

We can reuse most of the JS code via htmlwidgets::onRender. You tagged the question shiny - wrapped it in an app accordingly:
library(shiny)
library(plotly)
library(htmlwidgets)
ui <- fluidPage(
plotlyOutput("graph")
)
server <- function(input, output, session) {
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N, min = 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x, y, z)
output$graph <- renderPlotly({
plot_ly(
type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~ x,
y = ~ y,
z = ~ z
) %>%
layout(scene = list(camera = list(
eye = list(
x = 1.25,
y = 1.25,
z = 1.25
),
center = list(x = 0,
y = 0,
z = 0)
))) %>%
onRender("
function(el, x){
var id = el.getAttribute('id');
var gd = document.getElementById(id);
Plotly.update(id).then(attach);
function attach() {
var cnt = 0;
function run() {
rotate('scene', Math.PI / 180);
requestAnimationFrame(run);
}
run();
function rotate(id, angle) {
var eye0 = gd.layout[id].camera.eye
var rtz = xyz2rtz(eye0);
rtz.t += angle;
var eye1 = rtz2xyz(rtz);
Plotly.relayout(gd, id + '.camera.eye', eye1)
}
function xyz2rtz(xyz) {
return {
r: Math.sqrt(xyz.x * xyz.x + xyz.y * xyz.y),
t: Math.atan2(xyz.y, xyz.x),
z: xyz.z
};
}
function rtz2xyz(rtz) {
return {
x: rtz.r * Math.cos(rtz.t),
y: rtz.r * Math.sin(rtz.t),
z: rtz.z
};
}
};
}
")
})
}
shinyApp(ui, server)
The same can be done via plotlyProxy without additional JS - but it's not as smooth:
library(shiny)
library(plotly)
ui <- fluidPage(
plotlyOutput("graph")
)
server <- function(input, output, session) {
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N, min = 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x, y, z)
mySequence <- seq(0, 100, by = 0.1)
cam.zoom = 2
# ver.angle = 0
output$graph <- renderPlotly({
plot_ly(
type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~ x,
y = ~ y,
z = ~ z
) %>%
layout(scene = list(camera = list(
eye = list(
x = cos(mySequence[1]) * cam.zoom,
y = sin(mySequence[1]) * cam.zoom,
z = 0.3
),
center = list(x = 0,
y = 0,
z = 0)
)))
})
myPlotlyProxy <- plotlyProxy("graph")
count <- reactiveVal(1L)
observe({
invalidateLater(100)
plotlyProxyInvoke(myPlotlyProxy, "relayout", list(scene = list(camera = list(
eye = list(
x = cos(mySequence[isolate(count())]) * cam.zoom,
y = sin(mySequence[isolate(count())]) * cam.zoom,
z = 0.3
),
center = list(x = 0,
y = 0,
z = 0)
))))
isolate(count(count()+1))
if(count() > length(mySequence)){
count(1L)
}
})
}
shinyApp(ui, server)

Related

Plot_ly rotate animation in R

I am trying to animate a 3D figure being rotated around an axis and print that as a .gif or video format. Could not find a resource to assist, please point me in the right direction. Any input is appreciated. Example figure below:
library(plotly)
x <- iris$Sepal.Length
y <- iris$Sepal.Width
z <- iris$Petal.Length
test3d <- plot_ly(type = "scatter3d", mode = "markers",
x=x, y=y, z=z)
This is taken from my earlier answer here.
We can use the code without shiny and save a standalone HTML file via htmlwidgets::saveWidget:
library(plotly)
library(htmlwidgets)
library(utils)
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N, min = 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x, y, z)
fig <- plot_ly(
type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~ x,
y = ~ y,
z = ~ z
) %>%
layout(scene = list(camera = list(
eye = list(
x = 1.25,
y = 1.25,
z = 1.25
),
center = list(x = 0,
y = 0,
z = 0)
))) %>%
onRender("
function(el, x){
var id = el.getAttribute('id');
var gd = document.getElementById(id);
Plotly.update(id).then(attach);
function attach() {
var cnt = 0;
function run() {
rotate('scene', Math.PI / 180);
requestAnimationFrame(run);
}
run();
function rotate(id, angle) {
var eye0 = gd.layout[id].camera.eye
var rtz = xyz2rtz(eye0);
rtz.t += angle;
var eye1 = rtz2xyz(rtz);
Plotly.relayout(gd, id + '.camera.eye', eye1)
}
function xyz2rtz(xyz) {
return {
r: Math.sqrt(xyz.x * xyz.x + xyz.y * xyz.y),
t: Math.atan2(xyz.y, xyz.x),
z: xyz.z
};
}
function rtz2xyz(rtz) {
return {
x: rtz.r * Math.cos(rtz.t),
y: rtz.r * Math.sin(rtz.t),
z: rtz.z
};
}
};
}
")
htmlwidgets::saveWidget(partial_bundle(fig), file = "rotate_scatter3d.HTML", selfcontained = TRUE)
utils::browseURL("rotate_scatter3d.HTML")

How to set showing space in plotly

Is there any way to set the view and axes so that in my plotly animated 3D graph I can see a specific space and in this space the graph is moving? I'm trying to do an animation which shows how a detector works but right now when i play my animation the view and axes change along with the graph. I know that I can change the range of the axis but somehow it didn't change anything in my output or maybe i was doing something wrong.
Here is my code:
library(plotly)
Sx <- matrix()
Sy <- matrix()
Sz <- matrix()
N <- 360
u = seq(0, pi/2, length.out = 30)
w = seq(0, 2*pi, length.out = N)
datalist = list()
for (i in 1:N) {
Sx = cos(u) * cos(w[i])
Sy = cos(u) * sin(w[i])
Sz = sin(u)
df <- data.frame(Sx, Sy, Sz, t=i)
datalist[[i]] <- df
}
data = do.call(rbind, datalist)
plot_ly(data, x=~Sx, y =~Sy, z=~Sz, frame=~t, type = 'scatter3d', mode = 'lines')
Welcome to stackoverflow!
I'm not sure if I correctly understand your question. However, I think you are looking for a combination of range and aspectratio.
Please check the following:
library(plotly)
Sx <- matrix()
Sy <- matrix()
Sz <- matrix()
N <- 360
u = seq(0, pi/2, length.out = 30)
w = seq(0, 2*pi, length.out = N)
datalist = list()
for (i in 1:N) {
Sx = cos(u) * cos(w[i])
Sy = cos(u) * sin(w[i])
Sz = sin(u)
df <- data.frame(Sx, Sy, Sz, t=i)
datalist[[i]] <- df
}
data = do.call(rbind, datalist)
plot_ly(data, x=~Sx, y =~Sy, z=~Sz, frame=~t, type = 'scatter3d', mode = 'lines') %>%
layout(scene = list(xaxis = list(nticks = 5, range = c(-1, 1)),
yaxis = list(nticks = 5, range = c(-1, 1)),
zaxis = list(nticks = 5, range = c(-1, 1)),
aspectmode='manual',
aspectratio = list(x=1, y=1, z=1)
)) %>% animation_opts(frame = 100)
For further informarion please see this.

SIR model in Rstudio shiny

I´m trying to build the basic SIR model in Rstudio shiny. The model takes 2 parameters (beta = infection rate/day, gamma = recovery date/day), 3 initial values (S = numbers of susceptibles, I = infectious, R = recovered) and last variable is time (in days).
Here is the code of it just in R markdown:
library(deSolve)
sir_equations <- function(time, variables, parameters) {
with(as.list(c(variables, parameters)), {
dS <- -beta * I * S
dI <- beta * I * S - gamma * I
dR <- gamma * I
return(list(c(dS, dI, dR)))
})
}
parameters_values <- c(
beta = 0.05, # infectious rate/day
gamma = 0.5 # recovery rate/day
)
initial_values <- c(
S = 1000, # susceptibles
I = 1, # infectious
R = 0 # recovered (immune)
)
time_values <- seq(0, 10) #number of days (0-10)
sir_values_1 <- ode(
y = initial_values,
times = time_values,
func = sir_equations,
parms = parameters_values
)
sir_values_1 <- as.data.frame(sir_values_1) # convert to data frame
with(sir_values_1, {
plot(time, S, type = "l", col = "blue",
xlab = "period (days)", ylab = "number of people")
lines(time, I, col = "red")
lines(time, R, col = "green")
})
legend("right", c("susceptibles", "infectious", "recovered"),
col = c("blue", "red", "green"), lty = 1, bty = "n")
Now I want to add this into R shiny, where the user can input the beta, gamma and days value (sliderbar, or just input), then it will plot the result. I´m pretty new to R and tried some variations here, like putting the user input into ,,UI,, the calculating into ,,server,, then combine it in like this shinyApp(ui = ui, server = server). This code below I tried, but its not working. Can you guys help me, what I´m doing wrong, and what to follow to be able to put the code into R shiny?
library(deSolve)
library(shiny)
ui <- fluidPage(
sliderInput(inputId = "time_values", label = "Dny", value = 10, min = 1, max = 100),
sliderInput(inputId = "beta", label ="Míra nákazy", value = 0.05, min = 0.00, max = 1, step = 0.01),
sliderInput(inputId = "gamma", label ="Míra uzdravení", value = 0.5, min = 0.00, max = 1, step = 0.1),
plotOutput("plot")
)
server <- function(input, output) {
sir_equations <- function(time, variables, parameters) {
with(as.list(c(variables, parameters)), {
dS <- -beta * I * S
dI <- beta * I * S - gamma * I
dR <- gamma * I
return(list(c(dS, dI, dR)))
})
}
initial_values <- c(S = 1000, I = 1, R = 0)
sir_values_1 <- ode(
y = initial_values,
times = time_values,
func = sir_equations,
parms = parameters_values
)
output$plot <- renderPlot({
plot(rnorm(input$time_values))
plot(rnorm(input$beta))
plot(rnorm(input$gamma))
})
}
shinyApp(ui = ui, server = server)
Thanks
Michal
I guess it is something like this you want?
library(deSolve)
library(shiny)
ui <- fluidPage(
sliderInput(inputId = "time_values", label = "Dny", value = 10, min = 1, max = 100),
sliderInput(inputId = "beta", label ="Míra nákazy", value = 0.05, min = 0, max = 1, step = 0.01),
sliderInput(inputId = "gamma", label ="Míra uzdravení", value = 0.5, min = 0, max = 1, step = 0.1),
plotOutput("plot")
)
server <- function(input, output) {
sir_equations <- function(time, variables, parameters) {
with(as.list(c(variables, parameters)), {
dS <- -beta * I * S
dI <- beta * I * S - gamma * I
dR <- gamma * I
return(list(c(dS, dI, dR)))
})
}
initial_values <- c(S = 1000, I = 1, R = 0)
sir_values_1 <- reactiveValues(val = data.frame())
observe({
sir_values_1$val <- as.data.frame(ode(
y = initial_values,
times = seq(0, input$time_values),
func = sir_equations,
parms = c(beta=input$beta, gamma=input$gamma)
))
})
output$plot <- renderPlot({
with(sir_values_1$val, {
plot(sir_values_1$val$time, sir_values_1$val$S, type = "l", col = "blue",
xlab = "period (days)", ylab = "number of people")
lines(sir_values_1$val$time, sir_values_1$val$I, col = "red")
lines(sir_values_1$val$time, sir_values_1$val$R, col = "green")
legend("right", c("susceptibles", "infectious", "recovered"),
col = c("blue", "red", "green"), lty = 1, bty = "n")
})
})
}
shinyApp(ui = ui, server = server)
Here another solution without the need of an observer function. More about deSolve and shiny at: https://tpetzoldt.github.io/deSolve-shiny/deSolve-shiny.html
library("deSolve")
sir_equations <- function(time, variables, parameters) {
with(as.list(c(variables, parameters)), {
dS <- -beta * I * S
dI <- beta * I * S - gamma * I
dR <- gamma * I
return(list(c(dS, dI, dR)))
})
}
ui <- fluidPage(
sliderInput(inputId = "time_values", label = "Dny", value = 10, min = 1, max = 100),
sliderInput(inputId = "beta", label ="Míra nákazy", value = 0.05, min = 0.00, max = 1, step = 0.01),
sliderInput(inputId = "gamma", label ="Míra uzdravení", value = 0.5, min = 0.00, max = 1, step = 0.1),
plotOutput("plot")
)
server <- function(input, output) {
output$plot <- renderPlot({
initial_values <- c(S = 1000, I = 1, R = 0)
sir_values <- ode(
y = initial_values,
times = seq(0, input$time_values, length.out=1000),
func = sir_equations,
parms = c(beta=input$beta, gamma=input$gamma)
)
## easiest is to use the deSolve plot function
#plot(sir_values, mfrow=c(1,3))
## but you can also do it with own plot functions, e.g.:
matplot(sir_values[,1], sir_values[,-1], type="l", xlab="time", ylab="S, I, R")
legend("topright", col=1:3, lty=1:3, legend=c("S", "I", "R"))
})
}
shinyApp(ui = ui, server = server)
Just look at the error:
Warning: Error in ode: objet 'time_values' introuvable
In ode(), you should replace time_values by input$time_values and put the full ode() function in a reactive environment since you use some inputs:
sir_values_1 <- reactive({
ode(
y = initial_values,
times = input$time_values,
func = sir_equations,
parms = parameters_values
)
})
Then you have some errors in your plot but setting xlim and ylim should make it work. However, if you want to display multiple plots, you must define several plotOutput and renderPlot. Putting three plot in one renderPlot will not display the three of them but only the last one.

plotting 3D playes in R, anyone can look through the code

I hope anyone can help me :)
Write this code including shiny, but at the end it doesnt work the way I want it to.
If anyone can look through that code an tell me why the plot isnt working ?
You will see that there is an error at the end.
Ok first why istn the rgl window implemented into the GUI ?
Second how can I plot the 3D in bigger cube ?
If I dont open a 3D plot wihtout data it doesnt plot it at all :(
library(shiny)
library(rgl)
library(shinythemes)
library(devtools)
#install_github("rgl", "trestletech", "js-class")
#install_github("rgl", "trestletech", "js-class")
#######################################################################################
# User Interface #
#######################################################################################
ui <- fluidPage(theme = shinytheme("slate"),
#shinythemes::themeSelector(), # <--- Add this somewhere in the UI
headerPanel("Block Theory 0.1"),
sidebarPanel(
numericInput(inputId = "dd", label = "Dip direction:", value = "", width = "80%", min = 0, max = 360),
numericInput(inputId = "fa", label = "Fracture angle:", value = "", width = "80%", min = 0, max = 90),
numericInput(inputId = "position_x", label = "Position:", value = "", width = "40%"),
numericInput(inputId = "position_y", label = "", value = "", width = "40%"),
selectInput("form", "Form:",
c("Circle", "Square", "Ellipsoid")),
actionButton(inputId = "add", label = "Add a plane"),
actionButton(inputId = "plotbutton", label = "Update")
),
mainPanel(
plotOutput(outputId = "plot")
),
verbatimTextOutput(outputId = "log_planes")
)
#######################################################################################
# SERVER #
#######################################################################################
server <- function(input, output) {
data_planes <- data.frame()
makeReactiveBinding("data_planes")
observe({
input$add
isolate({
data_planes <<- rbind(data_planes, data.frame(input$dd, input$fa , input$position_x , input$position_y))
data_planes <<- na.omit(data_planes)
})
})
output$plot <- renderRglwidget({
# try(rgl.close())
input$plotbutton
isolate({
#######################################################################################
# Open 3d plot:
x<-sample(1:100, 100)
y<-sample(1:100, 100)
z<-sample(1:100, 100)
plot3d(x, y, z, type = "n",xlim = c(-10, 10), ylim = c(-10, 10), zlim = c(-30, 30))
#######################################################################################
while (i <= nrow(data_planes)) {
phi <- data_planes[i,1] * pi / 180
deta <- data_planes[i,2] * pi / 180
Px <- data_planes[i,3]
Py <- data_planes[i,4]
Pz <- 0
n <- c(-sin(deta)*sin(phi), sin(deta) * cos(phi), -cos(deta))
T <- matrix(c(cos(deta)*cos(phi), sin(deta), cos(deta)*sin(phi), -sin(deta)*cos(phi), cos(deta), -sin(deta)*sin(phi), -sin(phi), 0 , cos(phi)), nrow=3,ncol = 3, byrow = TRUE)
P_new <- T %*% c(Px,Py,Pz)
P_n <- -P_new %*% n # d = -P * n
# planes3d() plots equation: a*x + b*y + c*z + d = 0
a <- -sin(deta)*sin(phi)
b <- sin(deta) * cos(phi)
c <- -cos(deta)
d <- P_n
cols<-rgb(runif(5),runif(5),runif(5)) #random color genarator
planes3d(a, b, c , d , col = cols, alpha = 1.0)
i <- i + 1
}
})
})
output$log_planes <- renderPrint({na.omit(data_planes)})
}
#######################################################################################
shinyApp(ui = ui, server = server)
There are few mistakes in your app:
Firstly, in your ui instead of plotOutput(outputId = "plot") it should be rglwidgetOutput(outputId = "plot").
Secondly, you wont be able to plot in a loop and also you need to give rglwidget(). Just for demonstration purpose I have altered your server code by removing the loop. Have a look:
server <- function(input, output) {
data_planes <- data.frame()
makeReactiveBinding("data_planes")
observe({
input$add
isolate({
data_planes <<- rbind(data_planes, data.frame(input$dd, input$fa , input$position_x , input$position_y))
data_planes <<- na.omit(data_planes)
})
})
output$plot <- renderRglwidget({
# try(rgl.close())
input$plotbutton
# isolate({
#######################################################################################
# Open 3d plot:
x<-sample(1:100, 100)
y<-sample(1:100, 100)
z<-sample(1:100, 100)
plot3d(x, y, z, type = "n",xlim = c(-10, 10), ylim = c(-10, 10), zlim = c(-30, 30))
#######################################################################################
i=1;
# while (i <= nrow(data_planes)) {
phi <- data_planes[i,1] * pi / 180
deta <- data_planes[i,2] * pi / 180
Px <- data_planes[i,3]
Py <- data_planes[i,4]
Pz <- 0
n <- c(-sin(deta)*sin(phi), sin(deta) * cos(phi), -cos(deta))
T <- matrix(c(cos(deta)*cos(phi), sin(deta), cos(deta)*sin(phi), -sin(deta)*cos(phi), cos(deta), -sin(deta)*sin(phi), -sin(phi), 0 , cos(phi)), nrow=3,ncol = 3, byrow = TRUE)
P_new <- T %*% c(Px,Py,Pz)
P_n <- -P_new %*% n # d = -P * n
# planes3d() plots equation: a*x + b*y + c*z + d = 0
a <- -sin(deta)*sin(phi)
b <- sin(deta) * cos(phi)
c <- -cos(deta)
d <- P_n
cols<-rgb(runif(5),runif(5),runif(5)) #random color genarator
i <- i + 1
# }
planes3d(a, b, c , d , col = cols, alpha = 1.0)
rglwidget()
# })
})
output$log_planes <- renderPrint({na.omit(data_planes)})
}
The output you see from this code is:
EDIT:
To plot more than 1 plot at a time and adjust the x, y and z limits you can use this server code:
server <- function(input, output) {
data_planes <- data.frame()
makeReactiveBinding("data_planes")
observe({
input$add
isolate({
data_planes <<- rbind(data_planes, data.frame(input$dd, input$fa , input$position_x , input$position_y))
data_planes <<- na.omit(data_planes)
})
})
output$plot <- renderRglwidget({
# try(rgl.close())
input$plotbutton
# isolate({
#######################################################################################
# Open 3d plot:
x<-sample(1:100, 100)
y<-sample(1:100, 100)
z<-sample(1:100, 100)
plot3d(x, y, z, type = "n",xlim = c(min(x), max(x)), ylim = c(min(y), max(y)), zlim = c(min(z), max(z)))
####################################################
i=1;
while (i <= nrow(data_planes)) {
phi <- data_planes[i,1] * pi / 180
deta <- data_planes[i,2] * pi / 180
Px <- data_planes[i,3]
Py <- data_planes[i,4]
Pz <- 0
n <- c(-sin(deta)*sin(phi), sin(deta) * cos(phi), -cos(deta))
T <- matrix(c(cos(deta)*cos(phi), sin(deta), cos(deta)*sin(phi), -sin(deta)*cos(phi), cos(deta), -sin(deta)*sin(phi), -sin(phi), 0 , cos(phi)), nrow=3,ncol = 3, byrow = TRUE)
P_new <- T %*% c(Px,Py,Pz)
P_n <- -P_new %*% n # d = -P * n
# planes3d() plots equation: a*x + b*y + c*z + d = 0
a <- -sin(deta)*sin(phi)
b <- sin(deta) * cos(phi)
c <- -cos(deta)
d <- P_n
cols<-rgb(runif(5),runif(5),runif(5)) #random color genarator
i <- i + 1
planes3d(a, b, c , d , col = cols, alpha = 1.0)
}
rglwidget()
# })
})
output$log_planes <- renderPrint({na.omit(data_planes)})
}

Calculate, decode and plot routes on map using leaflet and R

I have raw data which consists of lattitude and longitude of places The sample data is as follows:
EDIT (dput):
structure(list(Lat = c(-33.9409444, -33.9335713, -33.9333906,
-33.9297826), Lon = c(18.5001774, 18.5033218, 18.518719, 18.5209372
)), .Names = c("Lat", "Lon"), row.names = c(NA, 4L), class = "data.frame")
I want to plot routes on the map using this data. This is my R code:
library(RODBC)
library(leaflet)
ui <- fluidPage(
titlePanel("South Africa & Lesotho"),
mainPanel(
leafletOutput("mymap")
)
)
server <- function(input, output, session) {
dbhandle <- odbcDriverConnect('driver={SQL Server};server=localhost\\SQLEXpress;database=OSM;trusted_connection=true')
res <- sqlQuery(dbhandle, 'select Lat, Lon from OSM2 where Street is not null')
output$mymap <- renderLeaflet({
leaflet(res) %>%
addTiles() %>%
addPolylines(lat = ~Lat, lng = ~Lon)
})
}
shinyApp(ui, server)
However, all I get is this:
How can I use leaflet and R to plot the routes using the raw data (lat, long)?
What you have to do:
Import the points
Calculate all routes between the points (I use OSRM)
Extract the route geometry from the routes (Appreciate the reference and have a look there for the speed updates!). Thanks to #SymbolixAU: You can also use googleway::decode_pl() or gepaf::decodePolyline()
Display everything on a map (I use leaflet)
My approach is not optimized for anything, but it should do the job...
(It is script in RStudio, therefore the print() statements after leaflet.)
library(leaflet)
library(stringr)
library(bitops)
df <- structure(list(
lat = c(-33.9409444, -33.9335713, -33.9333906, -33.9297826),
lng = c(18.5001774, 18.5033218, 18.518719, 18.5209372)),
.Names = c("lat", "lng"),
row.names = c(NA, 4L), class = "data.frame")
nn <- nrow(df)
# Functions
# =========
viaroute <- function(lat1, lng1, lat2, lng2) {
R.utils::evalWithTimeout({
repeat {
res <- try(
route <- rjson::fromJSON(
file = paste("http://router.project-osrm.org/route/v1/driving/",
lng1, ",", lat1, ";", lng2, ",", lat2,
"?overview=full", sep = "", NULL)))
if (class(res) != "try-error") {
if (!is.null(res)) {
break
}
}
}
}, timeout = 1, onTimeout = "warning")
return(res)
}
decode_geom <- function(encoded) {
scale <- 1e-5
len = str_length(encoded)
encoded <- strsplit(encoded, NULL)[[1]]
index = 1
N <- 100000
df.index <- 1
array = matrix(nrow = N, ncol = 2)
lat <- dlat <- lng <- dlnt <- b <- shift <- result <- 0
while (index <= len) {
# if (index == 80) browser()
shift <- result <- 0
repeat {
b = as.integer(charToRaw(encoded[index])) - 63
index <- index + 1
result = bitOr(result, bitShiftL(bitAnd(b, 0x1f), shift))
shift = shift + 5
if (b < 0x20) break
}
dlat = ifelse(bitAnd(result, 1),
-(result - (bitShiftR(result, 1))),
bitShiftR(result, 1))
lat = lat + dlat;
shift <- result <- b <- 0
repeat {
b = as.integer(charToRaw(encoded[index])) - 63
index <- index + 1
result = bitOr(result, bitShiftL(bitAnd(b, 0x1f), shift))
shift = shift + 5
if (b < 0x20) break
}
dlng = ifelse(bitAnd(result, 1),
-(result - (bitShiftR(result, 1))),
bitShiftR(result, 1))
lng = lng + dlng
array[df.index,] <- c(lat = lat * scale, lng = lng * scale)
df.index <- df.index + 1
}
geometry <- data.frame(array[1:df.index - 1,])
names(geometry) <- c("lat", "lng")
return(geometry)
}
map <- function() {
m <- leaflet() %>%
addTiles(group = "OSM") %>%
addProviderTiles("Stamen.TonerLite") %>%
addLayersControl(
baseGroups = c("OSM", "Stamen.TonerLite")
)
return(m)
}
map_route <- function(df, my_list) {
m <- map()
m <- addCircleMarkers(map = m,
lat = df$lat,
lng = df$lng,
color = "blue",
stroke = FALSE,
radius = 6,
fillOpacity = 0.8) %>%
addLayersControl(baseGroups = c("OSM", "Stamen.TonerLite")) %>%
{
for (i in 1:length(my_list)) {
. <- addPolylines(., lat = my_list[[i]]$lat, lng = my_list[[i]]$lng, color = "red", weight = 4)
}
return(.)
}
return(m)
}
# Main
# ======
m <- map()
m <- m %>% addCircleMarkers(lat = df$lat,
lng = df$lng,
color = "red",
stroke = FALSE,
radius = 10,
fillOpacity = 0.8)
print(m)
my_list <- list()
r <- 1
for (i in 1:(nn-1)) {
for (j in ((i+1):nn)) {
my_route <- viaroute(df$lat[i], df$lng[i],df$lat[j], df$lng[j])
geom <- decode_geom(my_route$routes[[1]]$geometry)
my_list[[r]] <- geom
r <- r + 1
}
}
print(map_route(df, my_list))
Result:
In the end, you have to put all that in your shiny server...
I hope that helps!
Another more efficient way to calculate routes between points is with the osrm package: Interface Between R and the OpenStreetMap-Based Routing Service OSRM. Look at this example:
library(osrm)
library(leaflet)
df = data.frame(com = c("A", "B", "C"),
lon = c(31.043515, 31.029080, 31.002896),
lat = c(-29.778562, -29.795506, -29.836168),
time = as.POSIXct(c("2020-03-18 07:56:59","2020-03-18 12:28:58","2020-03-18 18:24:52")))
trips <- osrmTrip(df, returnclass="sf")
trip <- trips[[1]]$trip
leaflet(trip) %>%
addProviderTiles("Stamen.TonerLite", group = "OSM") %>%
addPolylines() %>%
addCircleMarkers(lat = df$lat,
lng = df$lon,
popup = paste(df$com,"-",format(df$time,"%H:%M:%S")),
color = "red",
stroke = FALSE,
radius = 8,
fillOpacity = 0.8)
For the viaroute function created.
Use "R.utils::withTimeout" instead of "R.utils::evalWithTimeout" because that is now defunct.
I hope this helps
#Christoph's code is fantastic - although some of the functions no longer work as originally written, presumably due to breaking changes in R over time.
As #user7779697 points out above, the viaroute() function needs be updated to accommodate code changes to R.utils that saw deprecation of evalWithTimeout, replacing it with withTimeout as follows:
R.utils::withTimeout()
I also ran into issues with the map_route() function, corrected by removing the braces from the internal for loop.
I've pasted the full updated code below which works with R Version 4.2.1 - I take no credit for this excellent work, only to get it back up and running with version changes:
library(leaflet)
library(stringr)
library(bitops)
df <- structure(list(
lat = c(-33.9409444, -33.9335713, -33.9333906, -33.9297826),
lng = c(18.5001774, 18.5033218, 18.518719, 18.5209372)),
.Names = c("lat", "lng"),
row.names = c(NA, 4L), class = "data.frame")
nn <- nrow(df)
# Functions
# =========
viaroute <- function(lat1, lng1, lat2, lng2) {
R.utils::withTimeout({
repeat {
res <- try(
route <- rjson::fromJSON(
file = paste("http://router.project-osrm.org/route/v1/driving/",
lng1, ",", lat1, ";", lng2, ",", lat2,
"?overview=full", sep = "", NULL)))
if (class(res) != "try-error") {
if (!is.null(res)) {
break
}
}
}
}, timeout = 1, onTimeout = "warning")
return(res)
}
decode_geom <- function(encoded) {
scale <- 1e-5
len = str_length(encoded)
encoded <- strsplit(encoded, NULL)[[1]]
index = 1
N <- 100000
df.index <- 1
array = matrix(nrow = N, ncol = 2)
lat <- dlat <- lng <- dlnt <- b <- shift <- result <- 0
while (index <= len) {
# if (index == 80) browser()
shift <- result <- 0
repeat {
b = as.integer(charToRaw(encoded[index])) - 63
index <- index + 1
result = bitOr(result, bitShiftL(bitAnd(b, 0x1f), shift))
shift = shift + 5
if (b < 0x20) break
}
dlat = ifelse(bitAnd(result, 1),
-(result - (bitShiftR(result, 1))),
bitShiftR(result, 1))
lat = lat + dlat;
shift <- result <- b <- 0
repeat {
b = as.integer(charToRaw(encoded[index])) - 63
index <- index + 1
result = bitOr(result, bitShiftL(bitAnd(b, 0x1f), shift))
shift = shift + 5
if (b < 0x20) break
}
dlng = ifelse(bitAnd(result, 1),
-(result - (bitShiftR(result, 1))),
bitShiftR(result, 1))
lng = lng + dlng
array[df.index,] <- c(lat = lat * scale, lng = lng * scale)
df.index <- df.index + 1
}
geometry <- data.frame(array[1:df.index - 1,])
names(geometry) <- c("lat", "lng")
return(geometry)
}
map <- function() {
m <- leaflet() %>%
addTiles(group = "OSM") %>%
addProviderTiles("Stamen.TonerLite") %>%
addLayersControl(
baseGroups = c("OSM", "Stamen.TonerLite")
)
return(m)
}
map_route <- function(df, my_list) {
m <- map()
m <- addCircleMarkers(map = m,
lat = df$lat,
lng = df$lng,
color = "blue",
stroke = FALSE,
radius = 6,
fillOpacity = 0.8) %>%
addLayersControl(baseGroups = c("OSM", "Stamen.TonerLite"))
for (i in 1:length(my_list)) {
m <- addPolylines(map = m, lat = my_list[[i]]$lat, lng = my_list[[i]]$lng, color = "red", weight = 4)
}
return(m)
}
# Main
# ======
m <- map()
m <- m %>% addCircleMarkers(lat = df$lat,
lng = df$lng,
color = "red",
stroke = FALSE,
radius = 10,
fillOpacity = 0.8)
print(m)
my_list <- list()
r <- 1
for (i in 1:(nn-1)) {
for (j in ((i+1):nn)) {
my_route <- viaroute(df$lat[i], df$lng[i],df$lat[j], df$lng[j])
geom <- decode_geom(my_route$routes[[1]]$geometry)
my_list[[r]] <- geom
r <- r + 1
}
}
print(map_route(df, my_list))

Resources