Simplify dijkstra code and add tests

DESCRIPTION

@@ -34,11 +34,10 @@ Suggests:
     rmarkdown,
     rnaturalearthdata,
     spelling
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.0
 Collate: 
     'classes.R'
     'accessors.R'
-    'auxil.R'
     'basicMethods.R'
     'buffer.R'
     'closestNode.R'
@@ -49,10 +48,13 @@ Collate:
     'dropDead.R'
     'extractFromLayer.R'
     'findLand.R'
+    'geo.segments.R'
     'geograph.R'
     'globals.R'
+    'hasCosts.R'
     'interact.R'
     'isInArea.R'
+    'keepMaxConnected.R'
     'makeGrid.R'
     'plot.R'
     'rebuild.R'

NAMESPACE

@@ -2,7 +2,6 @@
 
 S3method(plot,gPath)
 export("%>%")
-export()
 export(.gData.valid)
 export(.gGraph.valid)
 export(.zoomlog.up)
@@ -42,6 +41,7 @@ export(is.gData)
 export(is.gGraph)
 export(isInArea)
 export(isReachable)
+export(keepMaxConnectedSet)
 export(makeGrid)
 export(plotEdges)
 export(setCosts)

R/connectivity.R

@@ -162,6 +162,25 @@
 }) # end isConnected for gData
 
 
+## the GENERIC of this method is given in package 'graph'
+#' @rdname connectivity
+#' @export
+setMethod("isConnected", "gGraph", function(object, ...) {
+  ## checks ##
+  if (!is.gGraph(object)) stop("'object' is not a valid gData object.")
+
+  ## set args for areConnected ##
+  myNodes <- getNodes(object)
+  ## wrapper ##
+  res <- areConnected(object, myNodes)
+
+  ## return res ##
+  return(res)
+}) # end isConnected for gGraph
+
+
+
+
 
 
 

R/dijkstra.R

@@ -163,51 +163,58 @@
 #' @rdname dijkstra-methods
 #' @export
 setMethod("dijkstraBetween", "gData", function(x) {
-  ## temp <- function(x){ # for debugging
+  # we transform the gData object to gGraph, extracting the nodes from the gData object.
+  # The node ids are found in the @nodes.id of the gData object: in this case we
+  # can call  getNodes(). 
+  # Then simply pass the new gGraph object to the method for gGraph.
 
   ## some checks ##
   if (!require(RBGL)) stop("RBGL is required.")
   if (!is.gData(x)) stop("x is not a valid gData object")
   if (!exists([email protected], envir = .GlobalEnv)) stop(paste("gGraph object", [email protected], "not found."))
   if (length([email protected]) == 0) stop("No assigned nodes ([email protected] is empty).")
-  if (!isConnected(x)) stop("Not all locations are connected by the graph.")
+  # if (!isConnected(x)) stop("Not all locations are connected by the graph.")
 
   ## build the wrapper ##
+  # @TODO check labels to keep
   myGraph <- get([email protected], envir = .GlobalEnv)
-  coords <- getCoords(myGraph) # store xy coords for later
-  myGraph <- getGraph(myGraph) # don't do this before getCoords
-
-  ## build indices of all pairwise combinations ##
-  pairIdStart <- integer()
-  pairIdStop <- integer()
-
-  for (i in 1:(length(getNodes(x)) + 1)) {
-    j <- i
-    while ((j <- j + 1) < length(getNodes(x)) + 1) {
-      pairIdStart <- c(pairIdStart, i)
-      pairIdStop <- c(pairIdStop, j)
-    }
-  }
-
-  ## wrap ##
-  ## ! sp.between does not return duplicated paths
-  res <- RBGL::sp.between(myGraph, start = [email protected][pairIdStart], finish = [email protected][pairIdStop])
-
-
-  ## handle duplicated paths ##
-  if (length(res) < length(pairIdStart)) { # res should have length = pairIdStart
-    fromTo <- paste([email protected][pairIdStart], [email protected][pairIdStop], sep = ":") # all different paths
-    res <- res[fromTo]
-  }
-
-
-  ## make it a class "gPath" (output + xy coords) ##
-  allNodes <- unique(unlist(lapply(res, function(e) e$path_detail)))
-  ## res$xy <- getCoords(x)[allNodes,]
-  attr(res, "xy") <- coords[allNodes, ]
-  class(res) <- "gPath"
-
-  return(res)
+  myNodes <- getNodes(x)
+  dijkstraBetween(myGraph,from=myNodes, to=myNodes)
+  # 
+  # coords <- getCoords(myGraph) # store xy coords for later
+  # myGraph <- getGraph(myGraph) # don't do this before getCoords
+  # 
+  # ## build indices of all pairwise combinations ##
+  # pairIdStart <- integer()
+  # pairIdStop <- integer()
+  # 
+  # for (i in 1:(length(getNodes(x)) + 1)) {
+  #   j <- i
+  #   while ((j <- j + 1) < length(getNodes(x)) + 1) {
+  #     pairIdStart <- c(pairIdStart, i)
+  #     pairIdStop <- c(pairIdStop, j)
+  #   }
+  # }
+  # 
+  # ## wrap ##
+  # ## ! sp.between does not return duplicated paths
+  # res <- RBGL::sp.between(myGraph, start = [email protected][pairIdStart], finish = [email protected][pairIdStop])
+  # 
+  # 
+  # ## handle duplicated paths ##
+  # if (length(res) < length(pairIdStart)) { # res should have length = pairIdStart
+  #   fromTo <- paste([email protected][pairIdStart], [email protected][pairIdStop], sep = ":") # all different paths
+  #   res <- res[fromTo]
+  # }
+  # 
+  # 
+  # ## make it a class "gPath" (output + xy coords) ##
+  # allNodes <- unique(unlist(lapply(res, function(e) e$path_detail)))
+  # ## res$xy <- getCoords(x)[allNodes,]
+  # attr(res, "xy") <- coords[allNodes, ]
+  # class(res) <- "gPath"
+  # 
+  # return(res)
 }) # end dijkstraBetween for gData
 
 
