Update combining costs

R/combineCosts.R

@@ -8,11 +8,11 @@
 #' Note that costs are inversely proportional to connectivity between edges:
 #' the larger the cost associated to an edge, the lower the connectivity
 #' between the two concerned nodes.\cr
-#' 
+#'
 #' Also note that 'costs' defined in \code{geoGraph} are equivalent to
 #' 'weights' as defined in \code{graph} and \code{RBGL} packages.
-#' 
-#' @param x1 The firt gGraph (which will be used as a template to build the combined gGraph )
+#'
+#' @param x1 The firt gGraph (which will be used as a template to build the combined gGraph)
 #' @param x2 The second gGraph from which costs will be combined
 #' @param method a character string indicating which method should be used to
 #' combined edge cost from the two gGraph. Currently available options are 'sum',
@@ -27,8 +27,10 @@
 #' data("worldgraph.40k")
 #' # new graph with custom cost function
 #' exp.cost <- function(x1, x2, cost.coeff) {
-#'  exp(-abs(x1 - x2) * cost.coeff)
+#'   exp(-abs(x1 - x2) * cost.coeff)
 #' }
+#' # create a set of node costs
+#' [email protected]$meanProd <- runif(n = 40962)
 #' new_costs_graph <-
 #'   setCosts(
 #'     worldgraph.40k,
@@ -38,51 +40,50 @@
 #'     cost.coeff = 0.5
 #'   )
 #' # combine costs from the original graph with the new costs
-#' combine_costs_graph<- combineCosts(worldgraph.40k, new_costs_graph, method="sum")
-
+#' combine_costs_graph <- combineCosts(worldgraph.40k, new_costs_graph, method = "sum")
 ###############
 ## combineCosts
 ###############
