Related
I wrote down this function for MLE estimation and then I apply it for different settings of parameters.
Finally, I bind all results for an output.
But is not working i have problem with the output and also I need to organize the output like the attached image using R program.
enter image description here
could some one help me please?
What should I fix and how can I print the results like the picture attached.
thank you in advance
rbssn<- function(n,alpha,beta)
{
if(!is.numeric(n)||!is.numeric(alpha)||!is.numeric(beta))
{stop("non-numeric argument to mathematical function")}
if(alpha<=0){ stop("alpha must be positive")}
if(beta<=0) { stop("beta must be positive") }
z <- rnorm(n,0,1)
r <- beta*((alpha*z*0.5)+sqrt((alpha*z*0.5)^2+1))^2
return(r)
}
#Function
mymle <- function(n,alpha,beta,rep)
{
theta=c(alpha,beta) # store starting values
#Tables
LHE=array(0, c(2,rep));
rownames(LHE)= c("MLE_alpha", "MLE_beta")
#Bias
bias= array(0, c(2,rep));
rownames(bias)= c("bias_alpha", "bias_beta")
#Simulation
set.seed(1)
#Loop
for(i in 1:rep){
myx <- exp(-rbssn(n, alpha, beta))
Score <- function(x) {
y <- numeric(2)
y[1] <- (-n/x[1])*(1+2/(x[1]^2)) - (1/(x[2]*x[1]^3))*sum(log(myx)) - (x[2]/(x[1]^3))*sum(1/log(myx))
y[2] <- -(n/(2*x[2])) + sum((1/(x[2]-log(myx)))) - (1/(2*(x[1]^2)*(x[2]^2)))*sum(log(myx)) + (1/(2*x[1]^2))*sum(1/(log(myx)))
y
}
Sin <- c(alpha,beta)
mle<- nleqslv(Sin, Score, control=list(btol=.01))[1]
LHE[i,]= mle
bias[i,]= c(mle[1]-theta[1], mle[2]-theta[2])
}
# end for i
#Format results
L <-round(apply(LHE, 1, mean), 3) # MLE of all the applied iterations
bs <-round(apply(bias,1, mean),3) # bias of all the applied iterations
row<- c(L, bs)
#Format a label
lab <- paste0('n= ',n,';',' alpha= ',alpha,';',' beta= ',beta)
row2 <- c(lab,row)
row2 <- as.data.frame(t(row2))
return(row2)
}
#Bind all
#Example 1
ex1 <- mymle(n = 20,alpha = 1,beta = 0.5,rep = 100)
ex2 <- mymle(n = 50,alpha = 2,beta = 0.5,rep = 100)
ex3 <- mymle(n = 100,alpha = 3,beta = 0.5,rep = 100)
#Example 2
ex4 <- mymle(n = 20,alpha = 0.5,beta = 0.5,rep = 100)
ex5 <- mymle(n = 50,alpha = 0.5,beta = 1,rep = 100)
ex6 <- mymle(n = 100,alpha = 0.5,beta = 1,rep = 100)
df <- rbind(ex1,ex2,ex3,ex4,ex5,ex6)
Any help will be appreciated.
As said: it even differs by a factor of 2 in time! How is that possible?
I found this issue but it seems it is still there?
It turns out that the highway is only taken in on direction (See leaflet map from map_route. Do I miss anything?
Here is a reproducible example:
wd <- getwd()
setwd("C:/OSRM_API5")
shell(paste0("osrm-routed ", "switzerland-latest.osrm", " >nul 2>nul"), wait = F)
Sys.sleep(3) # OSRM needs time
setwd(wd)
k1 <- 46.99917
k2 <- 8.610048
k3 <- 47.05398
k4 <- 8.530232
r1 <- viaroute5_2(k1, k2, k3, k4)
r1$routes[[1]]$duration
# [1] 598.2
geometry <- decode_geom(r1$routes[[1]]$geometry, 5)
map_route(geometry)
r2 <- viaroute5_2(k3, k4,k1, k2)
r2$routes[[1]]$duration
# [1] 1302
geometry <- decode_geom(r2$routes[[1]]$geometry, 5)
map_route(geometry)
shell("TaskKill /F /IM osrm-routed.exe >nul 2>nul")
Here are the functions you need:
viaroute5_2 <- function(lat1, lng1, lat2, lng2) {
# address <- "http://localhost:5000" # this should work without a local server
address <- "http://localhost:5000"
request <- paste(address, "/route/v1/driving/",
lng1, ",", lat1, ";", lng2, ",", lat2,
"?overview=full", sep = "", NULL)
R.utils::withTimeout({
repeat {
res <- try(
route <- rjson::fromJSON(
file = request))
if (class(res) != "try-error") {
if (!is.null(res)) {
break
} else {
stop("???")
}
}
}
}, timeout = 1, onTimeout = "warning")
if (res$code == "Ok") {
return(res)
} else {
t_guess <- 16*60
warning("Route not found: ", paste(lat1, lng1, lat2, lng2, collapse = ", "),
". Time set to ", t_guess/60 , " min.")
}
}
decode_geom <- function(encoded, precision = stop("a numeric, either 5 or 6")) {
if (precision == 5) {
scale <- 1e-5
} else if (precision == 6) {
scale <- 1e-6
} else {
stop("precision not set to 5 or 6")
}
len = stringr::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) {
shift <- result <- 0
repeat {
b = as.integer(charToRaw(encoded[index])) - 63
index <- index + 1
result = bitops::bitOr(result, bitops::bitShiftL(bitops::bitAnd(b, 0x1f), shift))
shift = shift + 5
if (b < 0x20) break
}
dlat = ifelse(bitops::bitAnd(result, 1),
-(result - (bitops::bitShiftR(result, 1))),
bitops::bitShiftR(result, 1))
lat = lat + dlat;
shift <- result <- b <- 0
repeat {
b = as.integer(charToRaw(encoded[index])) - 63
index <- index + 1
result = bitops::bitOr(result, bitops::bitShiftL(bitops::bitAnd(b, 0x1f), shift))
shift = shift + 5
if (b < 0x20) break
}
dlng = ifelse(bitops::bitAnd(result, 1),
-(result - (bitops::bitShiftR(result, 1))),
bitops::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() {
library(leaflet)
m <- leaflet() %>%
addTiles() %>%
addProviderTiles(providers$OpenStreetMap, group = "OSM") %>%
addProviderTiles(providers$Stamen.TonerLite, group = "Toner Lite") %>%
addLayersControl(baseGroups = c("OSM", "Toner Lite"))
return(m)
}
map_route <- function(geometry) { # Which parameters make sence? osrm inside or outside?
m <- map()
m <- addCircleMarkers(map = m,
lat = geometry$lat[1],
lng = geometry$lng[1],
color = imsbasics::fhs(),
popup = paste("Source"),
stroke = FALSE,
radius = 6,
fillOpacity = 0.8) %>%
addCircleMarkers(lat = geometry$lat[nrow(geometry)],
lng = geometry$lng[nrow(geometry)],
color = imsbasics::fhs(),
popup = paste("Destination"),
stroke = FALSE,
radius = 6,
fillOpacity = 0.8) %>%
addPolylines(lat = geometry$lat, lng = geometry$lng, color = "red", weight = 4) %>%
addLayersControl(baseGroups = c("OSM", "Stamen.TonerLite"))
return(m)
}
The answer is: Because OSRM searches by default a nearest point and searches one route from that point. If your coordinates are slightly north a highway, OSRM will only drive westbound (considering you're drive on the right side as we do in Europe..).
So in your example the point upleft is just a bit north of the highway and therefore when searching from that point OSRM takes quite a bit of a detour.
The following example shows this:
osrmr::run_server("switzerland-latest", "C:/OSRM_API5")
lat1 <- 46.99917
lng1 <- 8.610048
lat2 <- 47.05398
lng2 <- 8.530232
res1 <- osrmr::viaroute(lat1, lng1, lat2, lng2, instructions = TRUE, api_version = 5, localhost = TRUE)
res2 <- osrmr::viaroute(lat2, lng2, lat1, lng1, instructions = TRUE, api_version = 5, localhost = TRUE)
res1$routes[[1]]$duration
# [1] 598.2
res2$routes[[1]]$duration
# [1] 1302
map_route(decode_geom(res1$routes[[1]]$geometry, 5))
map_route(decode_geom(res2$routes[[1]]$geometry, 5))
lat1 <- 46.99917
lng1 <- 8.610048
lat2 <- 47.051 # setting that point a bit more south changes the results to the opposite..
lng2 <- 8.530232
res1 <- osrmr::viaroute(lat1, lng1, lat2, lng2, instructions = TRUE, api_version = 5, localhost = TRUE)
res2 <- osrmr::viaroute(lat2, lng2, lat1, lng1, instructions = TRUE, api_version = 5, localhost = TRUE)
res1$routes[[1]]$duration
# [1] 1307.5
res2$routes[[1]]$duration
# [1] 592.7
map_route(decode_geom(res1$routes[[1]]$geometry, 5))
map_route(decode_geom(res2$routes[[1]]$geometry, 5))
osrmr::quit_server()
As you can see, setting the second point a bit more south inverts the results. Now the other way takes quite a bit longer.
As discussed for example here the radiuses option might provide a solution to that problem. I couldn't however figure out to get that to work on your example..
Or maybe (simpler..) you want to calculate both directions and take the shorter duration?
What's best really depends on your algorithmic problem..
I am looking to generate a ternary plot with binned polygons (either triangle or hex, preferably in a ggplot framework) where the color of the polygon is a binned mean or median of selected values.
This script gets very close, but triangle cell color is representative of a number of observations, rather than a mean value of observations contained within the triangle cell.
So rather than soley providing X,Y, and Z; I would provide a fourth fill/value variable is provided from which binned means or medians are calculated and represented as a color on a gradient.
Akin to the below image, though in a ternary framework with an additional axis.
Image of stat_summary_hex() plot with color as binned mean value
I appreciate the help. Thank you.
Dummy data to begin with:
#load libraries
devtools::install_git('https://bitbucket.org/nicholasehamilton/ggtern')
library(ggtern)
library(ggplot)
# example data
sig <- matrix(c(3,0,0,2),2,2)
data <- data.frame(mvrnorm(n=10000, rep(2, 2), sig))
data$X1 <- data$X1/max(data$X1)
data$X2 <- data$X2/max(data$X2)
data$X1[which(data$X1<0)] <- runif(length(data$X1[which(data$X1<0)]))
data$X2[which(data$X2<0)] <- runif(length(data$X2[which(data$X2<0)]))
data$X3 <- with(data, 1-X1-X2)
data <- data[data$X3 >= 0,]
data$X4 <- rnorm(dim(data)[1])
data <- data.frame(X = data$X1, Y = data$X2, Z = data$X3, fill_variable = data$X4)
str(data)
# simple ternary plot where color of point is the fill variable value
ggtern(data,aes(X,Y,Z, color = fill_variable))+geom_point()
# 2D example, not a ternary though. Keep in mind in geom_hex Z is the fill, not the additional axis like ggtern
ggplot(data,aes(X,Y))+stat_summary_hex(aes(z = fill_variable))
This code isn't cleaned up, but it's a good jumping off point. Credit for original goes the OP referenced in the first question.
I made some minor adjustments to the count_bin function to instead of doing bin counts, it does bin medians. Use at your own risk and please point out any bugs. For my implementation this reports 0 for NA bins.
Example:
Function for binned median (pardon the name, just saves time):
count_bin <- function(data, minT, maxT, minR, maxR, minL, maxL) {
ret <- data
ret <- with(ret, ret[minT <= X1 & X1 < maxT,])
ret <- with(ret, ret[minL <= X2 & X2 < maxL,])
ret <- with(ret, ret[minR <= X3 & X3 < maxR,])
if(is.na(median(ret$VAR))) {
ret <- 0
} else {
ret <- median(ret$VAR)
}
ret
}
Modified heatmap function:
heatmap3d <- function(data, inc, logscale=FALSE, text=FALSE, plot_corner=TRUE) {
# When plot_corner is FALSE, corner_cutoff determines where to stop plotting
corner_cutoff = 1
# When plot_corner is FALSE, corner_number toggles display of obervations in the corners
# This only has an effect when text==FALSE
corner_numbers = TRUE
count <- 1
points <- data.frame()
for (z in seq(0,1,inc)) {
x <- 1- z
y <- 0
while (x>0) {
points <- rbind(points, c(count, x, y, z))
x <- round(x - inc, digits=2)
y <- round(y + inc, digits=2)
count <- count + 1
}
points <- rbind(points, c(count, x, y, z))
count <- count + 1
}
colnames(points) = c("IDPoint","T","L","R")
#str(points)
#str(count)
# base <- ggtern(data=points,aes(L,T,R)) +
# theme_bw() + theme_hidetitles() + theme_hidearrows() +
# geom_point(shape=21,size=10,color="blue",fill="white") +
# geom_text(aes(label=IDPoint),color="blue")
# print(base)
polygons <- data.frame()
c <- 1
# Normal triangles
for (p in points$IDPoint) {
if (is.element(p, points$IDPoint[points$T==0])) {
next
} else {
pL <- points$L[points$IDPoint==p]
pT <- points$T[points$IDPoint==p]
pR <- points$R[points$IDPoint==p]
polygons <- rbind(polygons,
c(c,p),
c(c,points$IDPoint[abs(points$L-pL) < inc/2 & abs(points$R-pR-inc) < inc/2]),
c(c,points$IDPoint[abs(points$L-pL-inc) < inc/2 & abs(points$R-pR) < inc/2]))
c <- c + 1
}
}
#str(c)
# Upside down triangles
for (p in points$IDPoint) {
if (!is.element(p, points$IDPoint[points$T==0])) {
if (!is.element(p, points$IDPoint[points$L==0])) {
pL <- points$L[points$IDPoint==p]
pT <- points$T[points$IDPoint==p]
pR <- points$R[points$IDPoint==p]
polygons <- rbind(polygons,
c(c,p),
c(c,points$IDPoint[abs(points$T-pT) < inc/2 & abs(points$R-pR-inc) < inc/2]),
c(c,points$IDPoint[abs(points$L-pL) < inc/2 & abs(points$R-pR-inc) < inc/2]))
c <- c + 1
}
}
}
#str(c)
# IMPORTANT FOR CORRECT ORDERING.
polygons$PointOrder <- 1:nrow(polygons)
colnames(polygons) = c("IDLabel","IDPoint","PointOrder")
df.tr <- merge(polygons,points)
Labs = ddply(df.tr,"IDLabel",function(x){c(c(mean(x$T),mean(x$L),mean(x$R)))})
colnames(Labs) = c("Label","T","L","R")
#str(Labs)
#triangles <- ggtern(data=df.tr,aes(L,T,R)) +
# geom_polygon(aes(group=IDLabel),color="black",alpha=0.25) +
# geom_text(data=Labs,aes(label=Label),size=4,color="black") +
# theme_bw()
# print(triangles)
bins <- ddply(df.tr, .(IDLabel), summarize,
maxT=max(T),
maxL=max(L),
maxR=max(R),
minT=min(T),
minL=min(L),
minR=min(R))
#str(bins)
count <- ddply(bins, .(IDLabel), summarize,
N=count_bin(data, minT, maxT, minR, maxR, minL, maxL)
#N=mean(data)
)
df <- join(df.tr, count, by="IDLabel")
str(count)
Labs = ddply(df,.(IDLabel,N),function(x){c(c(mean(x$T),mean(x$L),mean(x$R)))})
colnames(Labs) = c("Label","N","T","L","R")
if (plot_corner==FALSE){
corner <- ddply(df, .(IDPoint, IDLabel), summarize, maxperc=max(T,L,R))
corner <- corner$IDLabel[corner$maxperc>=corner_cutoff]
df$N[is.element(df$IDLabel, corner)] <- 0
if (text==FALSE & corner_numbers==TRUE) {
Labs$N[!is.element(Labs$Label, corner)] <- ""
text=TRUE
}
}
heat <- ggtern(data=df,aes(L,T,R)) +
geom_polygon(aes(fill=N,group=IDLabel),color="black",alpha=1, size = 0.1,show.legend = F)
if (logscale == TRUE) {
heat <- heat + scale_fill_gradient(name="Observations", trans = "log",
low=palette[2], high=palette[4])
} else {
heat <- heat + scale_fill_distiller(name="Median Value",
palette = "Spectral")
}
heat <<- heat +
Tlab("x") +
Rlab("y") +
Llab("z") +
theme_bw() +
theme(axis.tern.arrowsep=unit(0.02,"npc"), #0.01npc away from ticks ticklength
axis.tern.arrowstart=0.25,axis.tern.arrowfinish=0.75,
axis.tern.text=element_text(size=12),
axis.tern.arrow.text.T=element_text(vjust=-1),validate = F,
axis.tern.arrow.text.R=element_text(vjust=2),
axis.tern.arrow.text.L=element_text(vjust=-1),
#axis.tern.arrow.text=element_text(size=12),
axis.tern.title=element_text(size=15),
axis.tern.text=element_blank(),
axis.tern.arrow.text=element_blank())
if (text==FALSE) {
print(heat)
} else {
print(heat + geom_text(data=Labs,aes(label=N),size=3,color="white"))
}
}
Dummy example:
# dummy example
sig <- matrix(c(3,3,3,3),3,3)
data <- data.frame(mvrnorm(n=10000, rep(2, 2), sig))
data$X1[which(data$X1<0)] <- runif(length(data$X1[which(data$X1<0)]))
data$X2[which(data$X2<0)] <- runif(length(data$X2[which(data$X2<0)]))
data$X3 <- with(data, 1-X1-X2)
data <- data[data$X3 >= 0,]
data$VAR <- rnorm(dim(data)[1])
data <- data.frame(X = data$X1, Y = data$X2, Z = data$X3, fill_variable = data$X4)
str(data)
ggtern(data,aes(X1,
X2,
X3, color = VAR))+geom_point(size = 5)+scale_color_distiller(palette = "Spectral")
heatmap3d(data,.05)
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))
I am looking for a procedure that allows me to generate a sequence of equidistant points (coordinates) along the sides of an arbitrary polygon.
Imaging a polygon defined by the coordinates of its vertexes:
poly.mat <- matrix(c(0,0,
0,1,
0.5,1.5,
0.5,0,
0,0 # last row included to close the polygon
), byrow = T, ncol = 2)
colnames(poly.mat) <- c("x", "y")
plot(poly.mat, type = "l")
If the length of the sequence I want to generate is n (adjustable), how I can produce a sequence, starting at (0,0), of equidistant coordinates.
I got as far as calculating the perimeter of the shape with the geosphere package (which I believe I need)
library(geosphere)
n <- 50 # sequence of length set to be 50
perim <- perimeter(poly.mat)
perim/n # looks like every section needs to be 8210.768 something in length
You will have to write the code yourself. Sorry, there isn't a library function for every last detail of every last assignment. Assuming that each pair of points defines a line segment, you could just generate N points along each segment, as in
begin = [xbegin, ybegin ];
end = [xend, yend ];
xdist = ( xend - xbegin ) / nintervals;
ydist = ( yend - ybegin ) / nintervals;
then your points are given by [ xbegin + i * xdist, ybegin + i * ydist ]
Here is the solution I came up with.
pointDistance <- function(p1, p2){
sqrt((p2[,1]-p1[,1])^2) + sqrt((p2[,2]-p1[,2])^2)
}
getPos <- function(shp.mat, ll){
greaterLL <- shp.mat$cumdis > ll
if(all(greaterLL == FALSE)) return(poly.mat[nrow(poly.mat), c("x", "y")])
smallRow <- min(which(greaterLL)) # the smallest coordinate that has greater length
p.start <- shp.mat[smallRow-1, c("x","y")]
p.end <- shp.mat[smallRow, c("x","y")]
cumVal <- shp.mat$cumdis[smallRow]
prop <- (ll-shp.mat$cumdis[smallRow-1])/(shp.mat$cumdis[smallRow]-shp.mat$cumdis[smallRow-1])
p.start + (prop)* (p.end-p.start)
}
# shp1
poly.mat <- matrix(c(0,0,
0,1,
0.5,1.5,
0.5,0,
0,0
),byrow = T, ncol = 2)
colnames(poly.mat) <- c("x", "y")
poly.mat <- as.data.frame(poly.mat)
# Main fun
pointsOnPath <- function(shp.mat, n){
dist <- vector(mode = "numeric", length = nrow(shp.mat)-1)
for(i in 2:nrow(shp.mat)){
dist[i] <- pointDistance(p1 = shp.mat[i,], p2 = shp.mat[i-1,])
}
shp.mat$dist <- dist
shp.mat$cumdis <- cumsum(shp.mat$dist)
dis <- matrix(seq(from = 0, to = max(shp.mat$cumdis), length.out = n+1), ncol = 1)
out <- lapply(dis, function(x) getPos(shp.mat = shp.mat, ll = x))
out <- do.call("rbind", out)
out$dis <- dis
out[-nrow(out),]
}
df <- pointsOnPath(shp.mat = poly.mat, 5)
# Plot
plot(poly.mat$x, poly.mat$y, type = "l", xlim = c(0,1.5), ylim = c(0,1.5))
points(df$x, df$y, col = "red", lwd = 2)
There is room for improving the code, but it should return the correct result