@@ -249,21 +256,24 @@
   if (!all(start %in% getNodes(x))) stop("Starting node is not in x.")
 
   ## check connectivity ##
-  if (!areConnected(x, getNodes(myGraph))) stop("Not all nodes are connected by the graph.")
-
+  if (!areConnected(x, getNodes(x))) stop("Not all nodes are connected by the graph.")
+  
   ## build the wrapper ##
   myGraph <- getGraph(x)
   ##  if(is.character(costs) && costs=="default"){
   ##         costs <- unlist(edgeWeights(myGraph))
+  endNodes <- getNodes(x)[!getNodes(x) %in% start] 
   ##     }
-
+#browser()
   ## wrap ##
-  res <- RBGL::dijkstra.sp(myGraph, start = start)
+  #res <- RBGL::dijkstra.sp(myGraph, start = start)
+  res <- RBGL::sp.between(myGraph, start = start, 
+                          finish = endNodes)
 
   ## sp.between uses unique([email protected]) ##
   ## eventually have to duplicate paths ##
   temp <- gsub(".*:", "", names(res))
-  res <- res[match(getNodes(x), temp)]
+  res <- res[match(endNodes, temp)]
 
 
   ## make it a class "gPath" (output + xy coords) ##

R/auxil.R → R/geo.segments.R

@@ -1,21 +1,16 @@
-#' Auxiliary methods for geoGraph
-#'
-#' These methods are low-level functions called by other procedures of
-#' \code{geoGraph}. Some can, however, be useful in themselves. Note that
-#' unlike other functions in \code{geoGraph}, these functions do not generally
-#' test for the validity of the provided arguments (for speed purposes).\cr
-#'
-#' - \code{hasCosts}: tests whether a \linkS4class{gGraph} has costs associated
-#' to its edges.\cr
-#'
-#' - \code{geo.segments}: a substitute to \code{segments} which correctly draws
-#' segments between locations distant by more than 90 degrees of longitude.\cr
-#'
-#' - \code{rebuild}: in development.
+#' Plot segments correctly when crossing the antimeridian
 #'
+#' A substitute to \code{segments} which correctly draws
+#' segments between locations distant by more than 90 degrees of longitude 
+#' (i.e. from one hemisphere to the other). It is used instead of segments, but
+#' it is slower.
+#' 
+#' This low-level function is designed to be called  by other procedures of
+#' [geoGraph]. However, it can sometimes be useful by itself. Note that
+#' unlike other functions in \code{geoGraph}, this functions does not
+#' test for the validity of the provided arguments (for speed purposes).
 #'
 #' @aliases hasCosts rebuild geo.segments
-#' @param x a valid \linkS4class{gGraph}.
 #' @param x0,y0 coordinates of points *from* which to draw.
 #' @param x1,y1 coordinates of points *to* which to draw.
 #' @param col a character string or an integer indicating the color of the
@@ -24,52 +19,10 @@
 #' @param lwd an integer indicating the line width.
 #' @param \dots further graphical parameters (from 'par') passed to the
 #' \code{segments} function.
