Find routes between 2 points in R - r

Question

With following data of start and end points, how can we get routes between 2 points.
> ddf
start end
1 a b
2 a c
3 b e
4 b f
5 b c
6 a d
7 e f
8 f g
> dput(ddf)
structure(list(start = structure(c(1L, 1L, 2L, 2L, 2L, 1L, 3L,
4L), .Label = c("a", "b", "e", "f"), class = "factor"), end = structure(c(1L,
2L, 4L, 5L, 2L, 3L, 5L, 6L), .Label = c("b", "c", "d", "e", "f",
"g"), class = "factor")), .Names = c("start", "end"), class = "data.frame", row.names = c(NA,
-8L))
>
This page (http://www.anselm.edu/homepage/mmalita/culpro/graf1.html) shows only 2 line solution in Prolog! Following code works but does not give correct output list. It can be started with mainpath(ddf, 'a', 'f') to find path between 'a' and 'f'.
mainpath = function(ddf, startpt, endpt){
ddf$start = as.character(ddf$start)
ddf$end = as.character(ddf$end)
nodenames = sort(unique(c(ddf$start, ddf$end)))
routev=c(startpt)
if(is_arc(ddf, startpt, endpt, routev)) {return("Direct route found."); }
else{
nodenames = nodenames[which(nodenames!=startpt)]
nodenames = nodenames[which(nodenames!=endpt )]
if(is_path(ddf, nodenames, startpt, endpt, routev))
return ("Completed successfully")
else return ("Could not find a path.")
}
}
is_arc = function(ddf, frompt, topt, routevector){
len = nrow(ddf)
for(i in 1:len)
if(frompt == ddf$start[i] && topt == ddf$end[i]) {
routevector = append(routevector, frompt)
routevector = append(routevector, topt)
print(routevector)
return (TRUE);
}
return (FALSE)
}
is_path = function(ddf, othernodes, frompt, topt, routevector){
if(is_arc(ddf, frompt, topt, routevector)){
return (TRUE)
}
if(length(othernodes)==0){
print(routevector)
return (FALSE)
}
for(i in 1:length(othernodes)){
intermediate = othernodes[i]
if(is_arc(ddf, frompt, intermediate, routevector) && is_path(ddf, othernodes, intermediate, topt, routevector)){
return (TRUE)
}
}
print(routevector)
return (FALSE)
}
I am sure it can be much improved, especially all these for loops etc can be removed using apply etc functions. I know that packages with such functions are available but how can it be done in base R?
Your answers / comments will be appreciated.

Answer 1

While I'm sure there are wonderful ways to do this with linear algebra, here's a relatively intuitive method (using dplyr here, but translate as you like):
library(dplyr)
# convert factors to characters, filter down to possible starting points
df %>% mutate_each(funs(as.character)) %>% filter(start == 'a') %>%
# join to add possible next steps, indexing endpoints to startpoints
left_join(df, by = c('end' = 'start')) %>%
# iterate for successive steps
left_join(df, by = c('end.y' = 'start')) %>%
left_join(df, by = c('end.y.y' = 'start')) %>%
# chop out rows that didn't end at 'g' (omit if you're curious)
filter(apply(., 1, function(x){x[length(na.omit(x))]}) == 'g')
# start end.x end.y end.y.y end
# 1 a b e f g
# 2 a b f g <NA>
If df is factors, you'll get warnings about coercing, though it'll run fine (coerce to start or add %>% mutate_each(funs(as.character)) to each df call and they'll go away). The column names are a bit ugly; set them with left_join's suffix parameter or select or rename if you like.
Obviously the iteration of joins invites a loop, which might look as such:
df2 <- df %>% mutate_each(funs(as.character)) %>% filter(start == 'a')
for(i in 0:2){
endcol <- paste0('end', paste(rep('.y', i), collapse = ''))
df2 <- df2 %>% left_join(df, by = setNames('start', endcol))
}
df2 %>% filter(apply(., 1, function(x){x[length(na.omit(x))]}) == 'g')
# start end.x end.y end.y.y end
# 1 a b e f g
# 2 a b f g <NA>
If you set the number of iterations too high, it will error out because there are no rows to join to, but the error is actually quite convenient, as the loop has already saved the df2 you want, so the error just stops extra work from being done. Add tryCatch if you like, or go the other direction and refactor it into a scary-looking while loop which will actually iterate the perfect number of times:
df2 <- df %>% mutate_each(funs(as.character)) %>% filter(start == 'a')
endcol <- 'end' # initialize iterating variable
while(TRUE){
df2 <- df2 %>% left_join(df, by = setNames('start', endcol))
endcol <- paste0(endcol, '.y')
}
df2 %>% filter(apply(., 1, function(x){x[length(na.omit(x))]}) == 'g')
# start end.x end.y end.y.y end
# 1 a b e f g
# 2 a b f g <NA>

Answer 2

Following is much shorter and easily understandable, recursive function using base R. (First 2 lines are not needed if start and end columns of data.frame being sent are already character and not factor).
mainpath2 = function(ddf, startpt, endpt, route=c()){
ddf$start = as.character(ddf$start)
ddf$end = as.character(ddf$end)
if(startpt == endpt) return("Error: Same Start and End points.\n")
for(i in 1:nrow(ddf)){
if(ddf$start[i] == startpt){
route = append(route, startpt)
if(ddf$end[i] == endpt){
# PATH FOUND:
route = append(route, endpt)
print(route)
}
else mainpath2(ddf[-i, ], ddf$end[i], endpt, route)
route = route[-length(route)]
}
}
}
> mainpath2(ddf, 'a', 'g')
[1] "a" "b" "e" "f" "g"
[1] "a" "b" "f" "g"