-combineCosts <- function(x1, x2, method=c("sum", "product", "function"), FUN=NULL,...){
+combineCosts <- function(x1, x2, method = c("sum", "product", "function"), FUN = NULL, ...) {
   ## some checks + argument handling
-  if(!is.gGraph(x1)) stop("x1 is not a valid gGraph object")
-  if(!is.gGraph(x2)) stop("x2 is not a valid gGraph object")
-  if(!hasCosts(x1)) stop("x1 is does not have costs; use setCosts to set the costs first")
-  if(!hasCosts(x2)) stop("x1 is does not have costs; use setCosts to set the costs first")
+  if (!is.gGraph(x1)) stop("x1 is not a valid gGraph object")
+  if (!is.gGraph(x2)) stop("x2 is not a valid gGraph object")
+  if (!hasCosts(x1)) stop("x1 is does not have costs; use setCosts to set the costs first")
+  if (!hasCosts(x2)) stop("x1 is does not have costs; use setCosts to set the costs first")
   method <- match.arg(method)
 
   ## get the edges and weights from teh two graphs
   myGraph1 <- getGraph(x1)
   edgeW1 <- edgeWeights(myGraph1)
   edgeL1 <- edgeL(myGraph1)
-  
+
   myGraph2 <- getGraph(x2)
   edgeW2 <- edgeWeights(myGraph2)
   edgeL2 <- edgeL(myGraph2)
-  
+
   # test that the two graphs have the same edges
-  if (!all(unlist(edgeL1)==unlist(edgeL2))){
+  if (!all(unlist(edgeL1) == unlist(edgeL2))) {
     stop("the graphs differ in the edges they have")
   }
-  
+
   newEdgeL <- list()
-  for(i in 1:length(edgeL1)){
+  for (i in 1:length(edgeL1)) {
     newEdgeL[[i]] <- list()
     newEdgeL[[i]]$edges <- edgeL1[[i]]$edges
-    if (method=="sum"){
-      newEdgeL[[i]]$weights <- edgeW1[[i]]+edgeW2[[i]]
-    } else if (method=="product"){
-      newEdgeL[[i]]$weights <- edgeW1[[i]]*edgeW2[[i]]
-    } else if (method=="function"){
+    if (method == "sum") {
+      newEdgeL[[i]]$weights <- edgeW1[[i]] + edgeW2[[i]]
+    } else if (method == "product") {
+      newEdgeL[[i]]$weights <- edgeW1[[i]] * edgeW2[[i]]
+    } else if (method == "function") {
       newEdgeL[[i]]$weights <- FUN(edgeW1[[i]], edgeW2[[i]], ...)
     }
   }
-  
+
   names(newEdgeL) <- nodes(myGraph1) # items of the list must be named
-  
-  newGraph <- new("graphNEL", nodes=nodes(myGraph1), edgeL=newEdgeL)
+
+  newGraph <- new("graphNEL", nodes = nodes(myGraph1), edgeL = newEdgeL)
   res <- x1
   res@graph <- newGraph
-  
+
   return(res)
-} # end combineCosts
+} # end combineCosts

R/setCosts.R

@@ -11,7 +11,7 @@
 #' for the chosen attribute, which is associated to a costs (a friction). The
 #' cost of an edge is computed as a function (see argument \code{method}) of
 #' the costs of its nodes.\cr
-#' 
+#'
 #' Note that costs are inversely proportional to connectivity between edges:
 #' the larger the cost associated to an edge, the lower the connectivity
 #' between the two concerned nodes.\cr
@@ -55,35 +55,30 @@
 #' x <- setCosts(x, attr.name = "habitat")
 #' plot(x, edges = TRUE)
 #' title("costs defined by habitat (land/land=1, other=100)")
-#' 
-#' 
-setCosts <- function(x, attr.name=NULL, node.costs=NULL, method=c("mean", "product", "function"), FUN=NULL,...){
-    ## some checks + argument handling
-    if(!is.gGraph(x)) stop("x is not a valid gGraph object")
-    method <- match.arg(method)
-    if ((method=="function") && (is.null(FUN))){
-        stop("if method='function', FUN needs to be defined.")
-    }
+#'
+setCosts <- function(x, attr.name = NULL, node.costs = NULL, method = c("mean", "product", "function"), FUN = NULL, ...) {
+  ## some checks + argument handling
+  if (!is.gGraph(x)) stop("x is not a valid gGraph object")
+  method <- match.arg(method)
+  if ((method == "function") && (is.null(FUN))) {
+    stop("if method='function', FUN needs to be defined.")
+  }
 
-    ## assign costs to vertices
-    if(is.null(node.costs)){ # costs from a node attribute
-        nodeAttr <- unlist(getNodesAttr(x, attr.name=attr.name))
-        if(!is.null(x@meta$costs)){
-            if(!any(attr.name %in% colnames(x@meta$costs))) {
-                stop("attr.name is not documented in x@meta$costs.")
-            }
-            nodeCosts <- as.character(nodeAttr)
-            rules <- x@meta$costs
-            for(i in 1:nrow(x@meta$costs)){
-                nodeCosts[nodeCosts==rules[i,attr.name]] <- rules[i,ncol(rules)]
-            }
-            nodeCosts <- as.numeric(nodeCosts)
-        } else stop("x@meta does not contain a 'costs' component.")
-    } else{ # cost directly provided
-        if(!is.numeric(node.costs)) stop("Provided 'node.costs' not numeric.")
-        node.costs <- rep(node.costs, length=length(getNodes(x))) # recycling node costs
-        nodeCosts <- node.costs
-        ## might add some more checks here...
+  ## assign costs to vertices
+  if (is.null(node.costs)) { # costs from a node attribute
+    nodeAttr <- unlist(getNodesAttr(x, attr.name = attr.name))
+    if (!is.null(x@meta$costs)) {
+      if (!any(attr.name %in% colnames(x@meta$costs))) {
+        stop("attr.name is not documented in x@meta$costs.")
+      }
+      nodeCosts <- as.character(nodeAttr)
+      rules <- x@meta$costs
+      for (i in 1:nrow(x@meta$costs)) {
+        nodeCosts[nodeCosts == rules[i, attr.name]] <- rules[i, ncol(rules)]
+      }
+      nodeCosts <- as.numeric(nodeCosts)
+    } else {
+      stop("x@meta does not contain a 'costs' component.")
     }
   } else { # cost directly provided
     if (!is.numeric(node.costs)) stop("Provided 'node.costs' not numeric.")
@@ -92,7 +87,6 @@ setCosts <- function(x, attr.name=NULL, node.costs=NULL, method=c("mean", "produ
     ## might add some more checks here...
   }
 
-
   ## find costs of edges as a function of terminating vertices
   EL <- getGraph(x)@edgeL
 
@@ -110,17 +104,17 @@ setCosts <- function(x, attr.name=NULL, node.costs=NULL, method=c("mean", "produ
     }
   }
 
-    ## method == function ##
-    if (method=="function"){
-        for(i in 1:length(EL)){
-            EL[[i]]$weights <- FUN(nodeCosts[i], nodeCosts[EL[[i]]$edges], ...)
-        }            
+  ## method == function ##
+  if (method == "function") {
+    for (i in 1:length(EL)) {
+      EL[[i]]$weights <- FUN(nodeCosts[i], nodeCosts[EL[[i]]$edges], ...)
     }
-
-    ## return result
-    newGraph <- new("graphNEL", nodes=getNodes(x), edgeL=EL)
-    res <- x
-    res@graph <- newGraph
+  }
+
+  ## return result
+  newGraph <- new("graphNEL", nodes = getNodes(x), edgeL = EL)
+  res <- x
+  res@graph <- newGraph
 
   return(res)
 } # end setCosts