-#' @return For \code{hasCost}, a logical value is returned. \code{geo.segments}
-#' returns NULL.
-
+#' @return NULL.
+#' 
 #' @keywords utilities methods
 #' @name auxiliary
-#' @examples
-#'
-#' hasCosts(worldgraph.10k)
-#'
-NULL
-
-
-
-##############
-## hasCosts
-##############
-#' @rdname auxiliary
-#' @export
-
-hasCosts <- function(x) {
-  if (length(getGraph(x)@edgeData@data) == 0) {
-    return(FALSE)
-  }
-  w <- getCosts(x, res.type = "vector")
-  if (length(unique(w)) < 2) {
-    return(FALSE)
-  }
-  return(TRUE)
-}
-
-
-
-
-
-
-###################
-## geo.segments
-###################
-##
-## Rectifies segments drawn from one hemisphere to another
-## in the wrong direction (i.e. not the shortest path)
-## and draws it.
-##
-## Is to be called instead segments but will be slower.
-##
-#' @rdname auxiliary
 #' @export
 
 geo.segments <- function(x0, y0, x1, y1,
@@ -78,39 +31,39 @@ geo.segments <- function(x0, y0, x1, y1,
   THRES <- 90
   XMIN <- graphics::par("usr")[1]
   XMAX <- graphics::par("usr")[2]
-
+  
   ## pin down problematic segments ##
   toChange <- abs(x0 - x1) > THRES
   if (sum(toChange) == 0) { # exit here if everything is ok.
     graphics::segments(x0, y0, x1, y1,
-      col = col, lty = lty, lwd = lwd, ...
+                       col = col, lty = lty, lwd = lwd, ...
     )
     return(invisible())
   }
-
+  
   ## isolate problematic segments ##
   x0.ok <- x0[!toChange] # these are ok
   x1.ok <- x1[!toChange]
   y0.ok <- y0[!toChange]
   y1.ok <- y1[!toChange]
-
+  
   x0 <- x0[toChange] # problematic
   x1 <- x1[toChange]
   y0 <- y0[toChange]
   y1 <- y1[toChange]
-
-
+  
+  
   ## sort x and y coordinates so that x0 < x1 ##
   toInvert <- (x0 > x1)
   temp <- x0[toInvert] # x coords
   x0[toInvert] <- x1[toInvert]
   x1[toInvert] <- temp
-
+  
   temp <- y0[toInvert] # y coords
   y0[toInvert] <- y1[toInvert]
   y1[toInvert] <- temp
-
-
+  
+  
   ## define new segments ##
   ## notations:
   ## - x0: x coord, left point
@@ -121,14 +74,14 @@ geo.segments <- function(x0, y0, x1, y1,
   ## - h0, h1: differential of y coord for new coord
   ## (h0/d0 = h1/d1)
   ## - H: distance between y0 and y1
-
-
+  
+  
   d0 <- x0 - XMIN
   d1 <- XMAX - x1
   H <- abs(y1 - y0)
   h0 <- H * (d0 / d1) / (1 + (d0 / d1))
   h1 <- H - h0
-
+  
   x0.new <- rep(XMIN, length(x0))
   x1.new <- rep(XMAX, length(x1))
   ## for y coords, h0 (resp. h1) can be added or subtracted, depending on yo < y1
@@ -137,11 +90,11 @@ geo.segments <- function(x0, y0, x1, y1,
   facMod.1 <- facMod.0 * -1
   h0 <- h0 * facMod.0
   h1 <- h1 * facMod.1
-
+  
   y0.new <- y0 + h0
   y1.new <- y1 + h1
-
-
+  
+  
   ## add new segments to old segments ##
   ## order: old segments, new segments
   ## new segments: x0=original coords
@@ -150,21 +103,21 @@ geo.segments <- function(x0, y0, x1, y1,
   y0.out <- c(y0, y1)
   x1.out <- c(x0.new, x1.new)
   y1.out <- c(y0.new, y1.new)
-
-
+  
+  
   ## final call to segments ##
   ## non-modified segments
   oxpd <- graphics::par("xpd")
   graphics::par(xpd = TRUE)
   graphics::segments(x0.ok, y0.ok, x1.ok, y1.ok,
-    col = col, lty = lty, lwd = lwd, ...
+                     col = col, lty = lty, lwd = lwd, ...
   )
-
+  
   ## modified segments
   graphics::segments(x0.out, y0.out, x1.out, y1.out,
-    col = col, lty = 3, lwd = lwd, ...
+                     col = col, lty = 3, lwd = lwd, ...
   )
-
+  
   graphics::par(xpd = oxpd)
   return(invisible())
 } # end geo.segments