Skip to content

Commit

Permalink
Merge branch 'master' into sf
Browse files Browse the repository at this point in the history
  • Loading branch information
dramanica committed Dec 5, 2023
2 parents 293371a + cd9deb1 commit eac996f
Show file tree
Hide file tree
Showing 35 changed files with 1,664 additions and 38 deletions.
3 changes: 2 additions & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Package: geoGraph
Type: Package
Title: Walking through the geographic space using graphs
Version: 1.1.1.9001
Version: 1.1.1.9002
Author: Thibaut Jombart,
Andrea Manica
Maintainer: Andrea Manica <[email protected]>
Expand Down Expand Up @@ -36,6 +36,7 @@ Collate:
'basicMethods.R'
'buffer.R'
'closestNode.R'
'combineCosts.R'
'connectivity.R'
'datasets.R'
'dijkstra.R'
Expand Down
1 change: 1 addition & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@ export(areConnected)
export(areNeighbours)
export(buffer)
export(closestNode)
export(combineCosts)
export(connectivityPlot)
export(dijkstraBetween)
export(dijkstraFrom)
Expand Down
89 changes: 89 additions & 0 deletions R/combineCosts.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,89 @@
#' Combine the costs of two gGraph objects
#'
#' The function \code{combineCosts} combines the edge costs of two
#' \linkS4class{gGraph} objects. The first object is used as a temlate to generate
#' the objects with the combined costs. Two two \linkS4class{gGraph} objects must
#' have the same edges.
#'
#' 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 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',
#' 'prod' and 'function', where the combined costs are computed as the sum,
#' the product or a custom function (defined in \code{FUN}) of the costs of its nodes.
#' @param FUN a function used to compute the cost between two nodes (needed if \code{method="function"}).
#' @param \dots additional parameters to be passed to \code{FUN}.
#' @return A \linkS4class{gGraph} object with the newly defined costs, basedd on the combination of the
#' two gGraph objects, used as weightings of edges.
#' @export
#' @examples
#' data("worldgraph.40k")
#' # new graph with custom cost function
#' exp.cost <- function(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,
#' node.values = [email protected]$meanProd,
#' method = "function",
#' FUN = exp.cost,
#' 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")
###############
## combineCosts
###############
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")
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))) {
stop("the graphs differ in the edges they have")
}

newEdgeL <- list()
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") {
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)
res <- x1
res@graph <- newGraph

return(res)
} # end combineCosts
4 changes: 4 additions & 0 deletions R/findLand.R
Original file line number Diff line number Diff line change
Expand Up @@ -91,6 +91,10 @@ setMethod("findLand", "matrix", function(x, shape = "world", ...) {
}
}

if (any(is.na(x))) {
stop("Matrix contains NA values.")
}

long <- x[, 1]
lat <- x[, 2]
n.country <- length(shape@polygons)
Expand Down
34 changes: 22 additions & 12 deletions R/setCosts.R
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,7 @@
#' 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 proportionnal to connectivity between edges:
#' 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
#'
Expand All @@ -24,12 +24,14 @@
#' a \code{@meta$costs} component (for an example, see worldgraph.10k dataset).
#' @param attr.name the name of the node attribute used to compute costs (i.e.,
#' of one column of \code{@nodes.attr}).
#' @param node.costs a numeric vector giving costs associated to the nodes. If
#' @param node.values a numeric vector giving costs associated to the nodes. If
#' provided, it will be used instead of \code{attr.name}.
#' @param method a character string indicating which method should be used to
#' compute edge cost from nodes costs. Currently available options are 'mean'
#' and 'prod', where the cost associated to an edge is respectively computed as
#' the mean, or as the product of the costs of its nodes.
#' compute edge cost from nodes costs. Currently available options are 'mean',
#' 'prod' and 'function', where the cost associated to an edge is respectively computed as
#' the mean, the product or a custom function (defined in \code{FUN}) of the costs of its nodes.
#' @param FUN a function used to compute the cost between two nodes (needed if \code{method="function"}).
#' @param \dots additional parameters to be passed to \code{FUN}.
#' @return A \linkS4class{gGraph} object with the newly defined costs used as
#' weightings of edges.
#' @author Thibaut Jombart (\email{t.jombart@@imperial.ac.uk})
Expand All @@ -54,14 +56,16 @@
#' 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")) {
setCosts <- function(x, attr.name = NULL, node.values = 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
if (is.null(node.values)) { # 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))) {
Expand All @@ -77,13 +81,12 @@ setCosts <- function(x, attr.name = NULL, node.costs = NULL, method = c("mean",
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
if (!is.numeric(node.values)) stop("Provided 'node.values' not numeric.")
node.values <- rep(node.values, length = length(getNodes(x))) # recycling node costs
nodeCosts <- node.values
## might add some more checks here...
}


## find costs of edges as a function of terminating vertices
EL <- getGraph(x)@edgeL

Expand All @@ -101,6 +104,13 @@ setCosts <- function(x, attr.name = NULL, node.costs = NULL, method = c("mean",
}
}

## 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
Expand Down
Loading

0 comments on commit eac996f

Please sign in to comment.