Abstract
This page is a (online) guide to illustrate the article (available from Arvix), that presents a set of tools for the modeling of a spatial allocation problem in a large geographic market and gives examples of applications. In our settings, the market is described by a network that maps the cost of travel between each pair of adjacent locations. Two types of agents are located at the nodes of this network. The buyers choose the most competitive sellers depending on their prices and the cost to reach them. Their utility is assumed additive in both these quantities. Each seller, taking as given other sellers prices, sets her own price to have a demand equal to the one we observed. We give a linear programming formulation for the equilibrium conditions. After formally introducing our model we apply it on two examples: prices offered by petrol stations and quality of services provided by maternity wards (only the later is described here for privacy issues). These examples illustrate the applicability of our model to aggregate demand, rank prices and estimate cost structure over the network. We insist on the possibility of applications to large scale data sets using modern linear programming solvers such as Gurobi.Contact : Arthur Charpentier charpentier.arthur@uqam.ca
We will use some some network packages (mainly to illustrate)
as well as some packages for spatial analysis, and visualization
library(geosphere)
library(rgdal)
library(leaflet)
library(scales)
library(lwgeom)
library(shapefiles)
library(sp)
library(rgeos)
library(osmdata)
library(sf)
library(ggmap)
library(maptools)For technical reasons, we need additional packages
library(Matrix)
library(tripack)
library(RColorBrewer)
library(units)
library(pals)
library(classInt)In the applications, we will use gurobi. It is a commercial optimization solver for linear programming, quadratic programming (among many other), that is available for free in academia. Installation can be a little bit complicated (see the vignette online),
We will consider three applications in this guide
The geometry of the geographic market is described by a connected graph \(G=\left(V,E\right)\) where \(V\) is a set of vertices and \(E\) is a set of directed edges. Vertices are the different locations; edges are road segments linking two adjacent locations.
Agents are located at the vertices of our graph (if not, as we will see, we will match them with the closest vertice).We make the following assumptions on their consumption preferences:
A path \(\pi_{vw}\) between two nodes \(v,w\in V\) is a sequence of connected edges starting in \(v\) and ending in \(w\). We note \(\Pi_{vw}\) the set of paths between \(v\) and \(w\).
For each edge \(e\in E\), we define \(c_{e}\) the cost of travel along this arc. A seller located in \(w\in V\) sells at an endogenous price \(p_{w}\). Therefore a consumer located in \(v\) chooses to buy from the seller located in \(w\) that minimizes his total cost \(p_{v}\) \[ p_{v}=\underset{w\in V\text{, }\pi_{vw}\in\Pi_{vw}}{\min}\left[p_{w}+\underset{e\in\pi_{vw}}{\sum}c_{e}\right] \]
Let’s denote\(u_{v}\) the reservation utility of agents located in \(v\) and \(p_{v}\) the price for these agents (including the cost of transportation). Therefore, if \(p_{v}>u_{v}\) a consumer in \(v\) his outside option, else he buys from the most competitive seller depending on his location in the market.
This outside option can be modeled by a fictitious node \(0\), where the price of the commodity is set to \(p_{0}=0\) and the cost of travel is \(c_{v0}=u_{v}\).
Hence the excess demand \(z_{v}\) at a node \(v\in V\) does not depend on the price. We are solving a matching problem over a network between sellers and consumers.
At equilibrium each consumer chooses the most competitive seller depending on his location; furthermore the demand received by each seller must equal his supply. If we define \(\mu_{e}\) the number of agents traveling along edge \(e\), these equilibrium conditions can be written: \[ \left\{ \begin{array}{l} \forall vw\in E\text{, }p_{w}-p_{v}\leq c_{vw}\\ \forall vw\in E\text{ such that }\mu_{vw}>0\text{, }p_{w}-p_{v}=c_{vw}\\ \forall v\in V\text{, }\underset{w\in V}{\sum}\mu_{vw}-\underset{u\in V}{\sum}\mu_{uv}=z_{v} \end{array}\right. \]
These equations are the complementary slackness conditions for a minimum cost flow problem over network \(G\). Hence, if the graph is connected and if there isn’t any loop of negative cost in \(G\), there exists an equilibrium which is the solution of the min-cost flow problem \[ \begin{array}{cl} \mu=\text{argmin}\underset{e\in E}{\sum}c_{e}\mu_{e}\\ & \mu\text{ s.t. }\forall v\in V\text{, }\underset{w\in V}{\sum}\mu_{vw}-\underset{u\in V}{\sum}\mu_{uv}=z_{v} \end{array} \]
Models used in trade theory usually use iceberg transport costs. These costs are linear in distance and paid in the transported good once arrived - hence the metaphor of the iceberg that melts as you transport it.
Our model can incorporate these costs applying a log-transformation to the equilibrium conditions. Let’s define for all \(vw\in E\) iceberg costs \(\tau_{vw}\). An equilibrium \(\left(\mu,p\right)\) should satisfy \[ \left\{ \begin{array}{l} \forall vw\in E\text{, }\left(1-\tau_{vw}\right)p_{w}\leq p_{v}\\ \forall vw\in E\text{ such that }\mu_{vw}>0\text{, }\left(1-\tau_{vw}\right)p_{w}=p_{v}\\ \forall v\in V\text{, }\underset{w\in V}{\sum}\mu_{vw}-\underset{u\in V}{\sum}\mu_{uv}=z_{v} \end{array}\right. \] which becomes \[ \left\{ \begin{array}{l} \forall vw\in E\text{, }\log p_{w}-\log p_{v}\leq-\log\left(1-\tau_{vw}\right)\\ \forall vw\in E\text{ such that }\mu_{vw}>0\text{, }\log p_{w}-\log p_{v}=-\log\left(1-\tau_{vw}\right)\\ \forall v\in V\text{, }\underset{w\in V}{\sum}\mu_{vw}-\underset{u\in V}{\sum}\mu_{uv}=z_{v} \end{array}\right. \]
Therefore this problem is equivalent to the one presented earlier with \(\forall vw\in E\), \(c_{vw}=-\log\left(1-\tau_{vw}\right)\), and replacing \(p\) by its logarithm.
Consider a shapefile of roads, or train lines : each road is a collection of segments, or connected nodes. Our shapefile is, so fact, only in a dataframe dd
Here are the (given) knots and the four roads
par(mfrow=c(1,2))
plot(dd$X,dd$Y,col="white",xlab="",ylab="")
for(i in unique(dd[,1])) lines(dd$X[dd$Id==i],dd$Y[dd$Id==i])
points(dd$X,dd$Y,pch=19,col="red")
library(RColorBrewer)
darkcols = brewer.pal(8, "Dark2")
plot(dd$X,dd$Y,xlab="",ylab="")
for(i in unique(dd[,"Id"])) lines(dd$X[dd$Id==i],dd$Y[dd$Id==i],col=darkcols[i],lwd=2)Let us create a shapefile from those segments
Show code for the extend_shp() functionIntersections of roads are now added, as knots of the network
par(mfrow=c(1,2))
plot(dd$X,dd$Y,col="white",xlab="",ylab="")
for(i in unique(dd[,1])) lines(dd$X[dd$Id==i],dd$Y[dd$Id==i])
points(dd2[["knots"]]$X,dd2[["knots"]]$Y,pch=19,col="blue")
points(dd$X,dd$Y,pch=19,col="red")
plot(dd2[["shp"]]$X,dd2[["shp"]]$Y,col="white",xlab="",ylab="",axes=FALSE,xlim=c(2.6,8.4))
text(dd2[["knots"]]$X,dd2[["knots"]]$Y,dd2[["knots"]]$NO)
points(dd2[["knots"]]$X,dd2[["knots"]]$Y,cex=3)We can also visualize all knots of the network
library(RColorBrewer)
darkcols = brewer.pal(8, "Dark2")
plot(dd2[["shp"]]$X,dd2[["shp"]]$Y,col="white",xlab="",ylab="",axes=FALSE)
for(i in 1:(nrow(dd2$connected)/2)) segments(dd2[["knots"]]$X[dd2[["connected"]]$knot1[i]],dd2[["knots"]]$Y[dd2[["connected"]]$knot1[i]],
dd2[["knots"]]$X[dd2[["connected"]]$knot2[i]],dd2[["knots"]]$Y[dd2[["connected"]]$knot2[i]],
col=darkcols[dd2[["connected"]]$Id[i]])
points(dd2[["knots"]]$X,dd2[["knots"]]$Y,pch=19,col="black",cex=3)
text(dd2[["knots"]]$X,dd2[["knots"]]$Y,dd2[["knots"]]$NO,col="white")We can now create agents, buyers and sellers
agents=data.frame(X=c(5.5,3.5,6.5,6.5,4.5),
Y=c(4,9,8,5.5,9),
Type=as.factor(c("Demand","Demand","Supply","Supply","Supply")))
forme=c(15,19,0,1)
plot(dd2[["shp"]]$X,dd2[["shp"]]$Y,col="white",xlab="",ylab="",axes=FALSE)
for(i in 1:(nrow(dd2$connected)/2)) segments(dd2[["knots"]]$X[dd2[["connected"]]$knot1[i]],dd2[["knots"]]$Y[dd2[["connected"]]$knot1[i]],
dd2[["knots"]]$X[dd2[["connected"]]$knot2[i]],dd2[["knots"]]$Y[dd2[["connected"]]$knot2[i]])
points(dd2[["knots"]]$X,dd2[["knots"]]$Y,pch=19,col="white",cex=3)
points(dd2[["knots"]]$X,dd2[["knots"]]$Y,pch=1,col="black",cex=3)
text(dd2[["knots"]]$X,dd2[["knots"]]$Y,dd2[["knots"]]$NO,col="black")
points(agents$X,agents$Y,pch=forme[agents$Type],col=darkcols[agents$Type],cex=3)Here, we want to connect the buyers (green squares) and the sellers (orange bullets). Let use visualize, as a starting point, euclidean distances
plot(dd2[["shp"]]$X,dd2[["shp"]]$Y,col="white",xlab="",ylab="",axes=FALSE)
for(i in which(agents$Type=="Demand")) segments(agents[i,"X"],agents[i,"Y"],agents[agents$Type=="Supply","X"],agents[agents$Type=="Supply","Y"])
points(agents$X,agents$Y,pch=forme[agents$Type],col=darkcols[agents$Type],cex=3)We use the closest distance to match demand and supply
close_supply <- function(coord,knots=agents[agents$Type=="Supply",]){
knots[which.min(distHaversine( coord[,c("X","Y")] , knots[,c("X","Y")] , r =6378.137)),]
}
list_demand <- which(agents$Type=="Demand")
close_supply(agents[list_demand[1],])FALSE X Y Type
FALSE 4 6.5 5.5 Supply
plot(dd2[["shp"]]$X,dd2[["shp"]]$Y,col="white",xlab="",ylab="",axes=FALSE)
for(i in which(agents$Type=="Demand")) segments(agents[i,"X"],agents[i,"Y"],agents[agents$Type=="Supply","X"],agents[agents$Type=="Supply","Y"])
for(i in list_demand){
supply=unlist(close_supply(agents[i,]))
segments(agents[i,"X"],agents[i,"Y"],supply["X"],supply["Y"],col=darkcols[3],lwd=6)
}
points(agents$X,agents$Y,pch=forme[agents$Type],col=darkcols[agents$Type],cex=3.2)
text(agents$X,agents$Y,1:nrow(agents),pch=forme[agents$Type],col="white")or with a more classical bipartite graph with buyers on the left (demand), and sellers on the right (supply)
Show code for the bipartite graphFrom now on, let us forget about that shortest Euclidean distance, and let us consider the distance on the network (using roads).
The first step is to match the agents with a knot of the network (we use here the Euclidean distance)
close_knot=function(coord,knots=dd2$knots){
knots[which.min(distHaversine( coord[,c("X","Y")] , knots[,c("X","Y")] , r =6378.137)),]
}
shift_agents=agents
shift_agents$Xk=shift_agents$X
shift_agents$Yk=shift_agents$Y
shift_agents$NO=0
for(i in 1:nrow(shift_agents)) shift_agents[i,c("Xk","Yk","NO")]=close_knot(agents[i,])
shift_agentsFALSE X Y Type Xk Yk NO
FALSE 1 5.5 4.0 Demand 5.000000 4.000000 7
FALSE 2 3.5 9.0 Demand 3.000000 9.000000 1
FALSE 3 6.5 8.0 Supply 6.000000 8.000000 13
FALSE 4 6.5 5.5 Supply 6.263158 5.894737 6
FALSE 5 4.5 9.0 Supply 5.000000 9.000000 11
plot(dd2[["shp"]]$X,dd2[["shp"]]$Y,col="white",xlab="",ylab="",axes=FALSE)
for(i in 1:(nrow(dd2$connected)/2)) segments(dd2[["knots"]]$X[dd2[["connected"]]$knot1[i]],dd2[["knots"]]$Y[dd2[["connected"]]$knot1[i]],
dd2[["knots"]]$X[dd2[["connected"]]$knot2[i]],dd2[["knots"]]$Y[dd2[["connected"]]$knot2[i]])
points(dd2[["knots"]]$X,dd2[["knots"]]$Y,pch=19,col="white",cex=3)
points(dd2[["knots"]]$X,dd2[["knots"]]$Y,pch=1,col="black",cex=3)
points(agents$Xk,agents$Yk,pch=forme[agents$Type],col=darkcols[agents$Type],cex=3)
text(dd2[["knots"]]$X,dd2[["knots"]]$Y,dd2[["knots"]]$NO,col="black")
points(shift_agents$Xk,shift_agents$Yk,pch=forme[shift_agents$Type],col=darkcols[shift_agents$Type],cex=3.2)
points(shift_agents$X,shift_agents$Y,pch=forme[2+as.numeric(shift_agents$Type)],col=darkcols[as.numeric(shift_agents$Type)],cex=3)Then we compute the distance between nodes, manually here (we will use igraph and gurobi in the next section)
plot(0:1,0:1,col="white",xlab="",ylab="",axes=FALSE)
text(.125,.5,"DEMAND",srt=90,col=darkcols[1])
text(.875,.5,"SUPPLY",srt=270,col=darkcols[2])
i=which(agents$Type=="Demand")
y1=rev(seq(1/(2*length(i)),1-1/(2*length(i)),by=1/(2*length(i)))[seq(1,2*length(i),by=2)])
i=which(agents$Type=="Supply")
y2=rev(seq(1/(2*length(i)),1-1/(2*length(i)),by=1/(2*length(i)))[seq(1,2*length(i),by=2)])
id=which(agents$Type=="Demand")
for(i in 1:sum(agents$Type=="Demand")){
d=distHaversine( agents[id[i],c("X","Y")] , agents[agents$Type=="Supply",c("X","Y")] , r =6378.137)
segments(.25,y1[i],.75,y2,col=c("black",darkcols[3])[1+(d==min(d))],lwd=c(1,6)[1+(d==min(d))])
text(.5,(y2+y1[i])/2,round(d),pos=1,col=c("black",darkcols[3])[1+(d==min(d))])
}
i=which(agents$Type=="Demand")
points(rep(.25,length(i)),y1,
pch=forme[1],col=darkcols[1],cex=3.2)
text(rep(.25,length(i)),y1,i,col="white")
i=which(agents$Type=="Supply")
points(rep(.75,length(i)),y2,
pch=forme[2],col=darkcols[2],cex=3.2)
text(rep(.75,length(i)),y2,i,col="white")igraphOne can use library(igraph) (see http://igraph.org) to find the closest supply location
Demand = shift_agents[shift_agents$Type=="Demand",c("NO","X","Y")]
Supply = shift_agents[shift_agents$Type=="Supply",c("NO","X","Y")]
Nodes = dd2$knots[,c("NO","X","Y")]
Arcs = dd2$connected
library(igraph)
iarcs <- make_graph(edges = as.vector(rbind(Arcs[,1],Arcs[,2])),directed=TRUE)
plot(iarcs,layout=as.matrix(dd2$knots[,c("X","Y")]),edge.arrow.size=.2)iarcs = set_edge_attr(iarcs,"distance", value=Arcs[,"distance"])
cat("The graph is connex :", is.connected(iarcs,mode="strong"),"\n")FALSE The graph is connex : TRUE
If the graph is not connex, we need to keep the largest strongly connected subgraph
if(!is.connected(iarcs,mode="strong")){
nodestokeep=which(clusters(iarcs,mode="strong")[[1]]==which(clusters(iarcs,mode="strong")[[2]]==max(clusters(iarcs,mode="strong")[[2]])))
nodestokeep
Arcs = Arcs[(Arcs$knot1 %in% nodestokeep)&(Arcs$knot2 %in% nodestokeep),]
Nodes = Nodes[Nodes$NO %in% nodestokeep, ]
iarcs = graph.edgelist(as.matrix(Arcs[,c("knot1","knot2")]), directed=TRUE)
iarcs = set_edge_attr(iarcs,"distance", value=Arcs[,"distance"])
cat("The graph is connex :", is.connected(iarcs,mode="strong"),"\n")
plot(iarcs,layout=as.matrix(dd2$knots[dd2$knots$NO%in%nodestokeep,c("X","Y")]),edge.arrow.size=.2)}We need to keep the largest strongly connected subgraph (this technical assumption will be important later on):
AP=all_shortest_paths(iarcs,
from=Demand[1,"NO"],
to=Supply[3,"NO"])
L=AP$res[[1]]
n=length(L)
V(iarcs)$color="yellow"
V(iarcs)$color[L[2:(n-1)]]="light blue"
V(iarcs)$color[L[c(1,n)]]="blue"
plot(iarcs,layout=as.matrix(dd2$knots[,c("X","Y")]),edge.arrow.size=.2)dist_graph = function(i,j) dd2$connected[(dd2$connected$knot1==i)&(dd2$connected$knot2==j),"distance"][1]
D=function(dem,sup){
AP=all_shortest_paths(iarcs,
from=Demand[dem,"NO"],
to=Supply[sup,"NO"],weights=dd2$connected$distance)
AP_path = AP$res[[1]]
d=0
for(u in 1:(length(AP_path)-1)) d=d+dist_graph(AP_path[u],AP_path[u+1])
d}
DF=expand.grid(dem=1:nrow(Demand),sup=1:nrow(Supply))
M=matrix(Vectorize(function(i) D(DF[i,"dem"],DF[i,"sup"]))(1:(nrow(Demand)*nrow(Supply))),nrow(Demand),nrow(Supply))
MFALSE [,1] [,2] [,3]
FALSE [1,] 542.9799 253.2018 772.7032
FALSE [2,] 425.6273 519.5013 246.6023
idx=apply(M,1,which.min)
for(i in 1:length(idx)){
AP=all_shortest_paths(iarcs,
from=Demand[i,"NO"],
to=Supply[idx[i],"NO"])
L=AP$res[[1]]
n=length(L)
V(iarcs)$color="yellow"
V(iarcs)$color[L[2:(n-1)]]="light blue"
V(iarcs)$color[L[c(1,n)]]="blue"
plot(iarcs,layout=as.matrix(dd2$knots[,c("X","Y")]),edge.arrow.size=.2,
main=paste("Shortest Path, demand ",Demand[i,"NO"],", supply ",Supply[idx[i],"NO"],sep=""))
}gurobiOne can also use library(gurobi) (see http://gurobi.com/) to solve a linear programing problem. Very generally, the gurobi interface enables to solve problems of the form \(\mathbf{x}^{\text{T}}Q\mathbf{x}+c^{\text{T}}\mathbf{x}+\alpha\) subject to bound constraints \(\mathbf{\ell}\leq\mathbf{x}\leq \text{u}\), some quadratic constraints \(\mathbf{x}^{\text{T}}Qc\mathbf{x}+q^{\text{T}}\mathbf{x}\leq\beta\), some integrality constraints, some ordered set constraints, etc.
Here,the syntax will be the following (for gurobi functions)
Nabla - of size the number of edges (raws) times the number of nodes (columns). Each raw contains zeros, except for the starting node (+1) and the arrival node (-1). Note that \(|\nabla^{\text{T}}|\) is the incidence matrix of the network,Phi - of size the number of edges. Here, we use a linear cost function, so \(\Phi\) is the vector of length (in km) of edges,n - of size the number of nodesmodelsense : here we want to maximize the flow.result = gurobi ( list(A=t(Nabla), obj=Phi, modelsense='max', rhs=n, sense='=', start=matrix(0,nbArcs,1)), params=NULL)
The outputs of the gurobi call will be
pi = result$xlibrary(gurobi)
arcs = dd2$connected
nbArcs=nrow(arcs)
Nabla = sparseMatrix(i=1:nbArcs,j=arcs[,"knot1"],x=-1) +
sparseMatrix(i=1:nbArcs,j=arcs[,"knot2"],x=1)
Phi = -arcs[,"distance"]
n=rep(0,nrow(dd2$knots))
n[Supply$NO]=+nrow(Demand)
n[Demand$NO]=-nrow(Supply)
sum(n)FALSE [1] 0
FALSE Optimize a model with 13 rows, 26 columns and 52 nonzeros
FALSE Coefficient statistics:
FALSE Matrix range [1e+00, 1e+00]
FALSE Objective range [6e+01, 6e+02]
FALSE Bounds range [0e+00, 0e+00]
FALSE RHS range [2e+00, 3e+00]
FALSE Presolve removed 10 rows and 20 columns
FALSE Presolve time: 0.01s
FALSE Presolved: 3 rows, 6 columns, 12 nonzeros
FALSE
FALSE Iteration Objective Primal Inf. Dual Inf. Time
FALSE 0 -1.6954446e+03 4.000000e+00 0.000000e+00 0s
FALSE 2 -1.9682155e+03 0.000000e+00 0.000000e+00 0s
FALSE
FALSE Solved in 2 iterations and 0.01 seconds
FALSE Optimal objective -1.968215514e+03
FALSE $status
FALSE [1] "OPTIMAL"
FALSE
FALSE $runtime
FALSE [1] 0.01120687
FALSE
FALSE $itercount
FALSE [1] 2
FALSE
FALSE $baritercount
FALSE [1] 0
FALSE
FALSE $nodecount
FALSE [1] 0
FALSE
FALSE $objval
FALSE [1] -1968.216
FALSE
FALSE $x
FALSE [1] 3 1 0 1 0 0 3 0 0 0 2 0 2 0 0 0 0 1 0 0 0 0 0 0 0 0
FALSE
FALSE $slack
FALSE [1] 0 0 0 0 0 0 0 0 0 0 0 0 0
FALSE
FALSE $rc
FALSE [1] 0.0000 0.0000 -383.6504 0.0000 -383.6521 0.0000 0.0000
FALSE [8] 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 -246.6023
FALSE [15] -246.8586 -912.8559 -161.8896 0.0000 -750.9680 -506.4036 -295.1692
FALSE [22] -703.7146 -246.8586 -246.6023 -117.6091 -195.9041
FALSE
FALSE $pi
FALSE [1] 246.7304715 123.4293099 0.0000000 -264.6027722 -80.9448213
FALSE [6] 110.8812242 364.0830417 -36.7033854 -388.5606944 246.8586198
FALSE [11] 0.1281483 -22.1402962 -178.8968596
FALSE
FALSE $vbasis
FALSE [1] 0 0 -1 0 -1 0 0 0 0 0 0 0 0 -1 -1 -1 -1 0 -1 -1 -1 -1 -1
FALSE [24] -1 -1 -1
FALSE
FALSE $cbasis
FALSE [1] -1 -1 0 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
FALSE
FALSE $objbound
FALSE [1] -1968.216
library(pals)
COL = rev(brewer.rdbu(13))
V(iarcs)$color=COL[rank(prices)]
plot(iarcs,layout=as.matrix(dd2$knots[,c("X","Y")]),edge.arrow.size=.1)The legend for those prices is here
par(mfrow=c(1,1))
plot(1:13,rep(1,13),col=COL,pch=15,cex=9,ylim=c(.98,1.02),xlab="",ylab="",axes=FALSE)
text(1:13,rep(1,13),round(sort(prices)),cex=.9,col=c(rep("white",3),rep("black",7),rep("white",3)))FALSE X Y Type Xk Yk NO price
FALSE 1 5.5 4.0 Demand 5.000000 4.000000 7 364.0830417
FALSE 2 3.5 9.0 Demand 3.000000 9.000000 1 246.7304715
FALSE 3 6.5 8.0 Supply 6.000000 8.000000 13 -178.8968596
FALSE 4 6.5 5.5 Supply 6.263158 5.894737 6 110.8812242
FALSE 5 4.5 9.0 Supply 5.000000 9.000000 11 0.1281483
For this application, we will use network data of Paris’ Metro with a dataset of edges/arcs and a dataset with locations of nodes,
FALSE [1] 868 3
FALSE [1] 366 6
subarcs=arcs[(arcs$V1<303)&(arcs$V2<303),]
plot(nodes[1:302,c("V3","V4")],pch=19,xlab="",ylab="",axes=FALSE)
for(i in 1:nrow(arcs)) segments(nodes[subarcs$V1[i],"V3"],nodes[subarcs$V1[i],"V4"],
nodes[subarcs$V2[i],"V3"],nodes[subarcs$V2[i],"V4"])The following code can be used to visualize our network, with background information obtained from OpenStreetMap, as described in caRtosm’s github page.
#library(OpenStreetMap)
#library(devtools)
#install_github("ropensci/osmdata")
library(osmdata)
library(sf)
library(units)
library(scales)
#map=openmap(c(lat=48.9,lon=2.26),c(lat=48.8,lon=2.45))
#map=openproj(map,projection="+init=epsg:4326")
#plot(map)
# see https://rcarto.github.io/caRtosm/index.html
q0 = opq(bbox = c(2.2247, 48.8188, 2.4611, 48.9019))
q1 = add_osm_feature(opq = q0, key = 'name', value = "Paris")
res1 = osmdata_sf(q1)The following function use use to create a background to visualize the metro network
back_paris=function(a=1,background=FALSE){
plot(paris, col=alpha("#D9D0C9",a), border = NA, add=background)
plot(parc, col=alpha("#CDEBB2",a), border = NA, add=TRUE)
plot(seine, col=alpha("#AAD3DF",a), add=TRUE, lwd = 4)
plot(st_geometry(quartier), col = NA,lty = 2, lwd = 0.2, add=TRUE)
}back_paris()
points(nodes[1:302,c("V3","V4")],pch=19)
for(i in 1:nrow(arcs)) segments(nodes[subarcs$V1[i],"V3"],nodes[subarcs$V1[i],"V4"],
nodes[subarcs$V2[i],"V3"],nodes[subarcs$V2[i],"V4"])Consider for instance locations of some hospitals in Paris (one could actually use the geocode function of library(ggmap), from the adresses of hospitals, but here, we have locations, whith longitudes - lon - and latitudes - lat)
library(ggmap)
adresses <- c("47 boulevard de l'hopital Paris","20 rue leblanc Paris","2 rue ambroise pare paris","1 place parvis notre dame paris","149 rue de sevres paris","1 avenue claude vellafaux paris","184 faubourg saint antoine paris","46 rue henri huchard paris")
# hospital <- lapply(adresses,geocode)
hospital = list(c(lon=2.3610258,lat=48.8401821),
c(lon=2.2719068,lat=48.838736),
c(lon=2.3507367,lat=48.8824963),
c(lon=2.346142,lat=48.8539541),
c(lon=2.3125916,lat=48.8455934),
c(lon=2.3676277,lat=48.873488),
c(lon=2.3806986,lat=48.8500029),
c(lon=2.3300414,lat=48.8982232))and consider someone sick, located Place Denfert-Rochereau
adresses <- c("Place Denfert-Rochereau, Paris, France")
# sick <- lapply(adresses,geocode)
sick = list(c(lat=48.8342694,lon=2.3300964))We can plot them on the map
back_paris()
points(nodes[1:302,c("V3","V4")],pch=19)
for(i in 1:nrow(arcs)) segments(nodes[subarcs$V1[i],"V3"],nodes[subarcs$V1[i],"V4"],
nodes[subarcs$V2[i],"V3"],nodes[subarcs$V2[i],"V4"],col="grey")
points(unlist(hospital)[names(unlist(hospital))=="lon"],unlist(hospital)[names(unlist(hospital))=="lat"],pch=forme[2],col=darkcols[2],cex=2)
points(unlist(sick)[names(unlist(sick))=="lon"],unlist(sick)[names(unlist(sick))=="lat"],
pch=forme[1],col=darkcols[1],cex=2)Let us move all those locations to the closest subsway station (the nodes of our network)
Show codeback_paris()
points(nodes[1:302,c("V3","V4")],pch=19)
for(i in 1:nrow(arcs)) segments(nodes[subarcs$V1[i],"V3"],nodes[subarcs$V1[i],"V4"],
nodes[subarcs$V2[i],"V3"],nodes[subarcs$V2[i],"V4"],col="grey")
points(newhospital[,"X"],newhospital[,"Y"],pch=forme[2],col=darkcols[2],cex=2)
points(newsick[,"X"],newsick[,"Y"],pch=forme[1],col=darkcols[1],cex=2)igraphUsing library(igraph), it is possible to compute distances, for instance to get to the first hospital in our list (from the location of the sick person)
library(igraph)
g <- make_graph(edges = as.vector(rbind(arcs[,1],arcs[,2])),directed=FALSE)
sp <- shortest_paths(g, newsick[1,"NO"], newhospital[1,"NO"], weights= arcs[,3])
pth <- as.numeric(sp$vpath[[1]])
back_paris()
points(nodes[,c("V3","V4")],pch=19)
for(i in 1:nrow(arcs)) segments(nodes[arcs$V1[i],"V3"],nodes[arcs$V1[i],"V4"],
nodes[arcs$V2[i],"V3"],nodes[arcs$V2[i],"V4"],col="grey")
points(nodes[pth,c("V3","V4")],col=darkcols[3],pch=19)
for(i in 1:(length(pth)-1)) segments(nodes[pth[i],"V3"],nodes[pth[i],"V4"],
nodes[pth[i+1],"V3"],nodes[pth[i+1],"V4"],col=darkcols[3],lwd=5)
PCH=rep(1,nrow(newhospital))
PCH[1]=forme[2]
points(newhospital[,"X"],newhospital[,"Y"],pch=PCH,col=darkcols[2],cex=2,lwd=2)
points(newsick[,"X"],newsick[,"Y"],pch=forme[1],col=darkcols[1],cex=2)or the third one
library(igraph)
g <- make_graph(edges = as.vector(rbind(arcs[,1],arcs[,2])),directed=FALSE)
sp <- shortest_paths(g, newsick[1,"NO"], newhospital[3,"NO"], weights= arcs[,3])
pth <- as.numeric(sp$vpath[[1]])
back_paris()
points(nodes[,c("V3","V4")],pch=19)
for(i in 1:nrow(arcs)) segments(nodes[arcs$V1[i],"V3"],nodes[arcs$V1[i],"V4"],
nodes[arcs$V2[i],"V3"],nodes[arcs$V2[i],"V4"],col="grey")
points(nodes[pth,c("V3","V4")],col=darkcols[3],pch=19)
for(i in 1:(length(pth)-1)) segments(nodes[pth[i],"V3"],nodes[pth[i],"V4"],
nodes[pth[i+1],"V3"],nodes[pth[i+1],"V4"],col=darkcols[3],lwd=5)
PCH=rep(1,nrow(newhospital))
PCH[3]=forme[2]
points(newhospital[,"X"],newhospital[,"Y"],pch=PCH,col=darkcols[2],cex=2,lwd=2)
points(newsick[,"X"],newsick[,"Y"],pch=forme[1],col=darkcols[1],cex=2)Distances are respectively
FALSE [,1]
FALSE [1,] 2872.404
FALSE [,1]
FALSE [1,] 6029.571
On a graph, we get
plot(0:1,0:1,col="white",xlab="",ylab="",axes=FALSE)
text(.125,.5,"DEMAND",srt=90,col=darkcols[1])
text(.875,.5,"SUPPLY",srt=270,col=darkcols[2])
agents=data.frame(X=c(newhospital$X,newsick$X),Y=c(newhospital$Y,newsick$Y),
Type=c(rep("Supply",nrow(newhospital)),c(rep("Demand",nrow(newsick)))))
i=which(agents$Type=="Demand")
y1=rev(seq(1/(2*length(i)),1-1/(2*length(i)),by=1/(2*length(i)))[seq(1,2*length(i),by=2)])
i=which(agents$Type=="Supply")
y2=rev(seq(1/(2*length(i)),1-1/(2*length(i)),by=1/(2*length(i)))[seq(1,2*length(i),by=2)])
id=which(agents$Type=="Demand")
for(i in 1:sum(agents$Type=="Demand")){
d=rep(NA,sum(agents$Type=="Supply"))
for(j in 1:sum(agents$Type=="Supply")){
d[j]=distances(g, newsick[i,"NO"], newhospital[j,"NO"], weights= arcs[,3])
}
segments(.25,y1[i],.75,y2,col=c("black",darkcols[3])[1+(d==min(d))],lwd=c(1,6)[1+(d==min(d))])
text(.5,(y2+y1[i])/2,round(d),pos=1,col=c("black",darkcols[3])[1+(d==min(d))])
}
i=which(agents$Type=="Demand")
points(rep(.25,length(i)),y1,
pch=forme[1],col=darkcols[1],cex=3.2)
text(rep(.25,length(i)),y1,i,col="white")
i=which(agents$Type=="Supply")
points(rep(.75,length(i)),y2,
pch=forme[2],col=darkcols[2],cex=3.2)
text(rep(.75,length(i)),y2,i,col="white")Here is the closest hopital (here the th one), for our sick agent
FALSE [1] 5
library(igraph)
g <- make_graph(edges = as.vector(rbind(arcs[,1],arcs[,2])),directed=FALSE)
sp <- shortest_paths(g, newsick[1,"NO"], newhospital[which.min(d),"NO"], weights= arcs[,3])
pth <- as.numeric(sp$vpath[[1]])
back_paris()
points(nodes[,c("V3","V4")],pch=19)
for(i in 1:nrow(arcs)) segments(nodes[arcs$V1[i],"V3"],nodes[arcs$V1[i],"V4"],
nodes[arcs$V2[i],"V3"],nodes[arcs$V2[i],"V4"],col="grey")
points(nodes[pth,c("V3","V4")],col=darkcols[3],pch=19)
for(i in 1:(length(pth)-1)) segments(nodes[pth[i],"V3"],nodes[pth[i],"V4"],
nodes[pth[i+1],"V3"],nodes[pth[i+1],"V4"],col=darkcols[3],lwd=5)
PCH=rep(1,nrow(newhospital))
PCH[which(d==min(d))]=forme[2]
points(newhospital[,"X"],newhospital[,"Y"],pch=PCH,col=darkcols[2],cex=2,lwd=2)
points(newsick[,"X"],newsick[,"Y"],pch=forme[1],col=darkcols[1],cex=2)