diff --git a/.Rbuildignore b/.Rbuildignore index e144ce6..36ff8f4 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -5,3 +5,5 @@ README.Rmd ^\.Rproj\.user$ inst/shiny/.RData inst/shiny/.Rhistory +^\.github$ +data-raw diff --git a/.github/.gitignore b/.github/.gitignore new file mode 100644 index 0000000..2d19fc7 --- /dev/null +++ b/.github/.gitignore @@ -0,0 +1 @@ +*.html diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml new file mode 100644 index 0000000..028258f --- /dev/null +++ b/.github/workflows/R-CMD-check.yaml @@ -0,0 +1,29 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master, fix_check] + pull_request: + branches: [main, master] + +name: R-CMD-check + +jobs: + R-CMD-check: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + steps: + - uses: actions/checkout@v3 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/check-r-package@v2 diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 274e761..0000000 --- a/.travis.yml +++ /dev/null @@ -1,10 +0,0 @@ - -language: r - -warnings_are_errors: false - -sudo: required - -bioc_packages: -- graph -- RBGL \ No newline at end of file diff --git a/DESCRIPTION b/DESCRIPTION index 747df97..c524be3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: geoGraph Type: Package Title: Walking through the geographic space using graphs -Version: 1.1-1 +Version: 1.1.1.9001 Author: Thibaut Jombart, Andrea Manica Maintainer: Andrea Manica @@ -16,21 +16,16 @@ Depends: R (>= 3.5.0), methods, graph -Imports: - maptools, - MASS, +Imports: fields, - RBGL, + RBGL, sp -Remotes: - bioc::graph, - bioc::RBGL Suggests: testthat, knitr, rmarkdown, - BiocManager -RoxygenNote: 7.1.2 + sf +RoxygenNote: 7.2.3 Collate: 'classes.R' 'accessors.R' diff --git a/NAMESPACE b/NAMESPACE index 26b9d1b..243f0ad 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -36,7 +36,6 @@ export(getNodeCosts) export(getNodes) export(getNodesAttr) export(hasCosts) -export(installDep.geoGraph) export(is.gData) export(is.gGraph) export(isInArea) diff --git a/R/accessors.R b/R/accessors.R index 6e05699..3a42fb2 100644 --- a/R/accessors.R +++ b/R/accessors.R @@ -22,21 +22,21 @@ NULL ############## ## getGraph ############## -setGeneric("getGraph", function(x,...) { - standardGeneric("getGraph") +setGeneric("getGraph", function(x, ...) { + standardGeneric("getGraph") }) setMethod("getGraph", "gGraph", function(x, ...) { - res <- x@graph - return(res) + res <- x@graph + return(res) }) setMethod("getGraph", "gData", function(x, ...) { - if(!exists(x@gGraph.name, envir=.GlobalEnv)) stop(paste("gGraph object",x@gGraph.name,"not found.")) - res <- getGraph(get(x@gGraph.name, envir=.GlobalEnv)) - return(res) + if (!exists(x@gGraph.name, envir = .GlobalEnv)) stop(paste("gGraph object", x@gGraph.name, "not found.")) + res <- getGraph(get(x@gGraph.name, envir = .GlobalEnv)) + return(res) }) @@ -76,42 +76,41 @@ setMethod("getGraph", "gData", function(x, ...) { #' ## gData method #' getNodesAttr(hgdp) #' -#' #' @export -setGeneric("getNodesAttr", function(x,...) { - standardGeneric("getNodesAttr") +setGeneric("getNodesAttr", function(x, ...) { + standardGeneric("getNodesAttr") }) #' @describeIn getNodesAttr Method for gGraph objects #' @export -setMethod("getNodesAttr", "gGraph", function(x, nodes=NULL, attr.name=NULL,...) { - if(is.null(nodes)){ # no node specified -> all nodes kept - nodes <- TRUE - } - if(is.null(attr.name)){ # no attr specified -> all attr kept - attr.name <- TRUE - } +setMethod("getNodesAttr", "gGraph", function(x, nodes = NULL, attr.name = NULL, ...) { + if (is.null(nodes)) { # no node specified -> all nodes kept + nodes <- TRUE + } + if (is.null(attr.name)) { # no attr specified -> all attr kept + attr.name <- TRUE + } - res <- x@nodes.attr[nodes,attr.name, drop=FALSE] + res <- x@nodes.attr[nodes, attr.name, drop = FALSE] - return(res) + return(res) }) #' @describeIn getNodesAttr Method for gData objects #' @export -setMethod("getNodesAttr", "gData", function(x, attr.name=NULL,...) { - if(is.null(attr.name)){ # no attr specified -> all attr kept - attr.name <- TRUE - } +setMethod("getNodesAttr", "gData", function(x, attr.name = NULL, ...) { + if (is.null(attr.name)) { # no attr specified -> all attr kept + attr.name <- TRUE + } - myNodes <- getNodes(x) - if(!exists(x@gGraph.name, .GlobalEnv)) stop("gGraph object not found in global environment.") - mygGraph <- get(x@gGraph.name, envir=.GlobalEnv) + myNodes <- getNodes(x) + if (!exists(x@gGraph.name, .GlobalEnv)) stop("gGraph object not found in global environment.") + mygGraph <- get(x@gGraph.name, envir = .GlobalEnv) - res <- getNodesAttr(mygGraph, nodes=myNodes, attr.name=attr.name) + res <- getNodesAttr(mygGraph, nodes = myNodes, attr.name = attr.name) - return(res) + return(res) }) @@ -147,26 +146,26 @@ setMethod("getNodesAttr", "gData", function(x, attr.name=NULL,...) { ############# #' @export setGeneric("getCoords", function(x, ...) { - standardGeneric("getCoords") + standardGeneric("getCoords") }) #' @export setMethod("getCoords", "gGraph", function(x, ...) { - res <- x@coords - return(res) + res <- x@coords + return(res) }) #' @export -setMethod("getCoords", "gData", function(x, original=TRUE, ...) { - if(original){ # original coords - res <- x@coords - } else { - res <- getCoords(get(x@gGraph.name, envir=.GlobalEnv))[getNodes(x),,drop=FALSE] # - } - rownames(res) <- x@nodes.id - return(res) +setMethod("getCoords", "gData", function(x, original = TRUE, ...) { + if (original) { # original coords + res <- x@coords + } else { + res <- getCoords(get(x@gGraph.name, envir = .GlobalEnv))[getNodes(x), , drop = FALSE] # + } + rownames(res) <- x@nodes.id + return(res) }) @@ -176,21 +175,21 @@ setMethod("getCoords", "gData", function(x, original=TRUE, ...) { ############# #' @export setGeneric("getNodes", function(x, ...) { - standardGeneric("getNodes") + standardGeneric("getNodes") }) #' @export setMethod("getNodes", "gGraph", function(x, ...) { - res <- rownames(x@coords) - return(res) + res <- rownames(x@coords) + return(res) }) #' @export setMethod("getNodes", "gData", function(x, ...) { - res <- x@nodes.id - return(res) + res <- x@nodes.id + return(res) }) @@ -236,45 +235,47 @@ setMethod("getNodes", "gData", function(x, ...) { #' example(gGraph) #' #' getEdges(x) -#' getEdges(x,res.type="matNames") -#' getEdges(x,res.type="matId") +#' getEdges(x, res.type = "matNames") +#' getEdges(x, res.type = "matId") #' setGeneric("getEdges", function(x, ...) { - standardGeneric("getEdges") + standardGeneric("getEdges") }) #' @export #' @describeIn getEdges Method for gGraph objects -setMethod("getEdges", "gGraph", function(x, res.type=c("asIs","matNames", "matId"), unique=FALSE, ...) { - res.type <- match.arg(res.type) -## if(res.type=="asIs") return(x@graph@edgeL) - if(res.type=="asIs") return(edges(x@graph)) - - if(res.type=="matNames"){ # return matrix of node names - res <- edges(x@graph) - temp <- sapply(res, length) - col1 <- rep(names(res), temp) - ## col1 <- rep(1:length(res), temp) - col2 <- unlist(res) - res <- cbind(Vi=col1, Vj=col2) - } - - if(res.type=="matId"){ # return matrix of node numbers - res <- edgeL(x@graph) - temp <- sapply(res, function(e) length(e$edges)) - col1 <- rep(1:length(res), temp) - col2 <- unlist(res) - res <- cbind(Vi=col1, Vj=col2) - } - - if(unique){ - toKeep <- res[,1] < res[,2] - res <- res[toKeep,, drop=FALSE] - } - - rownames(res) <- NULL - return(res) +setMethod("getEdges", "gGraph", function(x, res.type = c("asIs", "matNames", "matId"), unique = FALSE, ...) { + res.type <- match.arg(res.type) + ## if(res.type=="asIs") return(x@graph@edgeL) + if (res.type == "asIs") { + return(edges(x@graph)) + } + + if (res.type == "matNames") { # return matrix of node names + res <- edges(x@graph) + temp <- sapply(res, length) + col1 <- rep(names(res), temp) + ## col1 <- rep(1:length(res), temp) + col2 <- unlist(res) + res <- cbind(Vi = col1, Vj = col2) + } + + if (res.type == "matId") { # return matrix of node numbers + res <- edgeL(x@graph) + temp <- sapply(res, function(e) length(e$edges)) + col1 <- rep(1:length(res), temp) + col2 <- unlist(res) + res <- cbind(Vi = col1, Vj = col2) + } + + if (unique) { + toKeep <- res[, 1] < res[, 2] + res <- res[toKeep, , drop = FALSE] + } + + rownames(res) <- NULL + return(res) }) @@ -312,54 +313,55 @@ setMethod("getEdges", "gGraph", function(x, res.type=c("asIs","matNames", "matId #' @keywords utilities methods #' @export setGeneric("setEdges", function(x, ...) { - standardGeneric("setEdges") + standardGeneric("setEdges") }) #' @export #' @describeIn setEdges Method for gGraph object -setMethod("setEdges", "gGraph", function(x, add=NULL, remove=NULL, costs=NULL, ...) { - ## some checks - if(is.null(add) & is.null(remove)) return(x) - - if(!is.null(add)){ ## add edges ## - add <- as.data.frame(add) - if(ncol(add) != 2) stop("add does not have two columns") - from <- as.character(add[[1]]) - to <- as.character(add[[2]]) - if(!all(unique(c(from,to)) %in% getNodes(x))) stop("unknown specified nodes") # unknown nodes - if(is.null(costs)){ - costs <- rep(1, length(from)) - } - - myGraph <- suppressWarnings(addEdge(from=from, to=to, graph=x@graph, weights=costs)) - - } else { ## remove edges ## - remove <- as.data.frame(remove) - if(ncol(remove) != 2) stop("remove does not have two columns") - from <- as.character(remove[[1]]) - to <- as.character(remove[[2]]) - if(!all(unique(c(from,to)) %in% getNodes(x))) stop("unknown specified nodes") # unknown nodes - - ## avoid attempts to removing non-existing edges - temp <- areNeighbours(from, to, x@graph) - myGraph <- removeEdge(from=from[temp], to=to[temp], graph=x@graph) +setMethod("setEdges", "gGraph", function(x, add = NULL, remove = NULL, costs = NULL, ...) { + ## some checks + if (is.null(add) & is.null(remove)) { + return(x) + } + + if (!is.null(add)) { ## add edges ## + add <- as.data.frame(add) + if (ncol(add) != 2) stop("add does not have two columns") + from <- as.character(add[[1]]) + to <- as.character(add[[2]]) + if (!all(unique(c(from, to)) %in% getNodes(x))) stop("unknown specified nodes") # unknown nodes + if (is.null(costs)) { + costs <- rep(1, length(from)) } - ## subx <- deparse(substitute(x)) - res <- x - res@graph <- myGraph - - ## remember this action - curCall <- match.call() - ##newHist <- new("gGraphHistory", res@history, cmd=curCall, comments="Modified edges using setEdges.") - ##res@history <- newHist - - ## make assignement - ## parEnv <- parent.frame() - ## assign(subx, res, parEnv) - - return(res) + myGraph <- suppressWarnings(addEdge(from = from, to = to, graph = x@graph, weights = costs)) + } else { ## remove edges ## + remove <- as.data.frame(remove) + if (ncol(remove) != 2) stop("remove does not have two columns") + from <- as.character(remove[[1]]) + to <- as.character(remove[[2]]) + if (!all(unique(c(from, to)) %in% getNodes(x))) stop("unknown specified nodes") # unknown nodes + + ## avoid attempts to removing non-existing edges + temp <- areNeighbours(from, to, x@graph) + myGraph <- removeEdge(from = from[temp], to = to[temp], graph = x@graph) + } + + ## subx <- deparse(substitute(x)) + res <- x + res@graph <- myGraph + + ## remember this action + curCall <- match.call() + ## newHist <- new("gGraphHistory", res@history, cmd=curCall, comments="Modified edges using setEdges.") + ## res@history <- newHist + + ## make assignement + ## parEnv <- parent.frame() + ## assign(subx, res, parEnv) + + return(res) }) # end setEdges @@ -404,37 +406,39 @@ setMethod("setEdges", "gGraph", function(x, add=NULL, remove=NULL, costs=NULL, . #' @keywords utilities methods #' @examples #' -#' head(getEdges(worldgraph.10k, res.type="matNames",unique=TRUE)) -#' head(getCosts(worldgraph.10k,res.type="vector",unique=TRUE)) +#' head(getEdges(worldgraph.10k, res.type = "matNames", unique = TRUE)) +#' head(getCosts(worldgraph.10k, res.type = "vector", unique = TRUE)) #' #' ############## ## getCosts ############## setGeneric("getCosts", function(x, ...) { - standardGeneric("getCosts") + standardGeneric("getCosts") }) #' @describeIn getCosts Method for gGraph object #' @export -setMethod("getCosts", "gGraph", function(x, res.type=c("asIs","vector"), unique=FALSE, ...) { - res.type <- match.arg(res.type) - if(res.type=="asIs") return(edgeWeights(x@graph)) - - if(res.type=="vector"){ # return a matrix of node names - res <- edgeWeights(x@graph) - res <- unlist(res) # res is a vector of edge weights named as Ni.Nj - } - - if(unique){ - nodeNames <- names(res) - temp <- strsplit(nodeNames, "[.]") - toKeep <- sapply(temp, function(v) v[1] < v[2]) - res <- res[toKeep] - } - - return(res) +setMethod("getCosts", "gGraph", function(x, res.type = c("asIs", "vector"), unique = FALSE, ...) { + res.type <- match.arg(res.type) + if (res.type == "asIs") { + return(edgeWeights(x@graph)) + } + + if (res.type == "vector") { # return a matrix of node names + res <- edgeWeights(x@graph) + res <- unlist(res) # res is a vector of edge weights named as Ni.Nj + } + + if (unique) { + nodeNames <- names(res) + temp <- strsplit(nodeNames, "[.]") + toKeep <- sapply(temp, function(v) v[1] < v[2]) + res <- res[toKeep] + } + + return(res) }) @@ -446,17 +450,17 @@ setMethod("getCosts", "gGraph", function(x, res.type=c("asIs","vector"), unique= ############### #' @export setGeneric("dropCosts", function(x, ...) { - standardGeneric("dropCosts") + standardGeneric("dropCosts") }) #' @export setMethod("dropCosts", "gGraph", function(x) { - myGraph <- getGraph(x) - myGraph@edgeData@data <- list() - x@graph <- myGraph + myGraph <- getGraph(x) + myGraph@edgeData@data <- list() + x@graph <- myGraph - return(x) + return(x) }) @@ -467,14 +471,14 @@ setMethod("dropCosts", "gGraph", function(x) { ############# #' @export setGeneric("getData", function(x, ...) { - standardGeneric("getData") + standardGeneric("getData") }) #' @export setMethod("getData", "gData", function(x, ...) { - res <- x@data - return(res) + res <- x@data + return(res) }) @@ -522,59 +526,57 @@ setMethod("getData", "gData", function(x, ...) { #' worldgraph.10k@meta$color #' #' head(getNodes(worldgraph.10k)) -#' head(getColors(worldgraph.10k,res.type="vector", attr.name="habitat")) -#' +#' head(getColors(worldgraph.10k, res.type = "vector", attr.name = "habitat")) #' setGeneric("getColors", function(x, ...) { - standardGeneric("getColors") + standardGeneric("getColors") }) #' @export #' @describeIn getColors Method for gGraph objects -setMethod("getColors", "gGraph", function(x, nodes="all", attr.name, col.rules=NULL, ...) { - if(!attr.name %in% colnames(getNodesAttr(x))) { - stop("Requested attribute not found in x@nodes.attr.") - } - - if(is.null(col.rules)){ - if(is.null(x@meta$colors)){ - stop("No rule for color provided, and none defined in x (x@meta$colors is NULL).") - } else { - col.rules <- x@meta$colors - } - } +setMethod("getColors", "gGraph", function(x, nodes = "all", attr.name, col.rules = NULL, ...) { + if (!attr.name %in% colnames(getNodesAttr(x))) { + stop("Requested attribute not found in x@nodes.attr.") + } - if(is.null(ncol(col.rules)) || ncol(col.rules)!=2){ - stop("Color rules does not contain two columns.") - } - - if(!attr.name %in% colnames(col.rules)){ - stop(paste("Nothing known about",attr.name,"in color rules.")) - } - - ## handle nodes ## - if(length(nodes)==1 && nodes=="all"){ - toKeep <- TRUE - } else if(is.numeric(nodes)){ - toKeep <- nodes - } - else if(is.character(nodes)){ - toKeep <- match(nodes, getNodes(x)) - } else{ - stop("Don't know what to do with 'nodes': wrong specification.") - } - - ## define colors ## - criterion <- getNodesAttr(x, nodes=toKeep, attr.name=attr.name) # seek criterion in nodes.attr - col <- as.character(unlist(criterion)) - - for(i in 1:nrow(col.rules)){ - col[col==col.rules[i,1]] <- col.rules[i,2] + if (is.null(col.rules)) { + if (is.null(x@meta$colors)) { + stop("No rule for color provided, and none defined in x (x@meta$colors is NULL).") + } else { + col.rules <- x@meta$colors } - - names(col) <- getNodes(x)[toKeep] - return(col) + } + + if (is.null(ncol(col.rules)) || ncol(col.rules) != 2) { + stop("Color rules does not contain two columns.") + } + + if (!attr.name %in% colnames(col.rules)) { + stop(paste("Nothing known about", attr.name, "in color rules.")) + } + + ## handle nodes ## + if (length(nodes) == 1 && nodes == "all") { + toKeep <- TRUE + } else if (is.numeric(nodes)) { + toKeep <- nodes + } else if (is.character(nodes)) { + toKeep <- match(nodes, getNodes(x)) + } else { + stop("Don't know what to do with 'nodes': wrong specification.") + } + + ## define colors ## + criterion <- getNodesAttr(x, nodes = toKeep, attr.name = attr.name) # seek criterion in nodes.attr + col <- as.character(unlist(criterion)) + + for (i in 1:nrow(col.rules)) { + col[col == col.rules[i, 1]] <- col.rules[i, 2] + } + + names(col) <- getNodes(x)[toKeep] + return(col) }) # end getColors for gGraph @@ -590,30 +592,31 @@ setMethod("getColors", "gGraph", function(x, nodes="all", attr.name, col.rules=N #' @export #' @describeIn getCosts Function to get the costs values for nodes setGeneric("getNodeCosts", function(x, ...) { - standardGeneric("getNodeCosts") + standardGeneric("getNodeCosts") }) #' @describeIn getCosts Method to get node costs for gGraph object #' @export setMethod("getNodeCosts", "gGraph", function(x, attr.name, ...) { - if(!is.gGraph(x)) stop("x is not a valid gGraph object") - - ## assign costs to vertices - 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.") - - - return(nodeCosts) -}) # end getNodeCosts + if (!is.gGraph(x)) stop("x is not a valid gGraph object") + ## assign costs to vertices + 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.") + } + + + return(nodeCosts) +}) # end getNodeCosts diff --git a/R/auxil.R b/R/auxil.R index e63e537..4b602b2 100644 --- a/R/auxil.R +++ b/R/auxil.R @@ -43,11 +43,15 @@ NULL #' @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) +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) } @@ -69,134 +73,98 @@ hasCosts <- function(x){ #' @export geo.segments <- function(x0, y0, x1, y1, - col = graphics::par("fg"), lty = graphics::par("lty"), lwd = graphics::par("lwd"), ...){ - - ## some declarations ## - 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, ...) - 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 - ## - x1: x coord, right point - ## - d0: distance x0 - - XMIN - ## - d1: distance XMAX - x1 - ## - 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 - facMod.0 <- rep(-1, length(x0)) - facMod.0[y0 < y1] <- 1 - 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 - ## x1=new coords - x0.out <- c(x0, x1) - 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, ...) - - ## modified segments - graphics::segments(x0.out, y0.out, x1.out, y1.out, - col = col, lty = 3, lwd = lwd, ...) - - graphics::par(xpd=oxpd) + col = graphics::par("fg"), lty = graphics::par("lty"), lwd = graphics::par("lwd"), ...) { + ## some declarations ## + 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, ... + ) 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 + ## - x1: x coord, right point + ## - d0: distance x0 - + XMIN + ## - d1: distance XMAX - x1 + ## - 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 + facMod.0 <- rep(-1, length(x0)) + facMod.0[y0 < y1] <- 1 + 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 + ## x1=new coords + x0.out <- c(x0, x1) + 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, ... + ) + + ## modified segments + graphics::segments(x0.out, y0.out, x1.out, y1.out, + col = col, lty = 3, lwd = lwd, ... + ) + + graphics::par(xpd = oxpd) + return(invisible()) } # end geo.segments - - - - - - -####################### -## installDep.geoGraph -####################### - - -#' Install dependencies for geoGraph -#' -#' This simple function installs the latest versions of the packages -#' \code{graph} and \code{RBGL} on Bioconductor. This function requires a -#' working internet connection, as well as administrator rights for the -#' directory where the libraries are installed. -#' -#' -#' @author Thibaut Jombart (\email{t.jombart@@imperial.ac.uk}) -#' @keywords utilities -#' @export -installDep.geoGraph <- function(){ - cat("\nInstalling MASS, sp, maptools, fields from CRAN ... \n") - utils::install.packages("MASS") - utils::install.packages("sp") - utils::install.packages("maptools") - utils::install.packages("fields") - cat("\n...done.\n") - - cat("\nInstalling graph from Bioconductor ... \n") - BiocManager::install("graph") - cat("\n...done.\n") - - cat("\nInstalling RBGL from Bioconductor\n") - BiocManager::install("RBGL") - cat("\n...done.\n") -} # end checkInstall.geoGraph diff --git a/R/basicMethods.R b/R/basicMethods.R index 19a2a98..9eaf1a1 100644 --- a/R/basicMethods.R +++ b/R/basicMethods.R @@ -28,92 +28,94 @@ NULL ############ ## [ gGraph ############ -setMethod("[", "gGraph", function(x, i, j, ..., drop=TRUE) { - if(missing(i)) { - i <- TRUE - } - if(is.logical(i)){ - i <- rep(i, length=nrow(getCoords(x))) - } - if(is.character(i)) { - i <- match(i, getNodes(x)) - if(any(is.na(i))) stop("Some specified node labels were not found.") - } - if(missing(j)) { - j <- TRUE - } - - if(is.logical(i) && is.logical(j) && all(c(i,j))) return(x) # don't loose time for silly trials - - argList <- list(...) - if(is.null(argList$useSubGraph)){ - useSubGraph <- TRUE - } else { - useSubGraph <- argList$useSubGraph - } - - oldNodeNames <- getNodes(x) # node names before subsetting - newNodeNames <- oldNodeNames[i] # node names after subsetting - - - ## do the subsetting ## - res <- x - res@coords <- res@coords[i, , drop=FALSE] - if(nrow(res@nodes.attr)>0){ - res@nodes.attr <- res@nodes.attr[i, j, drop=FALSE] - } - ##if(useSubGraph){ # use procedure from graph package to subset graph (slow) # - - myGraph <- subGraph(nodes(res@graph)[i], res@graph) - - ##} else ## { # use a customized procedure (faster) # - ## myGraph <- getGraph(res) - ## myGraph@nodes <- myGraph@nodes[i] - ## myGraph@edgeL <- myGraph@edgeL[myGraph@nodes] - ## ## special handling of i, to know which indexes are kept - ## if(is.character(i)){ # type == character - ## keptIdx <- match(i, nodeNames) - ## keptIdx <- !is.na(keptIdx) - ## } - ## if(is.logical(i)){ # type == logical - ## keptIdx <- which(i) - ## } - ## if(is.numeric(i)){ # type == numeric - ## if(i[1]>0) { - ## keptIdx <- i - ## } else{ - ## keptIdx <- setdiff(1:nrow(x@coords), i) - ## } - ## } - - ## f1.noweights <- function(nodeIdc){ # function to subset graph without weights - ## nodeIdc$edges <- nodeIdc$edges[nodeIdc$edges %in% keptIdx] # erase non kept indices - ## nodeIdc$edges <- match(oldNodeNames[nodeIdc$edges], newNodeNames) # match indices with new positions - ## return(nodeIdc) - ## } - ## f1.withweights <- function(oneNode){ # function to subset graph with weights - ## temp <- oneNode$edges %in% keptIdx - ## oneNode$edges <- oneNode$edges[temp] - ## oneNode$weights <- oneNode$weights[temp] - ## return(oneNode) - ## } - - ## if(is.null(myGraph@edgeL[[1]]$weights)){ - ## myGraph@edgeL <- lapply(myGraph@edgeL, f1.noweights) - ## } else { - ## myGraph@edgeL <- lapply(myGraph@edgeL, f1.withweights) - ## } - ## } - # end subset graph - - res@graph <- myGraph - - ## remember this subsetting - curCall <- match.call() - ## newHist <- new("gGraphHistory", res@history, cmd=curCall, comments="Subsetting using [...]") - ## res@history <- newHist - - return(res) +setMethod("[", "gGraph", function(x, i, j, ..., drop = TRUE) { + if (missing(i)) { + i <- TRUE + } + if (is.logical(i)) { + i <- rep(i, length = nrow(getCoords(x))) + } + if (is.character(i)) { + i <- match(i, getNodes(x)) + if (any(is.na(i))) stop("Some specified node labels were not found.") + } + if (missing(j)) { + j <- TRUE + } + + if (is.logical(i) && is.logical(j) && all(c(i, j))) { + return(x) + } # don't loose time for silly trials + + argList <- list(...) + if (is.null(argList$useSubGraph)) { + useSubGraph <- TRUE + } else { + useSubGraph <- argList$useSubGraph + } + + oldNodeNames <- getNodes(x) # node names before subsetting + newNodeNames <- oldNodeNames[i] # node names after subsetting + + + ## do the subsetting ## + res <- x + res@coords <- res@coords[i, , drop = FALSE] + if (nrow(res@nodes.attr) > 0) { + res@nodes.attr <- res@nodes.attr[i, j, drop = FALSE] + } + ## if(useSubGraph){ # use procedure from graph package to subset graph (slow) # + + myGraph <- subGraph(nodes(res@graph)[i], res@graph) + + ## } else ## { # use a customized procedure (faster) # + ## myGraph <- getGraph(res) + ## myGraph@nodes <- myGraph@nodes[i] + ## myGraph@edgeL <- myGraph@edgeL[myGraph@nodes] + ## ## special handling of i, to know which indexes are kept + ## if(is.character(i)){ # type == character + ## keptIdx <- match(i, nodeNames) + ## keptIdx <- !is.na(keptIdx) + ## } + ## if(is.logical(i)){ # type == logical + ## keptIdx <- which(i) + ## } + ## if(is.numeric(i)){ # type == numeric + ## if(i[1]>0) { + ## keptIdx <- i + ## } else{ + ## keptIdx <- setdiff(1:nrow(x@coords), i) + ## } + ## } + + ## f1.noweights <- function(nodeIdc){ # function to subset graph without weights + ## nodeIdc$edges <- nodeIdc$edges[nodeIdc$edges %in% keptIdx] # erase non kept indices + ## nodeIdc$edges <- match(oldNodeNames[nodeIdc$edges], newNodeNames) # match indices with new positions + ## return(nodeIdc) + ## } + ## f1.withweights <- function(oneNode){ # function to subset graph with weights + ## temp <- oneNode$edges %in% keptIdx + ## oneNode$edges <- oneNode$edges[temp] + ## oneNode$weights <- oneNode$weights[temp] + ## return(oneNode) + ## } + + ## if(is.null(myGraph@edgeL[[1]]$weights)){ + ## myGraph@edgeL <- lapply(myGraph@edgeL, f1.noweights) + ## } else { + ## myGraph@edgeL <- lapply(myGraph@edgeL, f1.withweights) + ## } + ## } + # end subset graph + + res@graph <- myGraph + + ## remember this subsetting + curCall <- match.call() + ## newHist <- new("gGraphHistory", res@history, cmd=curCall, comments="Subsetting using [...]") + ## res@history <- newHist + + return(res) }) @@ -124,48 +126,50 @@ setMethod("[", "gGraph", function(x, i, j, ..., drop=TRUE) { ########### ## [ gData ########### -setMethod("[", "gData", function(x, i, j, ..., drop=FALSE) { - if(missing(i)) { - i <- TRUE - } - if(is.logical(i)){ - i <- rep(i, length=nrow(getCoords(x))) - } - if(is.character(i)) { - i <- match(i, getNodes(x)) - if(any(is.na(i))) stop("Some specified node labels were not found.") - } - if(missing(j)) { - j <- TRUE - } - - if(is.logical(i) && is.logical(j) && all(c(i,j))) return(x) # don't loose time for silly trials - - - ## do the subsetting ## - - ## coords - res <- x - N <- nrow(res@coords) - res@coords <- res@coords[i, , drop=FALSE] - - ## nodes id - res@nodes.id <- res@nodes.id[i] - - ## data - if(!is.null(getData(x))){ - if(nrow(getData(x))==N){ - res@data <- res@data[i, j, drop=FALSE] - } else if(length(getData)==N){ - res@data <- res@data[i] - } else if(existsMethod("[",class(res@data)[1])){ - res@data <- res@data[i,j, ..., drop=drop] - } else{ - warning("Don't know what to do with @data.") - } +setMethod("[", "gData", function(x, i, j, ..., drop = FALSE) { + if (missing(i)) { + i <- TRUE + } + if (is.logical(i)) { + i <- rep(i, length = nrow(getCoords(x))) + } + if (is.character(i)) { + i <- match(i, getNodes(x)) + if (any(is.na(i))) stop("Some specified node labels were not found.") + } + if (missing(j)) { + j <- TRUE + } + + if (is.logical(i) && is.logical(j) && all(c(i, j))) { + return(x) + } # don't loose time for silly trials + + + ## do the subsetting ## + + ## coords + res <- x + N <- nrow(res@coords) + res@coords <- res@coords[i, , drop = FALSE] + + ## nodes id + res@nodes.id <- res@nodes.id[i] + + ## data + if (!is.null(getData(x))) { + if (nrow(getData(x)) == N) { + res@data <- res@data[i, j, drop = FALSE] + } else if (length(getData) == N) { + res@data <- res@data[i] + } else if (existsMethod("[", class(res@data)[1])) { + res@data <- res@data[i, j, ..., drop = drop] + } else { + warning("Don't know what to do with @data.") } + } - return(res) + return(res) }) @@ -209,31 +213,30 @@ setMethod("[", "gData", function(x, i, j, ..., drop=FALSE) { ############### ## show gGraph ############### -setMethod("show", "gGraph", function(object){ - x <- object - N <- nrow(x@coords) - nDisp <- 3 - - ## printing - cat("\n=== gGraph object ===\n") - cat("\n@coords: spatial coordinates of",nrow(x@coords),"nodes\n") - print(utils::head(x@coords, nDisp)) - if(N > nDisp) cat("...\n") - - cat("\n@nodes.attr:",ncol(x@nodes.attr),"nodes attributes\n") - print(utils::head(x@nodes.attr, nDisp)) - if(nrow(x@nodes.attr) > nDisp) cat("...\n") - - cat("\n@meta: list of meta information with", length(x@meta),"items\n") - if(length(x@meta)>0) print(paste("$", names(x@meta), sep="")) - - cat("\n@graph:\n") - print(x@graph) - - ##cat("\n@history: (", length(x@history@cmd)," items )\n") - ##print(x@history[1:min(nDisp,length(x@history@cmd))]) - ##if(length(x@history@cmd) > nDisp) cat("\n...\n") - +setMethod("show", "gGraph", function(object) { + x <- object + N <- nrow(x@coords) + nDisp <- 3 + + ## printing + cat("\n=== gGraph object ===\n") + cat("\n@coords: spatial coordinates of", nrow(x@coords), "nodes\n") + print(utils::head(x@coords, nDisp)) + if (N > nDisp) cat("...\n") + + cat("\n@nodes.attr:", ncol(x@nodes.attr), "nodes attributes\n") + print(utils::head(x@nodes.attr, nDisp)) + if (nrow(x@nodes.attr) > nDisp) cat("...\n") + + cat("\n@meta: list of meta information with", length(x@meta), "items\n") + if (length(x@meta) > 0) print(paste("$", names(x@meta), sep = "")) + + cat("\n@graph:\n") + print(x@graph) + + ## cat("\n@history: (", length(x@history@cmd)," items )\n") + ## print(x@history[1:min(nDisp,length(x@history@cmd))]) + ## if(length(x@history@cmd) > nDisp) cat("\n...\n") }) # end show gGraph @@ -244,27 +247,25 @@ setMethod("show", "gGraph", function(object){ ############### ## show gData ############### -setMethod("show", "gData", function(object){ - x <- object - N <- nrow(x@coords) - nDisp <- 3 - - ## printing - cat("\n=== gData object ===\n") - cat("\n@coords: spatial coordinates of",nrow(x@coords),"nodes\n") - print(utils::head(x@coords, nDisp)) - if(N > nDisp) cat("...\n") - - cat("\n@nodes.id:",nrow(x@nodes.id),"nodes identifiers\n") - print(utils::head(x@nodes.id, nDisp)) - if(length(x@nodes.id) > nDisp) cat("...\n") - - cat("\n@data:",nrow(x@data),"data\n") - print(utils::head(x@data, nDisp)) - if(N > nDisp) cat("...\n") - - ##cat("\nAssociated gGraph:",x@gGraph.name, "[",x@gGraph.version,"]\n") - cat("\nAssociated gGraph:",x@gGraph.name,"\n") - +setMethod("show", "gData", function(object) { + x <- object + N <- nrow(x@coords) + nDisp <- 3 + + ## printing + cat("\n=== gData object ===\n") + cat("\n@coords: spatial coordinates of", nrow(x@coords), "nodes\n") + print(utils::head(x@coords, nDisp)) + if (N > nDisp) cat("...\n") + + cat("\n@nodes.id:", nrow(x@nodes.id), "nodes identifiers\n") + print(utils::head(x@nodes.id, nDisp)) + if (length(x@nodes.id) > nDisp) cat("...\n") + + cat("\n@data:", nrow(x@data), "data\n") + print(utils::head(x@data, nDisp)) + if (N > nDisp) cat("...\n") + + ## cat("\nAssociated gGraph:",x@gGraph.name, "[",x@gGraph.version,"]\n") + cat("\nAssociated gGraph:", x@gGraph.name, "\n") }) # end show gData - diff --git a/R/buffer.R b/R/buffer.R index 6e85fff..7737040 100644 --- a/R/buffer.R +++ b/R/buffer.R @@ -34,33 +34,33 @@ #' #' #### gGraph example #### #' ## zoom in to an area -#' plot(worldgraph.10k, reset=TRUE) -#' geo.zoomin(list(x=c(-6,38), y=c(35,73))) +#' plot(worldgraph.10k, reset = TRUE) +#' geo.zoomin(list(x = c(-6, 38), y = c(35, 73))) #' #' ## identify one node -#' oneNodeXY <- c(getCoords(worldgraph.10k)[9299,1],getCoords(worldgraph.10k)[9299,2]) -#' points(oneNodeXY[1], oneNodeXY[2], col="red") +#' oneNodeXY <- c(getCoords(worldgraph.10k)[9299, 1], getCoords(worldgraph.10k)[9299, 2]) +#' points(oneNodeXY[1], oneNodeXY[2], col = "red") #' #' ## find some buffers #' buffer(worldgraph.10k, "9299", 100) # nothing around 100km #' buffer(worldgraph.10k, "9299", 500) -#' buf500km <- buffer(worldgraph.10k, "9299", 500, res="gGraph") -#' plot(buf500km, col.rules=buf500km@meta$buf.colors) -#' buf1000km <- buffer(worldgraph.10k, "9299", 1000, res="gGraph") -#' plot(buf1000km, col.rules=buf1000km@meta$buf.colors) +#' buf500km <- buffer(worldgraph.10k, "9299", 500, res = "gGraph") +#' plot(buf500km, col.rules = buf500km@meta$buf.colors) +#' buf1000km <- buffer(worldgraph.10k, "9299", 1000, res = "gGraph") +#' plot(buf1000km, col.rules = buf1000km@meta$buf.colors) #' #' #' #### gData example #### #' x <- hgdp[27:30] # retain a subset of hgdp -#' plot(x, reset=TRUE, col.g="lightgrey", pch.node=20) -#' buf.200 <- buffer(x, 200, res="gData") -#' buf.400 <- buffer(x, 400, res="gData") -#' buf.600 <- buffer(x, 600, res="gData") -#' buf.1000 <- buffer(x, 1000, res="gData") -#' points(buf.1000, col.node="black") -#' points(buf.600, col.node="yellow") -#' points(buf.400, col.node="gold") -#' points(buf.200, col.node="orange") +#' plot(x, reset = TRUE, col.g = "lightgrey", pch.node = 20) +#' buf.200 <- buffer(x, 200, res = "gData") +#' buf.400 <- buffer(x, 400, res = "gData") +#' buf.600 <- buffer(x, 600, res = "gData") +#' buf.1000 <- buffer(x, 1000, res = "gData") +#' points(buf.1000, col.node = "black") +#' points(buf.600, col.node = "yellow") +#' points(buf.400, col.node = "gold") +#' points(buf.200, col.node = "orange") #' title("Different buffers for a gData \n(100km, 200km, 500km)") #' NULL @@ -70,7 +70,7 @@ NULL ######### #' @export setGeneric("buffer", function(x, ...) { - standardGeneric("buffer") + standardGeneric("buffer") }) @@ -83,74 +83,76 @@ setGeneric("buffer", function(x, ...) { #' @export #' @rdname buffer -setMethod("buffer", "gGraph", function(x, nodes, d, res.type=c("nodes", "gGraph"), ...){ - ## CHECKS ## - if(!is.gGraph(x)) stop("x is not a valid gGraph object") - if(!is.numeric(d)) stop("d is not numeric") - if(d > 1e4) warning("Buffer distance is greater than 10,000km; computations may be long.") - res.type <- match.arg(res.type) - - ALL.NODES <- getNodes(x) - if(!all(nodes %in% ALL.NODES)) stop("Some requested nodes do not exist in the gGraph grid.") - - GRAPH <- getGraph(x) - EDGES <- edges(GRAPH) - XY <- getCoords(x) - - - ## FIND BUFFER FOR A NODE ## - find.buf.onenode <- function(node, d){ - curNodes <- node - res <- node - visited.nodes <- node - - while(TRUE){ - neig <- unlist(EDGES[curNodes]) - neig <- setdiff(neig, visited.nodes) - visited.nodes <- c(visited.nodes, neig) - - temp <- fields::rdist.earth(XY[node,,drop=FALSE], XY[neig,,drop=FALSE], miles=FALSE, R=NULL) - toKeep <- temp < d - if(!any(toKeep)) break # exit - curNodes <- neig[toKeep] - res <- c(res, neig[toKeep]) - } - return(res) +setMethod("buffer", "gGraph", function(x, nodes, d, res.type = c("nodes", "gGraph"), ...) { + ## CHECKS ## + if (!is.gGraph(x)) stop("x is not a valid gGraph object") + if (!is.numeric(d)) stop("d is not numeric") + if (d > 1e4) warning("Buffer distance is greater than 10,000km; computations may be long.") + res.type <- match.arg(res.type) + + ALL.NODES <- getNodes(x) + if (!all(nodes %in% ALL.NODES)) stop("Some requested nodes do not exist in the gGraph grid.") + + GRAPH <- getGraph(x) + EDGES <- edges(GRAPH) + XY <- getCoords(x) + + + ## FIND BUFFER FOR A NODE ## + find.buf.onenode <- function(node, d) { + curNodes <- node + res <- node + visited.nodes <- node + + while (TRUE) { + neig <- unlist(EDGES[curNodes]) + neig <- setdiff(neig, visited.nodes) + visited.nodes <- c(visited.nodes, neig) + + temp <- fields::rdist.earth(XY[node, , drop = FALSE], XY[neig, , drop = FALSE], miles = FALSE, R = NULL) + toKeep <- temp < d + if (!any(toKeep)) break # exit + curNodes <- neig[toKeep] + res <- c(res, neig[toKeep]) } + return(res) + } - ## FIND BUFFER FOR ALL REQUESTED NODES ## - res <- unlist(lapply(nodes, find.buf.onenode, d)) + ## FIND BUFFER FOR ALL REQUESTED NODES ## + res <- unlist(lapply(nodes, find.buf.onenode, d)) - ## RETURN RESULTS ## - res <- unique(res) - if(res.type == "nodes") return(res) # if res.type is nodes + ## RETURN RESULTS ## + res <- unique(res) + if (res.type == "nodes") { + return(res) + } # if res.type is nodes - #### DOES NOT WORK - ## ISSUES WHEN DEPARSING THE GGRAPH - ## if(res.type == "gData"){ # if res.type is gData - ## graphName <- gsub("\"","",deparse(x, back=FALSE)) - ## return(graphName) - ## temp <- new("gData", coords=XY[res,,drop=FALSE], gGraph.name=graphName) - ## return(temp) - ## } + #### DOES NOT WORK + ## ISSUES WHEN DEPARSING THE GGRAPH + ## if(res.type == "gData"){ # if res.type is gData + ## graphName <- gsub("\"","",deparse(x, back=FALSE)) + ## return(graphName) + ## temp <- new("gData", coords=XY[res,,drop=FALSE], gGraph.name=graphName) + ## return(temp) + ## } - ## else ... (res.type==gGraph) - bufAttr <- rep(FALSE, length(ALL.NODES)) - names(bufAttr) <- ALL.NODES - bufAttr[res] <- TRUE + ## else ... (res.type==gGraph) + bufAttr <- rep(FALSE, length(ALL.NODES)) + names(bufAttr) <- ALL.NODES + bufAttr[res] <- TRUE - ## set new attributes - ALL.ATTR <- getNodesAttr(x) - newATTR <- cbind.data.frame(ALL.ATTR, buffer=bufAttr) - x@nodes.attr <- newATTR + ## set new attributes + ALL.ATTR <- getNodesAttr(x) + newATTR <- cbind.data.frame(ALL.ATTR, buffer = bufAttr) + x@nodes.attr <- newATTR - ## set new color rules - x@meta$buf.colors <- data.frame(buffer=c(TRUE,FALSE), color=c("orange", "lightgrey")) - return(x) + ## set new color rules + x@meta$buf.colors <- data.frame(buffer = c(TRUE, FALSE), color = c("orange", "lightgrey")) + return(x) }) # end buffer for gGraph @@ -164,29 +166,31 @@ setMethod("buffer", "gGraph", function(x, nodes, d, res.type=c("nodes", "gGraph" ################ #' @export #' @rdname buffer -setMethod("buffer", "gData", function(x, d, res.type=c("nodes", "gData", "gGraph"), ...){ - ## CHECKS ## - res.type <- match.arg(res.type) - if(!is.gData(x)) stop("x is not a valid gData object") +setMethod("buffer", "gData", function(x, d, res.type = c("nodes", "gData", "gGraph"), ...) { + ## CHECKS ## + res.type <- match.arg(res.type) + if (!is.gData(x)) stop("x is not a valid gData object") - ## EXTRACT ARGUMENTS FOR FURTHER METHOD ## - myNodes <- getNodes(x) - myGraph <- get(x@gGraph.name, envir=.GlobalEnv) + ## EXTRACT ARGUMENTS FOR FURTHER METHOD ## + myNodes <- getNodes(x) + myGraph <- get(x@gGraph.name, envir = .GlobalEnv) - ## CALL UPON gGraph METHOD ## - if(res.type=="gGraph"){ # if result seeked is gGraph - res <- buffer(myGraph, myNodes, d, res.type="gGraph") - return(res) - } + ## CALL UPON gGraph METHOD ## + if (res.type == "gGraph") { # if result seeked is gGraph + res <- buffer(myGraph, myNodes, d, res.type = "gGraph") + return(res) + } - # if result seeked is nodes or gData - temp <- buffer(myGraph, myNodes, d, res.type="nodes") - if(res.type=="nodes") return(temp) # if res.type is nodes + # if result seeked is nodes or gData + temp <- buffer(myGraph, myNodes, d, res.type = "nodes") + if (res.type == "nodes") { + return(temp) + } # if res.type is nodes - ## else ... (res.type == gData) - res <- new("gData", coords=getCoords(myGraph)[temp,,drop=FALSE], gGraph.name=x@gGraph.name) + ## else ... (res.type == gData) + res <- new("gData", coords = getCoords(myGraph)[temp, , drop = FALSE], gGraph.name = x@gGraph.name) - return(res) + return(res) }) # end buffer for gData diff --git a/R/classes.R b/R/classes.R index 37b32d1..48a9da7 100644 --- a/R/classes.R +++ b/R/classes.R @@ -18,9 +18,7 @@ NULL #' 'nodes'), and a graph describing connectivity between these vertices. Data #' associated to the nodes can also be stored ('nodes attributes'), as well as #' meta-information used when plotting the object, or when computing weights -#' associated to the edges based on nodes attributes.\cr % History associated -#' to a \code{gGraph} object is stored in the slot % \code{history}, as an -#' object of the class % \linkS4class{gGraphHistory}.\cr +#' associated to the edges based on nodes attributes.\cr #' #' In all slots, nodes are uniquely identified by their name (reference is #' taken from the row names of \code{@coords} slot). @@ -50,8 +48,7 @@ NULL #' Note that none of these is mandatory: \code{new("gGraph")} would work, and #' create an empty \code{gGraph} object. #' @author Thibaut Jombart (\email{t.jombart@@imperial.ac.uk}) -#' @seealso Related classes are:\cr % - \code{\linkS4class{gGraphHistory}}: -#' slot \code{@history} in \code{gGraph}.\cr - \code{\linkS4class{graphNEL}} +#' @seealso Related classes are:\cr % - \code{\linkS4class{graphNEL}} #' (graph package): slot \code{@graph} in \code{gGraph}.\cr #' @keywords classes spatial graphs #' @exportClass gGraph @@ -62,10 +59,10 @@ NULL #' #' #' ## plotting the object -#' plot(rawgraph.10k, reset=TRUE) +#' plot(rawgraph.10k, reset = TRUE) #' #' ## zooming in -#' geo.zoomin(list(x=c(-6,38), y=c(35,73))) +#' geo.zoomin(list(x = c(-6, 38), y = c(35, 73))) #' title("Europe") #' #' ## to play interactively with graphics, use: @@ -76,28 +73,32 @@ NULL #' #' ## defining a new object restrained to visible nodes #' x <- rawgraph.10k[isInArea(rawgraph.10k)] -#' plot(x,reset=TRUE, edges=TRUE) +#' plot(x, reset = TRUE, edges = TRUE) #' title("x does just contain these visible nodes.") #' #' ## define weights for edges -#' x <- setCosts(x, attr.name="habitat", method="prod") -#' plot(x,edges=TRUE) +#' x <- setCosts(x, attr.name = "habitat", method = "prod") +#' plot(x, edges = TRUE) #' title("costs defined by habitat (land/land=1, other=100)") #' #' ## drop 'dead edges' (i.e. with weight 0) -#' x <- dropDeadEdges(x, thres=10) -#' plot(x,edges=TRUE) +#' x <- dropDeadEdges(x, thres = 10) +#' plot(x, edges = TRUE) #' title("after droping edges with null weight") #' -#' -setClass("gGraph", - representation(coords = "matrix", nodes.attr = "data.frame", meta = "list", - graph = "graphNEL"), - prototype(coords = matrix(numeric(0), ncol=2, dimnames=list(NULL, c("lon","lat"))), - nodes.attr = data.frame(), - meta = list(), - graph = new("graphNEL")) - ) +setClass( + "gGraph", + representation( + coords = "matrix", nodes.attr = "data.frame", meta = "list", + graph = "graphNEL" + ), + prototype( + coords = matrix(numeric(0), ncol = 2, dimnames = list(NULL, c("lon", "lat"))), + nodes.attr = data.frame(), + meta = list(), + graph = new("graphNEL") + ) +) #' Formal class "gData" @@ -145,25 +146,29 @@ setClass("gGraph", #' hgdp #' #' ## plot data -#' plot(worldgraph.40k, pch="") +#' plot(worldgraph.40k, pch = "") #' points(hgdp) #' #' ## subset and plot data -#' onlyNorth <- hgdp[hgdp@data$Latitude >0] # only northern populations -#' -#' plot(worldgraph.40k, reset=TRUE) -#' abline(h=0) # equator -#' points(onlyNorth, pch.node=20, cex=2, col.node="purple") +#' onlyNorth <- hgdp[hgdp@data$Latitude > 0] # only northern populations #' +#' plot(worldgraph.40k, reset = TRUE) +#' abline(h = 0) # equator +#' points(onlyNorth, pch.node = 20, cex = 2, col.node = "purple") #' #' @exportClass gData -setClass("gData", representation(coords="matrix", nodes.id="character", data="ANY", - gGraph.name="character"), - prototype(coords = matrix(numeric(0), ncol=2, dimnames=list(NULL, c("lon","lat"))), - nodes.id = character(0), - data=NULL, - gGraph.name="") - ) +setClass( + "gData", representation( + coords = "matrix", nodes.id = "character", data = "ANY", + gGraph.name = "character" + ), + prototype( + coords = matrix(numeric(0), ncol = 2, dimnames = list(NULL, c("lon", "lat"))), + nodes.id = character(0), + data = NULL, + gGraph.name = "" + ) +) @@ -173,94 +178,66 @@ setClass("gData", representation(coords="matrix", nodes.id="character", data="AN ## VALIDITY METHODS #################### #' @export -.gGraph.valid <- function(object){ - x <- object - N <- nrow(x@coords) - - if(N == 0) return(TRUE) # empty object always valid - - ## several cases of non-validity - - ## coords not numeric - if(!is.numeric(x@coords)){ - cat("\n Content of coords is not numeric.") - return(FALSE) - } - - ## wrong nrow for nodes attributes - temp <- nrow(x@nodes.attr) - if(temp > 0 && temp != N){ - cat("\n Number of coords do not match number of node attributes.") - return(FALSE) - } - - ## NAs in coords - if(any(is.na(x@coords))){ - cat("\n NAs in coords coordinates.") - return(FALSE) - } - - ## node labels consistency - if(!all(rownames(x@coords)==nodes(x@graph))){ - cat("\n Row names of @coords do not match node names of @graph.") - return(FALSE) - } - +.gGraph.valid <- function(object) { + x <- object + N <- nrow(x@coords) + if (N == 0) { return(TRUE) -} # end .gGprah.valid - - - + } # empty object always valid + ## several cases of non-validity -## .gGprahHistory.valid <- function(object){ -## x <- object -## Lcmd <- length(x@cmd) -## Ldates <- length(x@dates) -## Lcomments <- length(x@comments) -## ## several cases of non-validity ## + ## coords not numeric + if (!is.numeric(x@coords)) { + cat("\n Content of coords is not numeric.") + return(FALSE) + } -## ## empty object always ok -## if(all(c(Lcmd,Ldates,Lcomments) == 0)) return(TRUE) + ## wrong nrow for nodes attributes + temp <- nrow(x@nodes.attr) + if (temp > 0 && temp != N) { + cat("\n Number of coords do not match number of node attributes.") + return(FALSE) + } -## ## different length -## if(length(unique(c(Lcmd, Ldates, Lcomments)))>1) { -## cat("\n Components have different lengths.") -## return(FALSE) -## } + ## NAs in coords + if (any(is.na(x@coords))) { + cat("\n NAs in coords coordinates.") + return(FALSE) + } -## ## cmd wrong class -## if(!all(sapply(x@cmd, class)=="expression")){ -## cat("\n Some cmd components are not calls.") -## return(FALSE) -## } + ## node labels consistency + if (!all(rownames(x@coords) == nodes(x@graph))) { + cat("\n Row names of @coords do not match node names of @graph.") + return(FALSE) + } -## return(TRUE) -## } # end .gGprahHistory.valid + return(TRUE) +} # end .gGprah.valid #' @export -.gData.valid <- function(object){ - x <- object - Ncoords <- nrow(x@coords) - Nnodes <- length(x@nodes.id) - - ## dim matching - if(Ncoords != Nnodes){ - cat("\n Number of coordinates and of nodes do not match.") - return(FALSE) - } - - ## gGraph object - if(!exists(x@gGraph.name, envir=.GlobalEnv)){ - warning(paste("The gGraph object",x@gGraph.name,"is missing.")) - } - - return(TRUE) +.gData.valid <- function(object) { + x <- object + Ncoords <- nrow(x@coords) + Nnodes <- length(x@nodes.id) + + ## dim matching + if (Ncoords != Nnodes) { + cat("\n Number of coordinates and of nodes do not match.") + return(FALSE) + } + + ## gGraph object + if (!exists(x@gGraph.name, envir = .GlobalEnv)) { + warning(paste("The gGraph object", x@gGraph.name, "is missing.")) + } + + return(TRUE) } # end .gData.valid @@ -273,22 +250,16 @@ setValidity("gGraph", .gGraph.valid) #' @export setValidity("gData", .gData.valid) - -## is.gGraphHistory <- function(x){ -## res <- (is(x, "gGraphHistory") & validObject(x)) -## return(res) -## } - #' @export -is.gGraph <- function(x){ - res <- (is(x, "gGraph") & validObject(x)) - return(res) +is.gGraph <- function(x) { + res <- (is(x, "gGraph") & validObject(x)) + return(res) } #' @export -is.gData <- function(x){ - res <- (is(x, "gData") & validObject(x)) - return(res) +is.gData <- function(x) { + res <- (is(x, "gData") & validObject(x)) + return(res) } @@ -300,130 +271,67 @@ is.gData <- function(x){ ## CONSTRUCTORS ################ -################## -## gGraphHistory -################## -## setMethod("initialize", "gGraphHistory", function(.Object, ...) { -## x <- .Object -## input <- list(...) -## inputClasses <- sapply(input, class) - - -## ## handle ... ## -## if(is.null(input$cmd)){ -## input$cmd <- expression() -## } - -## if(is.null(input$dates)){ -## input$dates <- format(Sys.time()) -## } else{ -## input$dates <- as.character(input$dates) -## } - -## if(is.null(input$comments)){ -## input$comments <- "" -## } else{ -## input$comments <- as.character(input$comments) -## } - - -## ## if a gGraphHistory object is provided in ..., merge data with it. ## -## if(length(input)>0 && any(inputClasses=="gGraphHistory")){ -## prevObj <- input[[which(inputClasses=="gGraphHistory")[1]]] # 1st obj taken if several provided -## res <- prevObj -## res@cmd[[length(res@cmd)+1]] <- input$cmd -## res@dates <- c(res@dates, input$dates) -## res@comments <- c(res@comments, input$comments) -## } else{ -## res <- x -## res@cmd[[length(res@cmd)+1]] <- input$cmd -## res@dates <- input$dates -## res@comments <- input$comments -## } - -## return(res) -## }) # end gGraphHistory constructor - - - - - - ########## ## gGraph ########## #' @export setMethod("initialize", "gGraph", function(.Object, ...) { - x <- .Object - input <- list(...) - - ## handle @coords ## - if(!is.null(input$coords)){ - if(is.list(input$coords) && length(input$coords)==2) { - input$coords <- as.data.frame(input$coords) - } - - if(is.data.frame(input$coords)){ - input$coords <- as.matrix(input$coords) - } - - if(nrow(input$coords)>0 && !is.numeric(input$coords)) stop("Argument coords has to be numeric.") + x <- .Object + input <- list(...) - ## names of the matrix - colnames(input$coords) <- c("lon","lat") - rownames(input$coords) <- as.character(1:nrow(input$coords)) - - ## check/rectify longitudes - temp <- input$coords[,"lon"]>180 - input$coords[temp,"lon"] <- input$coords[temp,"lon"]-360 - - x@coords <- input$coords + ## handle @coords ## + if (!is.null(input$coords)) { + if (is.list(input$coords) && length(input$coords) == 2) { + input$coords <- as.data.frame(input$coords) } + if (is.data.frame(input$coords)) { + input$coords <- as.matrix(input$coords) + } - ## handle @nodes.attr ## - if(!is.null(input$nodes.attr)){ - input$nodes.attr <- as.data.frame(input$nodes.attr) + if (nrow(input$coords) > 0 && !is.numeric(input$coords)) stop("Argument coords has to be numeric.") - if(nrow(input$nodes.attr) != nrow(x@coords)){ - stop("Number of rows in nodes.attr differ from that of coords.") - } + ## names of the matrix + colnames(input$coords) <- c("lon", "lat") + rownames(input$coords) <- as.character(1:nrow(input$coords)) - x@nodes.attr <- input$nodes.attr - } + ## check/rectify longitudes + temp <- input$coords[, "lon"] > 180 + input$coords[temp, "lon"] <- input$coords[temp, "lon"] - 360 + x@coords <- input$coords + } - ## handle @graph ## - if(is.null(input$graph)){ # graph not provided - if(nrow(x@coords)>0){ - input$graph <- new("graphNEL", nodes=rownames(x@coords)) - } else{ - input$graph <- new("graphNEL") - } - } else { # graph provided - if(nrow(x@coords)>0){ - nodes(input$graph) <- rownames(x@coords) - } - } - x@graph <- input$graph + ## handle @nodes.attr ## + if (!is.null(input$nodes.attr)) { + input$nodes.attr <- as.data.frame(input$nodes.attr) + if (nrow(input$nodes.attr) != nrow(x@coords)) { + stop("Number of rows in nodes.attr differ from that of coords.") + } - ## ## handle history ## - ## if(is.null(input$cmd)){ - ## input$cmd <-sys.call(-2) - ## } + x@nodes.attr <- input$nodes.attr + } - ## if(is.null(input$comments) || input$comments==""){ - ## input$comments <- "Creation of the object (using new)." - ## } - ## x@history <- new("gGraphHistory", history=input$history, - ## cmd=input$cmd, dates=input$dates, comments=input$comments) + ## handle @graph ## + if (is.null(input$graph)) { # graph not provided + if (nrow(x@coords) > 0) { + input$graph <- new("graphNEL", nodes = rownames(x@coords)) + } else { + input$graph <- new("graphNEL") + } + } else { # graph provided + if (nrow(x@coords) > 0) { + nodes(input$graph) <- rownames(x@coords) + } + } + x@graph <- input$graph - ## return object - return(x) + ## return object + return(x) }) # end gGraph constructor @@ -436,76 +344,72 @@ setMethod("initialize", "gGraph", function(.Object, ...) { ########## #' @export setMethod("initialize", "gData", function(.Object, ...) { - x <- .Object - input <- list(...) - inputClasses <- sapply(input, class) - + x <- .Object + input <- list(...) + inputClasses <- sapply(input, class) - ## handle @coords ## - if(!is.null(input$coords)){ - if(is.list(input$coords) && length(input$coords)==2) { - input$coords <- as.data.frame(input$coords) - } - if(is.data.frame(input$coords)){ - input$coords <- as.matrix(input$coords) - } - - if(nrow(input$coords)>0 && !is.numeric(input$coords)) stop("Argument coords has to be numeric.") + ## handle @coords ## + if (!is.null(input$coords)) { + if (is.list(input$coords) && length(input$coords) == 2) { + input$coords <- as.data.frame(input$coords) + } - ## names of the matrix - colnames(input$coords) <- c("lon","lat") - rownames(input$coords) <- as.character(1:nrow(input$coords)) + if (is.data.frame(input$coords)) { + input$coords <- as.matrix(input$coords) + } - ## check/rectify longitudes - temp <- input$coords[,"lon"]>180 - input$coords[temp,"lon"] <- input$coords[temp,"lon"]-360 + if (nrow(input$coords) > 0 && !is.numeric(input$coords)) stop("Argument coords has to be numeric.") - x@coords <- input$coords - } + ## names of the matrix + colnames(input$coords) <- c("lon", "lat") + rownames(input$coords) <- as.character(1:nrow(input$coords)) + ## check/rectify longitudes + temp <- input$coords[, "lon"] > 180 + input$coords[temp, "lon"] <- input$coords[temp, "lon"] - 360 - ## handle gGraph.name and gGraph.version - if(!is.null(input$gGraph.name)){ - if(!exists(input$gGraph.name, envir=.GlobalEnv)){ - warning(paste("The gGraph object",input$gGraphName,"is missing.")) - myGraph <- NULL - } else { - myGraph <- get(input$gGraph.name, envir=.GlobalEnv) # used later for node.id - x@gGraph.name <- input$gGraph.name - } - - ## if(is.null(input$gGraph.version) & !is.null(myGraph)){ - ## x@gGraph.version <- myGraph@history@dates[length(myGraph@history@dates)] - ## } - } else{ - myGraph <- NULL - } + x@coords <- input$coords + } - ## handle nodes.id ## - if(is.null(input$nodes.id)){ # if nodes.id is not provided... - if(!is.null(myGraph)){ # ... and if the gGraph is available - x@nodes.id <- closestNode(myGraph, loc=x@coords) # deduce nodes.id from the gGraph - } + ## handle gGraph.name and gGraph.version + if (!is.null(input$gGraph.name)) { + if (!exists(input$gGraph.name, envir = .GlobalEnv)) { + warning(paste("The gGraph object", input$gGraphName, "is missing.")) + myGraph <- NULL } else { - x@nodes.id <- as.character(x@nodes.id) - if(!is.null(myGraph)){ - if(!all(x@nodes.id %in% getNodes(myGraph))){ - warning(paste("Some nodes were not found in the gGraph object",x@gGraphName,".")) - } - } + myGraph <- get(input$gGraph.name, envir = .GlobalEnv) # used later for node.id + x@gGraph.name <- input$gGraph.name } + ## if(is.null(input$gGraph.version) & !is.null(myGraph)){ + ## x@gGraph.version <- myGraph@history@dates[length(myGraph@history@dates)] + ## } + } else { + myGraph <- NULL + } - ## handle data ## - if(!is.null(input$data)){ - x@data <- input$data - } - - return(x) -}) # end gData constructor + ## handle nodes.id ## + if (is.null(input$nodes.id)) { # if nodes.id is not provided... + if (!is.null(myGraph)) { # ... and if the gGraph is available + x@nodes.id <- closestNode(myGraph, loc = x@coords) # deduce nodes.id from the gGraph + } + } else { + x@nodes.id <- as.character(x@nodes.id) + if (!is.null(myGraph)) { + if (!all(x@nodes.id %in% getNodes(myGraph))) { + warning(paste("Some nodes were not found in the gGraph object", x@gGraphName, ".")) + } + } + } + ## handle data ## + if (!is.null(input$data)) { + x@data <- input$data + } + return(x) +}) # end gData constructor diff --git a/R/closestNode.R b/R/closestNode.R index 0429ee9..c16a248 100644 --- a/R/closestNode.R +++ b/R/closestNode.R @@ -1,20 +1,20 @@ #' Find the closest node to a given location -#' +#' #' The function \code{closestNode} searches for the closest node in a #' \linkS4class{gGraph} or a \linkS4class{gData} object to a given location. It #' is possible to restrain the research to given values of a node attribute. #' For instance, one can search the closest node on land to a given #' location.\cr -#' +#' #' This function is also used to match locations of a \linkS4class{gData} #' object with nodes of the \code{gGraph} object to which it is linked. -#' +#' #' When creating a \linkS4class{gData} object, if the \code{gGraph.name} #' argument is provided, then locations are matched with the \code{gGraph} #' object automatically, by an internal call to closestNode. Note, however, #' that it is not possible to specify node attributes (\code{attr.names} and #' \code{attr.values}) this way. -#' +#' #' @aliases closestNode closestNode-methods closestNode,gGraph-method #' closestNode,gData-method #' @param x a valid \linkS4class{gGraph} or \linkS4class{gData} object. In the @@ -34,7 +34,7 @@ #' See details. #' @return If \code{x} is a \linkS4class{gGraph} object: a vector of node #' names.\cr -#' +#' #' If \code{x} is a \linkS4class{gData} object: a \linkS4class{gData} object #' with matching nodes stored in the \code{@nodes.id} slot. Note that previous #' content of \code{@nodes.id} will be erased.\cr @@ -44,42 +44,40 @@ #' @keywords utilities methods #' @export #' @examples -#' #' \dontrun{ #' ## interactive example ## -#' plot(worldgraph.10k, reset=TRUE) -#' +#' plot(worldgraph.10k, reset = TRUE) +#' #' ## zooming in -#' geo.zoomin(list(x=c(-6,38), y=c(35,73))) +#' geo.zoomin(list(x = c(-6, 38), y = c(35, 73))) #' title("Europe") -#' +#' #' ## click some locations -#' myNodes <- closestNode(worldgraph.10k,locator(), attr.name="habitat", attr.value="land") +#' myNodes <- closestNode(worldgraph.10k, locator(), attr.name = "habitat", attr.value = "land") #' myNodes -#' +#' #' ## here are the closestNodes -#' points(getCoords(worldgraph.10k)[myNodes,], col="red") +#' points(getCoords(worldgraph.10k)[myNodes, ], col = "red") #' } -#' +#' #' ## example with a gData object ## -#' myLoc <- list(x=c(3, -8, 11, 28), y=c(50, 57, 71, 67)) # some locations -#' obj <- new("gData", coords=myLoc) # new gData object +#' myLoc <- list(x = c(3, -8, 11, 28), y = c(50, 57, 71, 67)) # some locations +#' obj <- new("gData", coords = myLoc) # new gData object #' obj -#' +#' #' obj@gGraph.name <- "worldgraph.10k" # this could be done when creating obj -#' obj <- closestNode(obj, attr.name="habitat", attr.value="land") -#' +#' obj <- closestNode(obj, attr.name = "habitat", attr.value = "land") +#' #' ## plot the result (original location -> assigned node) -#' plot(obj, method="both", reset=TRUE) +#' plot(obj, method = "both", reset = TRUE) #' title("'x'=location, 'o'=assigned node") -#' -#' - +#' +#' ############### ## closestNode ############### -setGeneric("closestNode", function(x,...) { - standardGeneric("closestNode") +setGeneric("closestNode", function(x, ...) { + standardGeneric("closestNode") }) @@ -92,68 +90,67 @@ setGeneric("closestNode", function(x,...) { ############### #' @describeIn closestNode Method for gGraph #' @export -setMethod("closestNode", "gGraph", function(x, loc, zoneSize=5, attr.name=NULL, attr.values=NULL){ - - ## handle arguments - if(!is.gGraph(x)) stop("x is not a valid gGraph object.") - loc <- as.data.frame(loc) - if(ncol(loc) != 2) stop("coords does not have two columns.") - coords <- getCoords(x) - nodes <- getNodes(x) - - ## handle attribute specification if provided - if(!is.null(attr.name)){ - temp <- unlist(getNodesAttr(x, attr.name=attr.name)) - temp <- as.character(temp) - hasRightAttr <- temp %in% attr.values - if(!any(hasRightAttr)) stop(paste("specified values of",attr.name,"never found.")) - } else{ - hasRightAttr <- TRUE - } - - ## function finding the closest node for 1 loc ## - closeOne <- function(oneLoc){ - ## define area around loc - reg <- list() - toKeep <- character(0) # will contain node names - - while(length(toKeep) < 3){ # enlarge zoneSize until at least 3 candidates appear - ## define region - reg$x <- oneLoc[1] + c(-zoneSize,zoneSize) # +- zoneZine in long - reg$y <- oneLoc[2] + c(-zoneSize,zoneSize) # +- zoneZine in lat - - ## isolate nodes in this area - toKeep <- isInArea(x, reg) # ! from now nodes indices won't match those of x and coords - - ## intersect with attribute selection - toKeep <- toKeep & hasRightAttr - - ## toKeep must be a character to insure matching - toKeep <- nodes[toKeep] - - ## increment zoneSize - zoneSize <- zoneSize*1.5 - } # end while - - xy <- coords[toKeep,,drop=FALSE] - - ## compute all great circle distances between nodes and loc - temp <- fields::rdist.earth(xy, matrix(oneLoc, nrow=1)) - closeNode <- rownames(temp)[which.min(temp)] - return(closeNode) - } # end closeOne - - - ## apply closeOne to all requested locations - res <- apply(loc, 1, closeOne) # these are node labels - - ## must not return indices, as this would not work for subsets of data - ## e.g. closestPoint[x[getNodesAttr(x)=="land"]] will return wrong indices - ## temp <- res - ## res <- match(res, getNodes(x)) - ## names(res) <- temp - - return(res) +setMethod("closestNode", "gGraph", function(x, loc, zoneSize = 5, attr.name = NULL, attr.values = NULL) { + ## handle arguments + if (!is.gGraph(x)) stop("x is not a valid gGraph object.") + loc <- as.data.frame(loc) + if (ncol(loc) != 2) stop("coords does not have two columns.") + coords <- getCoords(x) + nodes <- getNodes(x) + + ## handle attribute specification if provided + if (!is.null(attr.name)) { + temp <- unlist(getNodesAttr(x, attr.name = attr.name)) + temp <- as.character(temp) + hasRightAttr <- temp %in% attr.values + if (!any(hasRightAttr)) stop(paste("specified values of", attr.name, "never found.")) + } else { + hasRightAttr <- TRUE + } + + ## function finding the closest node for 1 loc ## + closeOne <- function(oneLoc) { + ## define area around loc + reg <- list() + toKeep <- character(0) # will contain node names + + while (length(toKeep) < 3) { # enlarge zoneSize until at least 3 candidates appear + ## define region + reg$x <- oneLoc[1] + c(-zoneSize, zoneSize) # +- zoneZine in long + reg$y <- oneLoc[2] + c(-zoneSize, zoneSize) # +- zoneZine in lat + + ## isolate nodes in this area + toKeep <- isInArea(x, reg) # ! from now nodes indices won't match those of x and coords + + ## intersect with attribute selection + toKeep <- toKeep & hasRightAttr + + ## toKeep must be a character to insure matching + toKeep <- nodes[toKeep] + + ## increment zoneSize + zoneSize <- zoneSize * 1.5 + } # end while + + xy <- coords[toKeep, , drop = FALSE] + + ## compute all great circle distances between nodes and loc + temp <- fields::rdist.earth(xy, matrix(oneLoc, nrow = 1)) + closeNode <- rownames(temp)[which.min(temp)] + return(closeNode) + } # end closeOne + + + ## apply closeOne to all requested locations + res <- apply(loc, 1, closeOne) # these are node labels + + ## must not return indices, as this would not work for subsets of data + ## e.g. closestPoint[x[getNodesAttr(x)=="land"]] will return wrong indices + ## temp <- res + ## res <- match(res, getNodes(x)) + ## names(res) <- temp + + return(res) }) # end closestNode for gGraph @@ -166,20 +163,19 @@ setMethod("closestNode", "gGraph", function(x, loc, zoneSize=5, attr.name=NULL, ############### #' @describeIn closestNode Method for gData #' @export -setMethod("closestNode", "gData", function(x, zoneSize=5, attr.name=NULL, attr.values=NULL){ - - ## get coords ## - xy <- getCoords(x) +setMethod("closestNode", "gData", function(x, zoneSize = 5, attr.name = NULL, attr.values = NULL) { + ## get coords ## + xy <- getCoords(x) - ## get gGraph object ## - if(!exists(x@gGraph.name, envir=.GlobalEnv)) stop(paste("gGraph object",x@gGraph.name,"does not exist.")) - obj <- get(x@gGraph.name, envir=.GlobalEnv) + ## get gGraph object ## + if (!exists(x@gGraph.name, envir = .GlobalEnv)) stop(paste("gGraph object", x@gGraph.name, "does not exist.")) + obj <- get(x@gGraph.name, envir = .GlobalEnv) - ## make a call to the gGraph method ## - res <- closestNode(obj, loc=xy, zoneSize=zoneSize, attr.name=attr.name, attr.values=attr.values) + ## make a call to the gGraph method ## + res <- closestNode(obj, loc = xy, zoneSize = zoneSize, attr.name = attr.name, attr.values = attr.values) - ## return result ## - x@nodes.id <- res + ## return result ## + x@nodes.id <- res - return(x) + return(x) }) # end closestNode for gData diff --git a/R/connectivity.R b/R/connectivity.R index cf0cc32..18d5355 100644 --- a/R/connectivity.R +++ b/R/connectivity.R @@ -69,21 +69,21 @@ NULL #' @rdname connectivity #' @export -areNeighbours <- function(V1, V2, graph){ - V1 <- as.character(V1) - V2 <- as.character(V2) - if(length(V1) != length(V2)) stop("V1 and V2 have different lengths.") +areNeighbours <- function(V1, V2, graph) { + V1 <- as.character(V1) + V2 <- as.character(V2) + if (length(V1) != length(V2)) stop("V1 and V2 have different lengths.") - edg <- edges(graph) + edg <- edges(graph) - ## function testing if two nodes are directly connected - f1 <- function(A,B){ - return(any(edg[[A]]==B)) - } + ## function testing if two nodes are directly connected + f1 <- function(A, B) { + return(any(edg[[A]] == B)) + } - res <- mapply(function(x,y) f1(x,y), V1, V2) + res <- mapply(function(x, y) f1(x, y), V1, V2) - return(res) + return(res) } # end areNeighbours @@ -96,40 +96,40 @@ areNeighbours <- function(V1, V2, graph){ ################ #' @rdname connectivity #' @export -areConnected <- function(x, nodes){ # x is a gGraph - ## some checks ## - ##if(!require(RBGL)) stop("RBGL package is required.") not needed - if(!is.gGraph(x)) stop("x is not a valid gGraph object") - if(!all(nodes %in% getNodes(x))) stop("Some specified nodes were not found in the gGraph object.") - nodes <- unique(nodes) - - - ## This is now pointless, function is already fast ## - ## ## first check that all our nodes are part of an edge ## - ## temp <- unique(as.vector(getEdges(x, res.type="matName"))) - ## nodes.in.edges <- nodes %in% temp - ## if(!all(nodes.in.edges)) return(FALSE) # not a connected set if some nodes aren't connected at all - - - ## get connected sets ## - ## !! use RBGL::connectedComp from RBGL rather than connComp from graph - ## 100 times faster - connected.sets <- RBGL::connectedComp(getGraph(x)) - - ## just keep sets > 1 node - temp <- sapply(connected.sets, length) - reOrd <- order(temp,decreasing=TRUE) # sets ordered in decreasing size - temp <- temp[reOrd] - if(min(temp)==1){ - connected.sets <- connected.sets[reOrd][1:(which.min(temp)-1)] - } +areConnected <- function(x, nodes) { # x is a gGraph + ## some checks ## + ## if(!require(RBGL)) stop("RBGL package is required.") not needed + if (!is.gGraph(x)) stop("x is not a valid gGraph object") + if (!all(nodes %in% getNodes(x))) stop("Some specified nodes were not found in the gGraph object.") + nodes <- unique(nodes) + + + ## This is now pointless, function is already fast ## + ## ## first check that all our nodes are part of an edge ## + ## temp <- unique(as.vector(getEdges(x, res.type="matName"))) + ## nodes.in.edges <- nodes %in% temp + ## if(!all(nodes.in.edges)) return(FALSE) # not a connected set if some nodes aren't connected at all + - names(connected.sets) <- paste("set",1:length(connected.sets)) + ## get connected sets ## + ## !! use RBGL::connectedComp from RBGL rather than connComp from graph + ## 100 times faster + connected.sets <- RBGL::connectedComp(getGraph(x)) - res <- sapply(connected.sets, function(e) all(nodes %in% e)) - res <- any(res) + ## just keep sets > 1 node + temp <- sapply(connected.sets, length) + reOrd <- order(temp, decreasing = TRUE) # sets ordered in decreasing size + temp <- temp[reOrd] + if (min(temp) == 1) { + connected.sets <- connected.sets[reOrd][1:(which.min(temp) - 1)] + } - return(res) + names(connected.sets) <- paste("set", 1:length(connected.sets)) + + res <- sapply(connected.sets, function(e) all(nodes %in% e)) + res <- any(res) + + return(res) } # end areConnected @@ -143,22 +143,22 @@ areConnected <- function(x, nodes){ # x is a gGraph ## the GENERIC of this method is given in package 'graph' #' @rdname connectivity #' @export -setMethod("isConnected", "gData", function(object, ...){ - ## checks ## - x <- object - if(!is.gData(x)) stop("'object' is not a valid gData object.") - if(!exists(x@gGraph.name, envir=.GlobalEnv)) stop(paste("gGraph object",x@gGraph.name,"not found.")) +setMethod("isConnected", "gData", function(object, ...) { + ## checks ## + x <- object + if (!is.gData(x)) stop("'object' is not a valid gData object.") + if (!exists(x@gGraph.name, envir = .GlobalEnv)) stop(paste("gGraph object", x@gGraph.name, "not found.")) - ## set args for areConnected ## - myGraph <- get(x@gGraph.name, envir=.GlobalEnv) - myNodes <- getNodes(x) + ## set args for areConnected ## + myGraph <- get(x@gGraph.name, envir = .GlobalEnv) + myNodes <- getNodes(x) - ## wrapper ## - res <- areConnected(myGraph, myNodes) + ## wrapper ## + res <- areConnected(myGraph, myNodes) - ## return res ## - return(res) + ## return res ## + return(res) }) # end isConnected for gData @@ -171,50 +171,50 @@ setMethod("isConnected", "gData", function(object, ...){ ################# #' @rdname connectivity #' @export -isReachable <- function(x, loc){ # x is a gData object - ## checks ## - if(!is.gData(x)) stop("x is not a valid gData object.") - if(!exists(x@gGraph.name, envir=.GlobalEnv)) stop(paste("gGraph object",x@gGraph.name,"not found.")) - mygGraph <- get(x@gGraph.name, envir=.GlobalEnv) +isReachable <- function(x, loc) { # x is a gData object + ## checks ## + if (!is.gData(x)) stop("x is not a valid gData object.") + if (!exists(x@gGraph.name, envir = .GlobalEnv)) stop(paste("gGraph object", x@gGraph.name, "not found.")) + mygGraph <- get(x@gGraph.name, envir = .GlobalEnv) - ## get connected sets ## - connected.sets <- RBGL::connectedComp(getGraph(x)) + ## get connected sets ## + connected.sets <- RBGL::connectedComp(getGraph(x)) - ## just keep sets > 1 node - temp <- sapply(connected.sets, length) - reOrd <- order(temp,decreasing=TRUE) # sets ordered in decreasing size - temp <- temp[reOrd] - if(min(temp)==1){ - connected.sets <- connected.sets[reOrd][1:(which.min(temp)-1)] - } + ## just keep sets > 1 node + temp <- sapply(connected.sets, length) + reOrd <- order(temp, decreasing = TRUE) # sets ordered in decreasing size + temp <- temp[reOrd] + if (min(temp) == 1) { + connected.sets <- connected.sets[reOrd][1:(which.min(temp) - 1)] + } - names(connected.sets) <- paste("set",1:length(connected.sets)) + names(connected.sets) <- paste("set", 1:length(connected.sets)) - ## check which set contains refNode ## - refNode <- closestNode(mygGraph,loc) - temp <- sapply(connected.sets, function(e) refNode %in% e) - if(!any(temp)) { - warning("The reference node is not connected to any node.") - return(FALSE) - } - refSet <- connected.sets[[which(temp)]] + ## check which set contains refNode ## + refNode <- closestNode(mygGraph, loc) + temp <- sapply(connected.sets, function(e) refNode %in% e) + if (!any(temp)) { + warning("The reference node is not connected to any node.") + return(FALSE) + } + refSet <- connected.sets[[which(temp)]] - ## check reachability for each node ## - myNodes <- getNodes(x) + ## check reachability for each node ## + myNodes <- getNodes(x) - f1 <- function(oneNode){ # finds the set in which a node is - temp <- sapply(connected.sets, function(e) oneNode %in% refSet) - return(any(temp)) - } + f1 <- function(oneNode) { # finds the set in which a node is + temp <- sapply(connected.sets, function(e) oneNode %in% refSet) + return(any(temp)) + } - res <- sapply(myNodes, f1) - names(res) <- myNodes + res <- sapply(myNodes, f1) + names(res) <- myNodes - ## return res ## - return(res) + ## return res ## + return(res) } # end isReachable @@ -227,8 +227,8 @@ isReachable <- function(x, loc){ # x is a gData object ##################### #' @rdname connectivity #' @export -setGeneric("connectivityPlot", function(x,...) { - standardGeneric("connectivityPlot") +setGeneric("connectivityPlot", function(x, ...) { + standardGeneric("connectivityPlot") }) @@ -238,72 +238,72 @@ setGeneric("connectivityPlot", function(x,...) { ################## #' @rdname connectivity #' @export -setMethod("connectivityPlot", "gGraph", function(x, ..., seed=NULL){ - ## some checks ## - if(!is.gGraph(x)) stop("x is not a valid gGraph object") +setMethod("connectivityPlot", "gGraph", function(x, ..., seed = NULL) { + ## some checks ## + if (!is.gGraph(x)) stop("x is not a valid gGraph object") - ## create the .geoGraphEnv if it does not exist - # am315 This should not be necessary, as .geoGraphEnv should always exist - # if(!exists(".geoGraphEnv", envir=.GlobalEnv)) { - # assign(".geoGraphEnv", new.env(parent=.GlobalEnv), envir=.GlobalEnv) - # warning(".geoGraphEnv was not present, which may indicate a problem in loading geoGraph.") - # } + ## create the .geoGraphEnv if it does not exist + # am315 This should not be necessary, as .geoGraphEnv should always exist + # if(!exists(".geoGraphEnv", envir=.GlobalEnv)) { + # assign(".geoGraphEnv", new.env(parent=.GlobalEnv), envir=.GlobalEnv) + # warning(".geoGraphEnv was not present, which may indicate a problem in loading geoGraph.") + # } - #env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement + # env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement - ## get connected sets ## - connected.sets <- RBGL::connectedComp(getGraph(x)) + ## get connected sets ## + connected.sets <- RBGL::connectedComp(getGraph(x)) - ## just keep sets > 1 node - temp <- sapply(connected.sets, length) - reOrd <- order(temp,decreasing=TRUE) # sets ordered in decreasing size - temp <- temp[reOrd] - if(min(temp)==1){ - connected.sets <- connected.sets[reOrd][1:(which.min(temp)-1)] - } + ## just keep sets > 1 node + temp <- sapply(connected.sets, length) + reOrd <- order(temp, decreasing = TRUE) # sets ordered in decreasing size + temp <- temp[reOrd] + if (min(temp) == 1) { + connected.sets <- connected.sets[reOrd][1:(which.min(temp) - 1)] + } - names(connected.sets) <- paste("set",1:length(connected.sets)) + names(connected.sets) <- paste("set", 1:length(connected.sets)) - ## define colors ## - nbSets <- length(connected.sets) - if(!is.null(seed) && is.numeric(seed)) { - set.seed(seed) - } + ## define colors ## + nbSets <- length(connected.sets) + if (!is.null(seed) && is.numeric(seed)) { + set.seed(seed) + } - colSets <- sample(grDevices::rainbow(nbSets)) + colSets <- sample(grDevices::rainbow(nbSets)) - myNodes <- getNodes(x) - col <- rep("lightgray", length(myNodes)) - names(col) <- myNodes + myNodes <- getNodes(x) + col <- rep("lightgray", length(myNodes)) + names(col) <- myNodes - for(i in 1:nbSets){ - e <- connected.sets[[i]] # 'e' is a vector of connected nodes - col[e] <- colSets[i] - } + for (i in 1:nbSets) { + e <- connected.sets[[i]] # 'e' is a vector of connected nodes + col[e] <- colSets[i] + } - ## call to plot ## - plot(x, col=col, ...) + ## call to plot ## + plot(x, col = col, ...) - ## save plot param ## (will be used by plot gGraph - dots <- list(...) - temp <- get("last.plot.param", envir=.geoGraphEnv) - if(!is.null(dots$psize)) { - temp$psize <- dots$psize - } - if(!is.null(dots$pch)){ - temp$pch <- dots$pch - } - temp$col <- col - assign("last.plot.param", temp, envir=.geoGraphEnv) + ## save plot param ## (will be used by plot gGraph + dots <- list(...) + temp <- get("last.plot.param", envir = .geoGraphEnv) + if (!is.null(dots$psize)) { + temp$psize <- dots$psize + } + if (!is.null(dots$pch)) { + temp$pch <- dots$pch + } + temp$col <- col + assign("last.plot.param", temp, envir = .geoGraphEnv) - ## fix last call ## - curCall <- sys.call(-1) - assign("last.plot", curCall, envir=.geoGraphEnv) + ## fix last call ## + curCall <- sys.call(-1) + assign("last.plot", curCall, envir = .geoGraphEnv) - return(invisible(col)) + return(invisible(col)) }) # end connectivityPlot gGraph @@ -316,59 +316,59 @@ setMethod("connectivityPlot", "gGraph", function(x, ..., seed=NULL){ ################# #' @rdname connectivity #' @export -setMethod("connectivityPlot", "gData", function(x, col.gGraph=0, ...,seed=NULL){ - ## some checks ## - if(!is.gData(x)) stop("x is not a valid gData object") +setMethod("connectivityPlot", "gData", function(x, col.gGraph = 0, ..., seed = NULL) { + ## some checks ## + if (!is.gData(x)) stop("x is not a valid gData object") - env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement + env <- get(".geoGraphEnv", envir = .GlobalEnv) # env is our target environnement - ## get connected sets ## - connected.sets <- RBGL::connectedComp(getGraph(x)) + ## get connected sets ## + connected.sets <- RBGL::connectedComp(getGraph(x)) - ## just keep sets > 1 node - temp <- sapply(connected.sets, length) - reOrd <- order(temp,decreasing=TRUE) # sets ordered in decreasing size - temp <- temp[reOrd] - if(min(temp)==1){ - connected.sets <- connected.sets[reOrd][1:(which.min(temp)-1)] - } + ## just keep sets > 1 node + temp <- sapply(connected.sets, length) + reOrd <- order(temp, decreasing = TRUE) # sets ordered in decreasing size + temp <- temp[reOrd] + if (min(temp) == 1) { + connected.sets <- connected.sets[reOrd][1:(which.min(temp) - 1)] + } - names(connected.sets) <- paste("set",1:length(connected.sets)) + names(connected.sets) <- paste("set", 1:length(connected.sets)) - ## define colors ## - nbSets <- length(connected.sets) - ## find the number of relevant sets - nbRelSets <- 0 - myNodes <- getNodes(x) + ## define colors ## + nbSets <- length(connected.sets) + ## find the number of relevant sets + nbRelSets <- 0 + myNodes <- getNodes(x) - for(i in 1:nbSets){ - if(any(myNodes %in% connected.sets[[i]])){ - nbRelSets <- nbRelSets + 1 - } + for (i in 1:nbSets) { + if (any(myNodes %in% connected.sets[[i]])) { + nbRelSets <- nbRelSets + 1 } + } - if(!is.null(seed) && is.numeric(seed)) { - set.seed(seed) - } - colSets <- sample(grDevices::rainbow(nbRelSets)) + if (!is.null(seed) && is.numeric(seed)) { + set.seed(seed) + } + colSets <- sample(grDevices::rainbow(nbRelSets)) - col <- rep("lightgray", length(myNodes)) - names(col) <- myNodes + col <- rep("lightgray", length(myNodes)) + names(col) <- myNodes - for(i in 1:nbSets){ - e <- connected.sets[[i]] # 'e' is a vector of connected nodes - col[names(col) %in% e] <- colSets[i] - } + for (i in 1:nbSets) { + e <- connected.sets[[i]] # 'e' is a vector of connected nodes + col[names(col) %in% e] <- colSets[i] + } - ## call to plot ## - plot(x, col.ori=col, col.nodes=col, col.gGraph=col.gGraph, ...) + ## call to plot ## + plot(x, col.ori = col, col.nodes = col, col.gGraph = col.gGraph, ...) - ## fix last call ## - curCall <- sys.call(-1) - assign("last.plot", curCall, envir=.geoGraphEnv) + ## fix last call ## + curCall <- sys.call(-1) + assign("last.plot", curCall, envir = .geoGraphEnv) - return(invisible(col)) + return(invisible(col)) }) # end connectivityPlot gData diff --git a/R/datasets.R b/R/datasets.R index e0625ec..5736d6b 100644 --- a/R/datasets.R +++ b/R/datasets.R @@ -34,24 +34,24 @@ #' ## results from Handley et al. #' \dontrun{ #' ## Addis Ababa -#' addis <- list(lon=38.74,lat=9.03) -#' addis <- closestNode(worldgraph.40k,addis) # this takes a while +#' addis <- list(lon = 38.74, lat = 9.03) +#' addis <- closestNode(worldgraph.40k, addis) # this takes a while #' #' ## shortest path from Addis Ababa #' myPath <- dijkstraFrom(hgdp, addis) #' #' ## plot results -#' plot(worldgraph.40k, col=0) +#' plot(worldgraph.40k, col = 0) #' points(hgdp) -#' points(worldgraph.40k[addis], psize=3,pch="x", col="black") +#' points(worldgraph.40k[addis], psize = 3, pch = "x", col = "black") #' plot(myPath) #' #' ## correlations distance/genetic div. -#' geo.dist <- sapply(myPath[-length(myPath)],function(e) e$length) -#' gen.div <- getData(hgdp)[,"Genetic.Div"] -#' plot(gen.div~geo.dist) -#' lm1 <- lm(gen.div~geo.dist) -#' abline(lm1, col="blue") # this regression is wrong +#' geo.dist <- sapply(myPath[-length(myPath)], function(e) e$length) +#' gen.div <- getData(hgdp)[, "Genetic.Div"] +#' plot(gen.div ~ geo.dist) +#' lm1 <- lm(gen.div ~ geo.dist) +#' abline(lm1, col = "blue") # this regression is wrong #' summary(lm1) #' } #' @@ -67,18 +67,15 @@ NULL #' references.\cr #' #' 'worldgraph's are 'rawgraph's that have been modified manually to rectify -#' connectivity between edges at some places. The most noticable change is that +#' connectivity between edges at some places. The most noticeable change is that #' all edges involving sea vertices have been removed.\cr #' -#' 'globalcoord.10k' and 'globalcoord.40k' are matrices of geographic -#' coordinates of nodes, used to construct 'rawgraph' and 'worlgraph' objects.\cr -#' -#' 'worldshape' is a shapefile of contries of the world (snapshot from 1994). +#' 'worldshape' is a shapefile of countries of the world (snapshot from 1994). #' #' #' @name worldgraph #' @aliases worldgraph rawgraph.10k rawgraph.40k worldgraph.10k worldgraph.40k -#' globalcoord.10k globalcoord.40k worldshape +#' worldshape #' @docType data #' @format \code{worldgraph.10k} and \code{worldgraph.40k} are #' \linkS4class{gGraph} objects with the following specificities: \describe{ @@ -98,24 +95,24 @@ NULL #' worldgraph.10k #' #' ## plotting the object -#' plot(worldgraph.10k, reset=TRUE) +#' plot(worldgraph.10k, reset = TRUE) #' title("Hello world") #' #' ## zooming in -#' geo.zoomin(list(x=c(-12,45), y=c(33,75))) +#' geo.zoomin(list(x = c(-12, 45), y = c(33, 75))) #' title("Europe") -#' geo.zoomin(list(x=c(-12,2), y=c(50,60))) +#' geo.zoomin(list(x = c(-12, 2), y = c(50, 60))) #' plotEdges(worldgraph.10k) #' title("United Kingdom") #' #' ## zooming out #' # geo.zoomout() # needs clicking on device -#' geo.zoomin(list(x=c(-6,38), y=c(35,73))) +#' geo.zoomin(list(x = c(-6, 38), y = c(35, 73))) #' title("Europe") #' #' ## defining the subset of visible points #' x <- worldgraph.10k[isInArea(worldgraph.10k)] -#' plot(x,reset=TRUE, edges=TRUE) +#' plot(x, reset = TRUE, edges = TRUE) #' title("One subsetted object.") #' #' \dontrun{ @@ -123,7 +120,4 @@ NULL #' geo.zoomin() #' } #' -#' NULL - - diff --git a/R/dijkstra.R b/R/dijkstra.R index dad7466..e00454d 100644 --- a/R/dijkstra.R +++ b/R/dijkstra.R @@ -50,28 +50,27 @@ #' @author Thibaut Jombart (\email{t.jombart@@imperial.ac.uk}) #' @keywords methods spatial #' @examples -#' #' \dontrun{ #' #' ## plotting #' world <- worldgraph.40k -#' par(mar=rep(.1,4)) -#' plot(world, reset=TRUE) +#' par(mar = rep(.1, 4)) +#' plot(world, reset = TRUE) #' #' ## check connectivity #' isConnected(hgdp) # must be ok #' #' ## Lowest cost path from an hypothetical origin -#' ori.coord <- list(33,10) # one given location long/lat -#' points(data.frame(ori.coord), pch="x", col="black", cex=3) # an 'x' shows the putative origin +#' ori.coord <- list(33, 10) # one given location long/lat +#' points(data.frame(ori.coord), pch = "x", col = "black", cex = 3) # an 'x' shows the putative origin #' ori <- closestNode(world, ori.coord) # assign it the closest node #' #' myPath <- dijkstraFrom(hgdp, ori) # compute shortest path #' #' ## plotting -#' plot(world,pch="") # plot the world -#' points(hgdp, lwd=3) # plot populations -#' points(data.frame(ori.coord), pch="x", col="black", cex=3) # add origin +#' plot(world, pch = "") # plot the world +#' points(hgdp, lwd = 3) # plot populations +#' points(data.frame(ori.coord), pch = "x", col = "black", cex = 3) # add origin #' plot(myPath) # plot the path #' } #' @@ -84,8 +83,8 @@ NULL ################### #' @rdname dijkstra-methods #' @export -setGeneric("dijkstraBetween", function(x,...) { - standardGeneric("dijkstraBetween") +setGeneric("dijkstraBetween", function(x, ...) { + standardGeneric("dijkstraBetween") }) @@ -98,59 +97,59 @@ setGeneric("dijkstraBetween", function(x,...) { ##################### #' @rdname dijkstra-methods #' @export -setMethod("dijkstraBetween", "gGraph", function(x, from, to){ - ## some checks ## - if(!require(RBGL)) stop("RBGL is required.") - if(!is.gGraph(x)) stop("x is not a valid gGraph object") - if(!all(from %in% getNodes(x))) stop("Some starting nodes are not in x.") - if(!all(to %in% getNodes(x))) stop("Some ending nodes are not in x.") - - ## check connectivity ## - if(!areConnected(x, unique(c(from,to)))) stop("Not all nodes are connected by the graph.") - - ## build the wrapper ## - myGraph <- getGraph(x) - - ## recycle from and to - maxLength <- max(length(from), length(to)) - from <- rep(from, length=maxLength) - to <- rep(to, length=maxLength) - - ## build indices of all pairwise combinations ## - if(maxLength>1){ - pairIdStart <- integer() - pairIdStop <- integer() - - for(i in 1:maxLength){ - j <- i - while((j <- j+1) < (maxLength+1) ){ - pairIdStart <- c(pairIdStart, i) - pairIdStop <- c(pairIdStop, j) - } - } - } else { - pairIdStart <- pairIdStop <- 1 +setMethod("dijkstraBetween", "gGraph", function(x, from, to) { + ## some checks ## + if (!require(RBGL)) stop("RBGL is required.") + if (!is.gGraph(x)) stop("x is not a valid gGraph object") + if (!all(from %in% getNodes(x))) stop("Some starting nodes are not in x.") + if (!all(to %in% getNodes(x))) stop("Some ending nodes are not in x.") + + ## check connectivity ## + if (!areConnected(x, unique(c(from, to)))) stop("Not all nodes are connected by the graph.") + + ## build the wrapper ## + myGraph <- getGraph(x) + + ## recycle from and to + maxLength <- max(length(from), length(to)) + from <- rep(from, length = maxLength) + to <- rep(to, length = maxLength) + + ## build indices of all pairwise combinations ## + if (maxLength > 1) { + pairIdStart <- integer() + pairIdStop <- integer() + + for (i in 1:maxLength) { + j <- i + while ((j <- j + 1) < (maxLength + 1)) { + pairIdStart <- c(pairIdStart, i) + pairIdStop <- c(pairIdStop, j) + } } + } else { + pairIdStart <- pairIdStop <- 1 + } - ## wrap ## - ## ! sp.between does not return duplicated paths - res <- RBGL::sp.between(myGraph, start=from[pairIdStart], finish=to[pairIdStop]) + ## wrap ## + ## ! sp.between does not return duplicated paths + res <- RBGL::sp.between(myGraph, start = from[pairIdStart], finish = to[pairIdStop]) - ## handle duplicated paths ## - if(length(res) < maxLength){ # res should have length = laxLength - fromTo <- paste(from[pairIdStart], to[pairIdStop], sep=":") # all different paths - res <- res[fromTo] - } + ## handle duplicated paths ## + if (length(res) < maxLength) { # res should have length = laxLength + fromTo <- paste(from[pairIdStart], to[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") <- getCoords(x)[allNodes,] - class(res) <- "gPath" + ## 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") <- getCoords(x)[allNodes, ] + class(res) <- "gPath" - return(res) + return(res) }) # end dijkstraBetween for gGraph @@ -163,52 +162,52 @@ setMethod("dijkstraBetween", "gGraph", function(x, from, to){ ##################### #' @rdname dijkstra-methods #' @export -setMethod("dijkstraBetween", "gData", function(x){ -##temp <- function(x){ # for debugging - - ## some checks ## - if(!require(RBGL)) stop("RBGL is required.") - if(!is.gData(x)) stop("x is not a valid gData object") - if(!exists(x@gGraph.name, envir=.GlobalEnv)) stop(paste("gGraph object",x@gGraph.name,"not found.")) - if(length(x@nodes.id)==0) stop("No assigned nodes (x@nodes.id is empty).") - if(!isConnected(x)) stop("Not all locations are connected by the graph.") - - ## build the wrapper ## - myGraph <- get(x@gGraph.name, 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) - } +setMethod("dijkstraBetween", "gData", function(x) { + ## temp <- function(x){ # for debugging + + ## some checks ## + if (!require(RBGL)) stop("RBGL is required.") + if (!is.gData(x)) stop("x is not a valid gData object") + if (!exists(x@gGraph.name, envir = .GlobalEnv)) stop(paste("gGraph object", x@gGraph.name, "not found.")) + if (length(x@nodes.id) == 0) stop("No assigned nodes (x@nodes.id is empty).") + if (!isConnected(x)) stop("Not all locations are connected by the graph.") + + ## build the wrapper ## + myGraph <- get(x@gGraph.name, 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=x@nodes.id[pairIdStart], finish=x@nodes.id[pairIdStop]) + ## wrap ## + ## ! sp.between does not return duplicated paths + res <- RBGL::sp.between(myGraph, start = x@nodes.id[pairIdStart], finish = x@nodes.id[pairIdStop]) - ## handle duplicated paths ## - if(length(res) < length(pairIdStart)){ # res should have length = pairIdStart - fromTo <- paste(x@nodes.id[pairIdStart], x@nodes.id[pairIdStop], sep=":") # all different paths - res <- res[fromTo] - } + ## handle duplicated paths ## + if (length(res) < length(pairIdStart)) { # res should have length = pairIdStart + fromTo <- paste(x@nodes.id[pairIdStart], x@nodes.id[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" + ## 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) + return(res) }) # end dijkstraBetween for gData @@ -229,8 +228,8 @@ setMethod("dijkstraBetween", "gData", function(x){ ################ #' @rdname dijkstra-methods #' @export -setGeneric("dijkstraFrom", function(x,...) { - standardGeneric("dijkstraFrom") +setGeneric("dijkstraFrom", function(x, ...) { + standardGeneric("dijkstraFrom") }) @@ -243,38 +242,37 @@ setGeneric("dijkstraFrom", function(x,...) { ##################### #' @rdname dijkstra-methods #' @export -setMethod("dijkstraFrom", "gGraph", function(x, start){ +setMethod("dijkstraFrom", "gGraph", function(x, start) { + ## some checks ## + if (!require(RBGL)) stop("RBGL is required.") + if (!is.gGraph(x)) stop("x is not a valid gGraph object") + if (!all(start %in% getNodes(x))) stop("Starting node is not in x.") - ## some checks ## - if(!require(RBGL)) stop("RBGL is required.") - if(!is.gGraph(x)) stop("x is not a valid gGraph object") - 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.") - ## check connectivity ## - if(!areConnected(x, getNodes(myGraph))) 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)) + ## } - ## build the wrapper ## - myGraph <- getGraph(x) - ## if(is.character(costs) && costs=="default"){ - ## costs <- unlist(edgeWeights(myGraph)) - ## } + ## wrap ## + res <- RBGL::dijkstra.sp(myGraph, start = start) - ## wrap ## - res <- RBGL::dijkstra.sp(myGraph, start=start) + ## sp.between uses unique(x@nodes.id) ## + ## eventually have to duplicate paths ## + temp <- gsub(".*:", "", names(res)) + res <- res[match(getNodes(x), temp)] - ## sp.between uses unique(x@nodes.id) ## - ## eventually have to duplicate paths ## - temp <- gsub(".*:","",names(res)) - res <- res[match(getNodes(x), temp)] + ## 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") <- getCoords(x)[allNodes, ] + class(res) <- "gPath" - ## 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") <- getCoords(x)[allNodes,] - class(res) <- "gPath" - - return(res) + return(res) }) # end dijkstraFrom for gGraph @@ -287,43 +285,42 @@ setMethod("dijkstraFrom", "gGraph", function(x, start){ #################### #' @rdname dijkstra-methods #' @export -setMethod("dijkstraFrom", "gData", function(x, start){ - - ## some checks ## - if(!require(RBGL)) stop("RBGL is required.") - if(!is.gData(x)) stop("x is not a valid gData object") - if(!exists(x@gGraph.name, envir=.GlobalEnv)) stop(paste("gGraph object",x@gGraph.name,"not found.")) - if(length(x@nodes.id)==0) stop("No assigned nodes (x@nodes.id is empty).") - if(!isConnected(x)) stop("Not all locations are connected by the graph") +setMethod("dijkstraFrom", "gData", function(x, start) { + ## some checks ## + if (!require(RBGL)) stop("RBGL is required.") + if (!is.gData(x)) stop("x is not a valid gData object") + if (!exists(x@gGraph.name, envir = .GlobalEnv)) stop(paste("gGraph object", x@gGraph.name, "not found.")) + if (length(x@nodes.id) == 0) stop("No assigned nodes (x@nodes.id is empty).") + if (!isConnected(x)) stop("Not all locations are connected by the graph") - ## build the wrapper ## - myGraph <- get(x@gGraph.name, envir=.GlobalEnv) # myGraph is a gGraph object - coords <- getCoords(myGraph) # store xy for later - myGraph <- getGraph(myGraph) + ## build the wrapper ## + myGraph <- get(x@gGraph.name, envir = .GlobalEnv) # myGraph is a gGraph object + coords <- getCoords(myGraph) # store xy for later + myGraph <- getGraph(myGraph) - ## if(is.character(weights) && weights=="default"){ # no longer used - ## weights <- unlist(edgeWeights(myGraph)) - ## } + ## if(is.character(weights) && weights=="default"){ # no longer used + ## weights <- unlist(edgeWeights(myGraph)) + ## } - ## wrap ## - res <- RBGL::sp.between(myGraph, start=start, finish=x@nodes.id) + ## wrap ## + res <- RBGL::sp.between(myGraph, start = start, finish = x@nodes.id) - ## sp.between uses unique(x@nodes.id) ## - ## eventually have to duplicate paths ## - temp <- gsub(".*:","",names(res)) - res <- res[match(getNodes(x), temp)] + ## sp.between uses unique(x@nodes.id) ## + ## eventually have to duplicate paths ## + temp <- gsub(".*:", "", names(res)) + res <- res[match(getNodes(x), temp)] - ## 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" + ## 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) + return(res) }) # end dijkstraFrom for gData @@ -346,38 +343,39 @@ setMethod("dijkstraFrom", "gData", function(x, start){ #' @rdname dijkstra-methods #' @method plot gPath #' @export -plot.gPath <- function(x, col="rainbow", lwd=3, ...){ - - ##listNodes <- lapply(x[-length(x)], function(e) e$path_detail) - listNodes <- lapply(x, function(e) e$path_detail) - - ##xy <- x$xy - xy <- attr(x,"xy") - Npath <- length(listNodes) - - ## handle color ## - if(is.character(col) && col[1]=="rainbow"){ - col <- sample(grDevices::rainbow(length(x))) - } - col <- rep(col, length=Npath) - lwd <- rep(lwd, length=Npath) - - - ## function plotting one gPath - f1 <- function(vecNodes, col, lwd, ...){ - N <- length(vecNodes) - if(N<2) return() # escape if a path is a single vertice - from <- vecNodes[1:(N-1)] - to <- vecNodes[2:N] - ## segments(xy[from,1], xy[from,2], xy[to,1], xy[to,2], col=col, lwd=lwd, ...) - geo.segments(xy[from,1], xy[from,2], xy[to,1], xy[to,2], col=col, lwd=lwd, ...) - } - - - ## plot all gPaths - lapply(1:length(listNodes), function(i) f1(listNodes[[i]], col=col[i], lwd=lwd[i], ...)) - - return(invisible()) +plot.gPath <- function(x, col = "rainbow", lwd = 3, ...) { + ## listNodes <- lapply(x[-length(x)], function(e) e$path_detail) + listNodes <- lapply(x, function(e) e$path_detail) + + ## xy <- x$xy + xy <- attr(x, "xy") + Npath <- length(listNodes) + + ## handle color ## + if (is.character(col) && col[1] == "rainbow") { + col <- sample(grDevices::rainbow(length(x))) + } + col <- rep(col, length = Npath) + lwd <- rep(lwd, length = Npath) + + + ## function plotting one gPath + f1 <- function(vecNodes, col, lwd, ...) { + N <- length(vecNodes) + if (N < 2) { + return() + } # escape if a path is a single vertice + from <- vecNodes[1:(N - 1)] + to <- vecNodes[2:N] + ## segments(xy[from,1], xy[from,2], xy[to,1], xy[to,2], col=col, lwd=lwd, ...) + geo.segments(xy[from, 1], xy[from, 2], xy[to, 1], xy[to, 2], col = col, lwd = lwd, ...) + } + + + ## plot all gPaths + lapply(1:length(listNodes), function(i) f1(listNodes[[i]], col = col[i], lwd = lwd[i], ...)) + + return(invisible()) } # end plot.gPath @@ -398,40 +396,40 @@ plot.gPath <- function(x, col="rainbow", lwd=3, ...){ #' @rdname dijkstra-methods #' @export -gPath2dist <- function(m, diag=FALSE, upper=FALSE, res.type=c("dist","vector")){ - - ## find the size of the dist object ## - x <- m - res.type <- match.arg(res.type) - L <- length(x) - x.names <- sub(":.*","",names(x)) - i <- 1 - while(x.names[i]==x.names[i+1] && i1){ - x@nodes.attr <- cbind.data.frame(x@nodes.attr,res) - } else { - x@nodes.attr <- res - } +setMethod("extractFromLayer", "gGraph", function(x, layer = "world", attr = "all", ...) { + coords <- getCoords(x) + res <- extractFromLayer(x = coords, layer = layer, attr = attr, ...) + + if (nrow(x@nodes.attr) > 1) { + x@nodes.attr <- cbind.data.frame(x@nodes.attr, res) + } else { + x@nodes.attr <- res + } - return(x) + return(x) }) # end findLand @@ -220,23 +219,22 @@ setMethod("extractFromLayer", "gGraph", function(x, layer="world", attr="all",.. ############## #' @rdname extractFromLayer #' @export -setMethod("extractFromLayer", "gData", function(x, layer="world", attr="all",...){ - coords <- getCoords(x) - res <- extractFromLayer(x=coords, layer=layer, attr=attr, ...) - - if(is.null(x@data)){ - x@data <- res - }else if(length(nrow(x@data))>0 && nrow(x@data)>1){ # if data are non-empty data.frame - x@data <- cbind.data.frame(x@data,res) - } else if(is.list(x@data)){ # if data is a list - x@data$layerInfo <- res - } else if(is.vector(x@data) & length(x@data)==nrow(res)){ # if data is a 'mergeable' vector - x@data <- cbind.data.frame(x@data, res) - } else{ # else, build a list - warning("x@data has been transformed into a list to include layer data.") - x@data <- list(x@data, layerInfo=res) - } - - return(x) +setMethod("extractFromLayer", "gData", function(x, layer = "world", attr = "all", ...) { + coords <- getCoords(x) + res <- extractFromLayer(x = coords, layer = layer, attr = attr, ...) + + if (is.null(x@data)) { + x@data <- res + } else if (length(nrow(x@data)) > 0 && nrow(x@data) > 1) { # if data are non-empty data.frame + x@data <- cbind.data.frame(x@data, res) + } else if (is.list(x@data)) { # if data is a list + x@data$layerInfo <- res + } else if (is.vector(x@data) & length(x@data) == nrow(res)) { # if data is a 'mergeable' vector + x@data <- cbind.data.frame(x@data, res) + } else { # else, build a list + warning("x@data has been transformed into a list to include layer data.") + x@data <- list(x@data, layerInfo = res) + } + + return(x) }) # end findLand - diff --git a/R/findLand.R b/R/findLand.R index 26f49db..a187d40 100644 --- a/R/findLand.R +++ b/R/findLand.R @@ -37,8 +37,8 @@ #' #' #' ## create a new gGraph with random coordinates -#' myCoords <- data.frame(long=runif(1000,-180,180), lat=runif(1000,-90,90)) -#' obj <- new("gGraph", coords=myCoords) +#' myCoords <- data.frame(long = runif(1000, -180, 180), lat = runif(1000, -90, 90)) +#' obj <- new("gGraph", coords = myCoords) #' obj # note: no node attribute #' plot(obj) #' @@ -47,14 +47,13 @@ #' obj # note: new node attribute #' #' ## define rules for colors -#' temp <- data.frame(habitat=c("land","sea"), color=c("green","blue")) +#' temp <- data.frame(habitat = c("land", "sea"), color = c("green", "blue")) #' temp #' obj@meta$color <- temp #' #' ## plot object with new colors #' plot(obj) #' -#' NULL @@ -63,8 +62,8 @@ NULL ############ #' @rdname findLand #' @export -setGeneric("findLand", function(x,...) { - standardGeneric("findLand") +setGeneric("findLand", function(x, ...) { + standardGeneric("findLand") }) @@ -77,42 +76,42 @@ setGeneric("findLand", function(x,...) { ################ #' @rdname findLand #' @export -setMethod("findLand", "matrix", function(x, shape="world", ...) { - - ## This functions automatically assigns to land all points overlapping the country polygons - if(!require(maptools)) stop("maptools package is required.") - - ## Load country shapefile - if(is.character(shape) && shape[1]=="world"){ - shape <- worldshape +setMethod("findLand", "matrix", function(x, shape = "world", ...) { + ## This functions automatically assigns to land all points overlapping the country polygons + # if(!require(maptools)) stop("maptools package is required.") + + ## Load country shapefile + if (is.character(shape) && shape[1] == "world") { + shape <- worldshape + } + + if (!is.null(shape)) { # with background + if (!inherits(shape, "SpatialPolygonsDataFrame")) { + stop("Layer must be a SpatialPolygonsDataFrame object \n(see st_read and as_Spatial in sf to import such data from a GIS shapefile).") } + } - if(!is.null(shape)){ # with background - if(!inherits(shape,"SpatialPolygonsDataFrame")) - stop("Shape must be a SpatialPolygonsDataFrame object \n(see readShapePoly in maptools to import such data from a GIS shapefile).") - } + long <- x[, 1] + lat <- x[, 2] + n.country <- length(shape@polygons) - long <- x[,1] - lat <- x[,2] - n.country <- length(shape@polygons) + ## create land vector to score land + land <- rep(0, length(lat)) - ## create land vector to score land - land <- rep(0,length(lat)) + for (i in 1:n.country) { + this.country <- shape@polygons[i][[1]] + n.polys <- length(this.country@Polygons) - for(i in 1:n.country) { - this.country <- shape@polygons[i][[1]] - n.polys <- length(this.country@Polygons) - - for (p in 1:n.polys) { - this.poly <- this.country@Polygons[p][[1]] - land <- land + point.in.polygon(long,lat, this.poly@coords[,1], this.poly@coords[,2]) - } + for (p in 1:n.polys) { + this.poly <- this.country@Polygons[p][[1]] + land <- land + point.in.polygon(long, lat, this.poly@coords[, 1], this.poly@coords[, 2]) } - land[land>1] <- 1 - land[land==0] <- "sea" - land[land==1] <- "land" + } + land[land > 1] <- 1 + land[land == 0] <- "sea" + land[land == 1] <- "land" - return(factor(land)) + return(factor(land)) }) @@ -122,9 +121,9 @@ setMethod("findLand", "matrix", function(x, shape="world", ...) { ################ #' @rdname findLand #' @export -setMethod("findLand", "data.frame", function(x, shape="world",...){ - x <- as.matrix(x) - return(findLand(x, shape=shape, ...)) +setMethod("findLand", "data.frame", function(x, shape = "world", ...) { + x <- as.matrix(x) + return(findLand(x, shape = shape, ...)) }) # end findLand @@ -137,16 +136,15 @@ setMethod("findLand", "data.frame", function(x, shape="world",...){ ############## #' @rdname findLand #' @export -setMethod("findLand", "gGraph", function(x, shape="world", attr.name="habitat",...){ - coords <- getCoords(x) - res <- findLand(coords, shape=shape, ...) - if(nrow(x@nodes.attr)>1){ - x@nodes.attr <- cbind.data.frame(x@nodes.attr, res) - names(x@nodes.attr)[ncol(x@nodes.attr)] <- attr.name - } else { - x@nodes.attr <- data.frame(res) - names(x@nodes.attr) <- attr.name - } - return(x) +setMethod("findLand", "gGraph", function(x, shape = "world", attr.name = "habitat", ...) { + coords <- getCoords(x) + res <- findLand(coords, shape = shape, ...) + if (nrow(x@nodes.attr) > 1) { + x@nodes.attr <- cbind.data.frame(x@nodes.attr, res) + names(x@nodes.attr)[ncol(x@nodes.attr)] <- attr.name + } else { + x@nodes.attr <- data.frame(res) + names(x@nodes.attr) <- attr.name + } + return(x) }) # end findLand - diff --git a/R/geograph.R b/R/geograph.R index 616859f..63b553b 100644 --- a/R/geograph.R +++ b/R/geograph.R @@ -89,21 +89,14 @@ #' \code{\link{worldgraph.40k}}: coverage using about 40,000 nodes\cr #' #' Other datasets are:\cr - \code{\link{worldshape}}: shapefile containing -#' world countries.\cr - \code{\link{globalcoord.10k}}: spatial coordinates -#' used in \code{\link{worldgraph.10k}}.\cr - \code{\link{globalcoord.40k}}: -#' spatial coordinates used in \code{\link{worldgraph.40k}}.\cr +#' world countries.\cr #' #' To cite geoGraph, please use the reference given by #' \code{citation("geoGraph")}. #' -#' \tabular{ll}{ Package: \tab geoGraph\cr Type: \tab Package\cr Version: \tab -#' 1.0-0\cr Date: \tab 2010-07-01 \cr License: \tab GPL (>=2) } -#' #' @name geoGraph-package #' @aliases geoGraph-package geoGraph #' @docType package -#' @author Thibaut Jombart (maintainer)\cr François -#' Balloux \cr Andrea Manica \cr #' @keywords manip spatial #' @examples #' @@ -111,10 +104,10 @@ #' worldgraph.10k #' #' ## plotting the object -#' plot(worldgraph.10k, reset=TRUE) +#' plot(worldgraph.10k, reset = TRUE) #' #' ## zooming in -#' geo.zoomin(list(x=c(-6,38), y=c(35,73))) +#' geo.zoomin(list(x = c(-6, 38), y = c(35, 73))) #' title("Europe") #' #' ## to play interactively with graphics, use: @@ -125,18 +118,17 @@ #' #' ## defining a new object restrained to visible nodes #' x <- worldgraph.10k[isInArea(worldgraph.10k)] -#' plot(x,reset=TRUE, edges=TRUE) +#' plot(x, reset = TRUE, edges = TRUE) #' title("x does just contain these visible nodes.") #' #' ## define weights for edges -#' x <- setCosts(x, attr.name="habitat", method="prod") -#' plot(x,edges=TRUE) +#' x <- setCosts(x, attr.name = "habitat", method = "prod") +#' plot(x, edges = TRUE) #' title("connectivity defined by habitat (land/land=1, other=0)") #' #' ## drop 'dead edges' (i.e. with weight 0) #' x <- dropDeadEdges(x) -#' plot(x,edges=TRUE) +#' plot(x, edges = TRUE) #' title("after droping edges with null weight") #' -#' NULL diff --git a/R/globals.R b/R/globals.R index a56dd28..988f102 100644 --- a/R/globals.R +++ b/R/globals.R @@ -1 +1 @@ -utils::globalVariables(c("rawgraph.10k","rawgraph.40k","worldshape")) +utils::globalVariables(c("rawgraph.10k", "rawgraph.40k", "worldshape")) diff --git a/R/interact.R b/R/interact.R index 2e3d261..36908da 100644 --- a/R/interact.R +++ b/R/interact.R @@ -33,114 +33,113 @@ NULL #' a \linkS4class{gGraph} object. #' @keywords utilities #' @examples -#' #' \dontrun{ -#' plot(worldgraph.10k, reset=TRUE) +#' plot(worldgraph.10k, reset = TRUE) #' #' ## zooming in -#' geo.zoomin(list(x=c(-6,38), y=c(35,73))) +#' geo.zoomin(list(x = c(-6, 38), y = c(35, 73))) #' title("Europe") #' #' ## remove edges #' geo.remove.edges(worldgraph.10k) # points mode -#' geo.remove.edges(worldgraph.10k, mode="area") # area mode +#' geo.remove.edges(worldgraph.10k, mode = "area") # area mode #' #' ## add edges #' geo.add.edges(worldgraph.10k) # points mode -#' geo.add.edges(worldgraph.10k, mode="area") # area mode +#' geo.add.edges(worldgraph.10k, mode = "area") # area mode #' } #' @export -geo.add.edges <- function(x, mode=c("points","area","all"), refObj="rawgraph.40k") { - ## preliminary stuff - if(!is.gGraph(x)) stop("x is not a valid gGraph object") - mode <- match.arg(mode) - ## temp <- isInArea(x) # not needed - ## coords <- getCoords(x)[temp,] - ## nodes <- getNodes(x)[temp] - coords <- getCoords(x) - nodes <- getNodes(x) - lon <- coords[,1] - lat <- coords[,2] - #env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement - - ## handle refObj - if(is.character(refObj) && refObj=="rawgraph.10k"){ - refObj <- rawgraph.10k - } else if(is.character(refObj) && refObj=="rawgraph.40k"){ - refObj <- rawgraph.40k - } else if(!is.gGraph(refObj)){ - stop("refObj is not a valid gGraph object.") - } - - ## handle plot param - last.plot.param <- get("last.plot.param", envir=.geoGraphEnv) - psize <- last.plot.param$psize - pch <- last.plot.param$pch - - ## initialize toAdd - toAdd <- list(from=NULL, to=NULL) - - ## "points" mode ## - if(mode=="points"){ - spoint <- 1:2 - ## getting input from the user - while (length(spoint) > 1) { - spoint <- NULL - spoint <- identify(lon, lat, plot=FALSE, n=2) - if(length(spoint) > 1) { - segments(lon[spoint[1]], lat[spoint[1]], lon[spoint[2]], lat[spoint[2]], col="green") - points(lon[spoint[1]],lat[spoint[1]],cex=psize, col="green", pch=pch) - points(lon[spoint[2]],lat[spoint[2]],cex=psize, col="green", pch=pch) - - toAdd$from <- c(toAdd$from, nodes[spoint[1]]) - toAdd$to <- c(toAdd$to, nodes[spoint[2]]) - } - } - } # end mode "points" - - ## "area" mode ## - if(mode=="area"){ - selArea <- data.frame(x=1:2,y=1:2) - - ## getting input from the user - while(nrow(selArea) > 1) { - ## selArea <- selArea[integer(0),] not needed - selArea <- data.frame(locator(2)) - - if(nrow(selArea) > 1) { - selNodes <- isInArea(refObj, reg=selArea, res.type="integer") # indices of selected points - selEdges <- getEdges(refObj, res.type="matId", unique=TRUE) # edges, nodes=numerical indices - temp <- (selEdges[,1] %in% selNodes) & (selEdges[,2] %in% selNodes) - selEdges <- selEdges[temp,] # edges of refobj wholly inside the selected area - - segments(lon[selEdges[,1]], lat[selEdges[,1]], lon[selEdges[,2]], lat[selEdges[,2]], col="red") - points(lon[selNodes], lat[selNodes], cex=psize, col="green", pch=pch) - - toAdd$from <- c(toAdd$from, getNodes(refObj)[selEdges[,1]]) - toAdd$to <- c(toAdd$to, getNodes(refObj)[selEdges[,2]]) - } - } # end while - } # end mode "area" - - ## "all" mode ## - if(mode=="all"){ - x@graph <- getGraph(refObj) - return(x) +geo.add.edges <- function(x, mode = c("points", "area", "all"), refObj = "rawgraph.40k") { + ## preliminary stuff + if (!is.gGraph(x)) stop("x is not a valid gGraph object") + mode <- match.arg(mode) + ## temp <- isInArea(x) # not needed + ## coords <- getCoords(x)[temp,] + ## nodes <- getNodes(x)[temp] + coords <- getCoords(x) + nodes <- getNodes(x) + lon <- coords[, 1] + lat <- coords[, 2] + # env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement + + ## handle refObj + if (is.character(refObj) && refObj == "rawgraph.10k") { + refObj <- rawgraph.10k + } else if (is.character(refObj) && refObj == "rawgraph.40k") { + refObj <- rawgraph.40k + } else if (!is.gGraph(refObj)) { + stop("refObj is not a valid gGraph object.") + } + + ## handle plot param + last.plot.param <- get("last.plot.param", envir = .geoGraphEnv) + psize <- last.plot.param$psize + pch <- last.plot.param$pch + + ## initialize toAdd + toAdd <- list(from = NULL, to = NULL) + + ## "points" mode ## + if (mode == "points") { + spoint <- 1:2 + ## getting input from the user + while (length(spoint) > 1) { + spoint <- NULL + spoint <- identify(lon, lat, plot = FALSE, n = 2) + if (length(spoint) > 1) { + segments(lon[spoint[1]], lat[spoint[1]], lon[spoint[2]], lat[spoint[2]], col = "green") + points(lon[spoint[1]], lat[spoint[1]], cex = psize, col = "green", pch = pch) + points(lon[spoint[2]], lat[spoint[2]], cex = psize, col = "green", pch = pch) + + toAdd$from <- c(toAdd$from, nodes[spoint[1]]) + toAdd$to <- c(toAdd$to, nodes[spoint[2]]) + } } - - ## make sure added edges are unique - toAdd <- as.matrix(as.data.frame(toAdd)) - toAdd <- t(apply(toAdd,1,sort)) # sorting - toAdd <- paste(toAdd[,1], toAdd[,2], sep="-") # making strings - toAdd <- unique(toAdd) # keep unique strings - toAdd <- strsplit(toAdd, "-") - from <- sapply(toAdd, function(e) e[1]) - to <- sapply(toAdd, function(e) e[2]) - - ## call to setEdges - res <- setEdges(x=x, add=cbind(from, to) ) - - return(res) + } # end mode "points" + + ## "area" mode ## + if (mode == "area") { + selArea <- data.frame(x = 1:2, y = 1:2) + + ## getting input from the user + while (nrow(selArea) > 1) { + ## selArea <- selArea[integer(0),] not needed + selArea <- data.frame(locator(2)) + + if (nrow(selArea) > 1) { + selNodes <- isInArea(refObj, reg = selArea, res.type = "integer") # indices of selected points + selEdges <- getEdges(refObj, res.type = "matId", unique = TRUE) # edges, nodes=numerical indices + temp <- (selEdges[, 1] %in% selNodes) & (selEdges[, 2] %in% selNodes) + selEdges <- selEdges[temp, ] # edges of refobj wholly inside the selected area + + segments(lon[selEdges[, 1]], lat[selEdges[, 1]], lon[selEdges[, 2]], lat[selEdges[, 2]], col = "red") + points(lon[selNodes], lat[selNodes], cex = psize, col = "green", pch = pch) + + toAdd$from <- c(toAdd$from, getNodes(refObj)[selEdges[, 1]]) + toAdd$to <- c(toAdd$to, getNodes(refObj)[selEdges[, 2]]) + } + } # end while + } # end mode "area" + + ## "all" mode ## + if (mode == "all") { + x@graph <- getGraph(refObj) + return(x) + } + + ## make sure added edges are unique + toAdd <- as.matrix(as.data.frame(toAdd)) + toAdd <- t(apply(toAdd, 1, sort)) # sorting + toAdd <- paste(toAdd[, 1], toAdd[, 2], sep = "-") # making strings + toAdd <- unique(toAdd) # keep unique strings + toAdd <- strsplit(toAdd, "-") + from <- sapply(toAdd, function(e) e[1]) + to <- sapply(toAdd, function(e) e[2]) + + ## call to setEdges + res <- setEdges(x = x, add = cbind(from, to)) + + return(res) } # end geo.add.edges @@ -152,89 +151,88 @@ geo.add.edges <- function(x, mode=c("points","area","all"), refObj="rawgraph.40k ## geo.remove.edges #################### #' @export -geo.remove.edges <- function(x, mode=c("points","area")) { - ## preliminary stuff - if(!is.gGraph(x)) stop("x is not a valid gGraph object") - temp <- isInArea(x) - # coords <- getCoords(x)[temp,] # not needed: can work with whole object - coords <- getCoords(x) - nodeNames <- getNodes(x) - lon <- coords[,1] - lat <- coords[,2] - #env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement - psize <- get("psize", envir=.geoGraphEnv) - mode <- match.arg(mode) - - ## handle plot param - last.plot.param <- get("last.plot.param", envir=.geoGraphEnv) - psize <- last.plot.param$psize - pch <- last.plot.param$pch - - ## initialize toRemove - toRemove <- list(from=NULL, to=NULL) - - - ## mode: points ## - - if(mode=="points"){ - spoint <- 1:2 - ## getting input from the user - while(length(spoint) > 1) { - spoint <- NULL - spoint <- identify(lon, lat, plot=FALSE, n=2) - if(length(spoint) > 1) { - segments(lon[spoint[1]], lat[spoint[1]], lon[spoint[2]], lat[spoint[2]], col="red") - points(lon[spoint[1]], lat[spoint[1]], cex=psize, col="red", pch=pch) - points(lon[spoint[2]], lat[spoint[2]], cex=psize, col="red", pch=pch) - - toRemove$from <- c(toRemove$from, nodeNames[spoint[1]]) - toRemove$to <- c(toRemove$to, nodeNames[spoint[2]]) - } - } - } # end mode: points - - - ## mode: area ## - - if(mode=="area"){ - selArea <- data.frame(x=1:2,y=1:2) - - ## getting input from the user - while(nrow(selArea) > 1) { - ## selArea <- selArea[integer(0),] not needed - selArea <- data.frame(locator(2)) - - if(nrow(selArea) > 1) { - selIdx <- which(isInArea(x, reg=selArea)) # indices of selected points - selEdges <- getEdges(x, res.type="matId", unique=TRUE) # edges, nodes=numerical indices - temp <- (selEdges[,1] %in% selIdx) & (selEdges[,2] %in% selIdx) - selEdges <- selEdges[temp,] # edges wholly inside the selected area - - segments(lon[selEdges[,1]], lat[selEdges[,1]], lon[selEdges[,2]], lat[selEdges[,2]], col="red") - points(lon[selIdx], lat[selIdx], cex=psize*1.5, col="red") - - toRemove$from <- c(toRemove$from, nodeNames[selEdges[,1]]) - toRemove$to <- c(toRemove$to, nodeNames[selEdges[,2]]) - } - } - - } # end mode: area - - - ## handle toRemove ## - ## make sure removed edges are unique - toRemove <- as.matrix(as.data.frame(toRemove)) - toRemove <- t(apply(toRemove,1,sort)) # sorting - toRemove <- paste(toRemove[,1], toRemove[,2], sep="-") # making strings - toRemove <- unique(toRemove) # keep unique strings - toRemove <- strsplit(toRemove, "-") - from <- sapply(toRemove, function(e) e[1]) - to <- sapply(toRemove, function(e) e[2]) - - ## call to setEdges - res <- setEdges(x=x, remove=cbind(from, to) ) - - return(res) +geo.remove.edges <- function(x, mode = c("points", "area")) { + ## preliminary stuff + if (!is.gGraph(x)) stop("x is not a valid gGraph object") + temp <- isInArea(x) + # coords <- getCoords(x)[temp,] # not needed: can work with whole object + coords <- getCoords(x) + nodeNames <- getNodes(x) + lon <- coords[, 1] + lat <- coords[, 2] + # env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement + psize <- get("psize", envir = .geoGraphEnv) + mode <- match.arg(mode) + + ## handle plot param + last.plot.param <- get("last.plot.param", envir = .geoGraphEnv) + psize <- last.plot.param$psize + pch <- last.plot.param$pch + + ## initialize toRemove + toRemove <- list(from = NULL, to = NULL) + + + ## mode: points ## + + if (mode == "points") { + spoint <- 1:2 + ## getting input from the user + while (length(spoint) > 1) { + spoint <- NULL + spoint <- identify(lon, lat, plot = FALSE, n = 2) + if (length(spoint) > 1) { + segments(lon[spoint[1]], lat[spoint[1]], lon[spoint[2]], lat[spoint[2]], col = "red") + points(lon[spoint[1]], lat[spoint[1]], cex = psize, col = "red", pch = pch) + points(lon[spoint[2]], lat[spoint[2]], cex = psize, col = "red", pch = pch) + + toRemove$from <- c(toRemove$from, nodeNames[spoint[1]]) + toRemove$to <- c(toRemove$to, nodeNames[spoint[2]]) + } + } + } # end mode: points + + + ## mode: area ## + + if (mode == "area") { + selArea <- data.frame(x = 1:2, y = 1:2) + + ## getting input from the user + while (nrow(selArea) > 1) { + ## selArea <- selArea[integer(0),] not needed + selArea <- data.frame(locator(2)) + + if (nrow(selArea) > 1) { + selIdx <- which(isInArea(x, reg = selArea)) # indices of selected points + selEdges <- getEdges(x, res.type = "matId", unique = TRUE) # edges, nodes=numerical indices + temp <- (selEdges[, 1] %in% selIdx) & (selEdges[, 2] %in% selIdx) + selEdges <- selEdges[temp, ] # edges wholly inside the selected area + + segments(lon[selEdges[, 1]], lat[selEdges[, 1]], lon[selEdges[, 2]], lat[selEdges[, 2]], col = "red") + points(lon[selIdx], lat[selIdx], cex = psize * 1.5, col = "red") + + toRemove$from <- c(toRemove$from, nodeNames[selEdges[, 1]]) + toRemove$to <- c(toRemove$to, nodeNames[selEdges[, 2]]) + } + } + } # end mode: area + + + ## handle toRemove ## + ## make sure removed edges are unique + toRemove <- as.matrix(as.data.frame(toRemove)) + toRemove <- t(apply(toRemove, 1, sort)) # sorting + toRemove <- paste(toRemove[, 1], toRemove[, 2], sep = "-") # making strings + toRemove <- unique(toRemove) # keep unique strings + toRemove <- strsplit(toRemove, "-") + from <- sapply(toRemove, function(e) e[1]) + to <- sapply(toRemove, function(e) e[2]) + + ## call to setEdges + res <- setEdges(x = x, remove = cbind(from, to)) + + return(res) } # end geo.remove.edges @@ -281,150 +279,144 @@ geo.remove.edges <- function(x, mode=c("points","area")) { #' @author Thibaut Jombart (\email{t.jombart@@imperial.ac.uk}) #' @keywords utilities #' @examples -#' #' \dontrun{ -#' plot(worldgraph.10k, reset=TRUE) +#' plot(worldgraph.10k, reset = TRUE) #' #' ## have to click here for an area #' ## all nodes are modified in the area -#' x <- geo.change.attr(worldgraph.10k, mode="area", attr.name="habitat", attr.value="fancy -#' habitat", newCol="pink") # modify selected area +#' x <- geo.change.attr(worldgraph.10k, mode = "area", attr.name = "habitat", attr.value = "fancy +#' habitat", newCol = "pink") # modify selected area #' -#' plot(x,reset=TRUE) # modification in the whole selected area +#' plot(x, reset = TRUE) # modification in the whole selected area #' #' ## have to click here for an area #' ## only nodes on land are modified -#' x <- geo.change.attr(x, mode="area", attr.name="habitat", attr.value="fancy2 -#' habitat", newCol="purple", only.name="habitat", only.value="land") +#' x <- geo.change.attr(x, mode = "area", attr.name = "habitat", attr.value = "fancy2 +#' habitat", newCol = "purple", only.name = "habitat", only.value = "land") #' -#' plot(x,reset=TRUE) # modification in the whole selected area +#' plot(x, reset = TRUE) # modification in the whole selected area #' } #' #' @export -geo.change.attr <- function(x, mode=c("points","area"), attr.name, attr.value, - only.name=NULL, only.value=NULL, newCol="black", - restore.edges=FALSE, refObj="rawgraph.40k") { - - ## preliminary stuff ## - if(!is.gGraph(x)) stop("x is not a valid gGraph object") - - ## handle "only" ## - if(!is.null(only.name)){ - temp <- unlist(getNodesAttr(x, attr.name=only.name)) - temp <- as.character(unlist(temp)) - hasRightAttr <- which(temp==only.value) - if(length(hasRightAttr)==0) stop(paste("specified values of",only.name,"never found.")) - } else{ - hasRightAttr <- 1:nrow(getCoords(x)) +geo.change.attr <- function(x, mode = c("points", "area"), attr.name, attr.value, + only.name = NULL, only.value = NULL, newCol = "black", + restore.edges = FALSE, refObj = "rawgraph.40k") { + ## preliminary stuff ## + if (!is.gGraph(x)) stop("x is not a valid gGraph object") + + ## handle "only" ## + if (!is.null(only.name)) { + temp <- unlist(getNodesAttr(x, attr.name = only.name)) + temp <- as.character(unlist(temp)) + hasRightAttr <- which(temp == only.value) + if (length(hasRightAttr) == 0) stop(paste("specified values of", only.name, "never found.")) + } else { + hasRightAttr <- 1:nrow(getCoords(x)) + } + + ## handle refObj ## + if (restore.edges) { + if (is.character(refObj) && refObj == "rawgraph.10k") { + refObj <- rawgraph.10k + } else if (is.character(refObj) && refObj == "rawgraph.40k") { + refObj <- rawgraph.40k + } else if (!is.gGraph(refObj)) { + stop("refObj is not a valid gGraph object.") } - - ## handle refObj ## - if(restore.edges){ - if(is.character(refObj) && refObj=="rawgraph.10k"){ - refObj <- rawgraph.10k - } else if(is.character(refObj) && refObj=="rawgraph.40k"){ - refObj <- rawgraph.40k - } else if(!is.gGraph(refObj)){ - stop("refObj is not a valid gGraph object.") - } - } # end handle refObj - - - coords <- getCoords(x) - lon <- coords[,1] - lat <- coords[,2] - #env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement - mode <- match.arg(mode) - if(!attr.name %in% colnames(x@nodes.attr)) stop("specified node attribute name not found") - - ## set replacement colors - if( (!is.null(x@meta$colors)) && (attr.name %in% colnames(x@meta$colors)) ){ - temp <- which(attr.value == x@meta$colors[,attr.name])[1] - if(!is.na(temp)){ # attr.value is documented in @meta$colors - newCol <- x@meta$colors[temp,2] - } else{ # if attr.value is not documented, we document it in @meta$colors - if(is.factor(x@meta$colors[,attr.name])){ # if attr is a factor - x@meta$colors[,attr.name] <- as.character(x@meta$colors[,attr.name]) # convert as character - x@meta$colors <- rbind.data.frame(x@meta$colors, c(attr.value,newCol)) - x@meta$colors[,attr.name] <- factor(x@meta$colors[,attr.name]) # restore factor type - } else { # attr is not a factor - x@meta$colors <- rbind.data.frame(x@meta$colors, c(attr.value,newCol)) - } - } - } # end setting replacement colors - - - ## handle plot param - last.plot.param <- get("last.plot.param", envir=.geoGraphEnv) - psize <- last.plot.param$psize - pch <- last.plot.param$pch - - ## initialize toChange - toChange <- integer(0) - - - ## mode: points ## - - if(mode=="points"){ - spoint <- 0 - ## getting input from the user - while(length(spoint) > 0) { - spoint <- NULL - spoint <- identify(lon, lat, plot=FALSE, n=1) - if(length(spoint) > 0) { - spoint <- spoint[spoint %in% hasRightAttr] # only nodes with a given attributes will be modified - points(lon[spoint], lat[spoint], cex=psize, pch=pch, col=newCol) - - toChange <- c(toChange, spoint) - - } - } - } # end mode: points - - if(mode=="area"){ - selArea <- data.frame(x=1:2,y=1:2) - - ## getting input from the user - while(nrow(selArea) > 1) { - selArea <- selArea[integer(0),] - selArea <- data.frame(locator(2)) - - if(nrow(selArea) > 1) { - selIdx <- which(isInArea(x, reg=selArea)) # indices of selected points - selIdx <- selIdx[selIdx %in% hasRightAttr] # only nodes with replaced attribute - points(lon[selIdx], lat[selIdx], cex=psize, pch=pch, col=newCol) - - toChange <- c(toChange, selIdx) - } - } - - } # end mode: area - - - ## make changes ## - toChange <- unique(toChange) # unique id - res <- x - - if(is.factor(res@nodes.attr[,attr.name])){ # special handling if attr is a factor - temp <- as.character(res@nodes.attr[, attr.name]) - temp[toChange] <- attr.value - res@nodes.attr[,attr.name] <- factor(temp) - } else { # in other cases... - res@nodes.attr[toChange,attr.name] <- attr.value + } # end handle refObj + + + coords <- getCoords(x) + lon <- coords[, 1] + lat <- coords[, 2] + # env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement + mode <- match.arg(mode) + if (!attr.name %in% colnames(x@nodes.attr)) stop("specified node attribute name not found") + + ## set replacement colors + if ((!is.null(x@meta$colors)) && (attr.name %in% colnames(x@meta$colors))) { + temp <- which(attr.value == x@meta$colors[, attr.name])[1] + if (!is.na(temp)) { # attr.value is documented in @meta$colors + newCol <- x@meta$colors[temp, 2] + } else { # if attr.value is not documented, we document it in @meta$colors + if (is.factor(x@meta$colors[, attr.name])) { # if attr is a factor + x@meta$colors[, attr.name] <- as.character(x@meta$colors[, attr.name]) # convert as character + x@meta$colors <- rbind.data.frame(x@meta$colors, c(attr.value, newCol)) + x@meta$colors[, attr.name] <- factor(x@meta$colors[, attr.name]) # restore factor type + } else { # attr is not a factor + x@meta$colors <- rbind.data.frame(x@meta$colors, c(attr.value, newCol)) + } } + } # end setting replacement colors + + + ## handle plot param + last.plot.param <- get("last.plot.param", envir = .geoGraphEnv) + psize <- last.plot.param$psize + pch <- last.plot.param$pch + + ## initialize toChange + toChange <- integer(0) - ## re-add some edges if restore.edges is TRUE ## - if(restore.edges){ - nodeLab <- getNodes(res)[toChange] # label of changed nodes - temp <- adj(getGraph(refObj), nodeLab) - toAdd1 <- rep(names(temp),sapply(temp,length)) - toAdd2 <- unlist(temp) - toAdd <- list(toAdd1,toAdd2) - res <- setEdges(res, add=toAdd) + + ## mode: points ## + + if (mode == "points") { + spoint <- 0 + ## getting input from the user + while (length(spoint) > 0) { + spoint <- NULL + spoint <- identify(lon, lat, plot = FALSE, n = 1) + if (length(spoint) > 0) { + spoint <- spoint[spoint %in% hasRightAttr] # only nodes with a given attributes will be modified + points(lon[spoint], lat[spoint], cex = psize, pch = pch, col = newCol) + + toChange <- c(toChange, spoint) + } } - ## need to save the call here ! ## + } # end mode: points - return(res) -} # end geo.change.attr + if (mode == "area") { + selArea <- data.frame(x = 1:2, y = 1:2) + ## getting input from the user + while (nrow(selArea) > 1) { + selArea <- selArea[integer(0), ] + selArea <- data.frame(locator(2)) + if (nrow(selArea) > 1) { + selIdx <- which(isInArea(x, reg = selArea)) # indices of selected points + selIdx <- selIdx[selIdx %in% hasRightAttr] # only nodes with replaced attribute + points(lon[selIdx], lat[selIdx], cex = psize, pch = pch, col = newCol) + + toChange <- c(toChange, selIdx) + } + } + } # end mode: area + + + ## make changes ## + toChange <- unique(toChange) # unique id + res <- x + + if (is.factor(res@nodes.attr[, attr.name])) { # special handling if attr is a factor + temp <- as.character(res@nodes.attr[, attr.name]) + temp[toChange] <- attr.value + res@nodes.attr[, attr.name] <- factor(temp) + } else { # in other cases... + res@nodes.attr[toChange, attr.name] <- attr.value + } + + ## re-add some edges if restore.edges is TRUE ## + if (restore.edges) { + nodeLab <- getNodes(res)[toChange] # label of changed nodes + temp <- adj(getGraph(refObj), nodeLab) + toAdd1 <- rep(names(temp), sapply(temp, length)) + toAdd2 <- unlist(temp) + toAdd <- list(toAdd1, toAdd2) + res <- setEdges(res, add = toAdd) + } + ## need to save the call here ! ## + + return(res) +} # end geo.change.attr diff --git a/R/isInArea.R b/R/isInArea.R index b879bf2..0e6d8f7 100644 --- a/R/isInArea.R +++ b/R/isInArea.R @@ -39,10 +39,10 @@ #' @export #' @examples #' -#' plot(worldgraph.10k, reset=TRUE) +#' plot(worldgraph.10k, reset = TRUE) #' #' ## zooming in -#' geo.zoomin(list(x=c(-6,38), y=c(35,73))) +#' geo.zoomin(list(x = c(-6, 38), y = c(35, 73))) #' title("Europe") #' #' @@ -52,17 +52,17 @@ #' sum(isInArea(worldgraph.10k)) #' head(which(isInArea(worldgraph.10k))) # which nodes are TRUE ? #' -#' head(isInArea(worldgraph.10k, res.type="integer")) # node indices +#' head(isInArea(worldgraph.10k, res.type = "integer")) # node indices #' -#' head(isInArea(worldgraph.10k, res.type="character")) # node names +#' head(isInArea(worldgraph.10k, res.type = "character")) # node names #' #' #' ## use isInArea to have a subset of visible nodes #' x <- worldgraph.10k[isInArea(worldgraph.10k)] -#' plot(x, reset=TRUE) +#' plot(x, reset = TRUE) #' setGeneric("isInArea", function(x, ...) { - standardGeneric("isInArea") + standardGeneric("isInArea") }) @@ -73,59 +73,57 @@ setGeneric("isInArea", function(x, ...) { ################ #' @export #' @describeIn isInArea Method for matrix -setMethod("isInArea", "matrix", function(x, reg="current", res.type=c("logical","integer","character"), buffer=0){ - ## some checks / definitiona - res.type <- match.arg(res.type) - #env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement - coords <- x - - ## get xlim and ylim - if(exists("zoom.log", envir=.geoGraphEnv) && length(reg)==1 && reg=="zoom"){ # xlim/ylim taken from log - zoomlog <- get("zoom.log", envir=.geoGraphEnv) - zoomlog <- zoomlog[1,] - - xlim <- zoomlog[1:2] - ylim <- zoomlog[3:4] - - } else if(length(reg)==1 && reg=="current"){ # xlim/ylim taken from par("usr") - xlim <- sort(graphics::par("usr")[1:2]) - ylim <- sort(graphics::par("usr")[3:4]) - - } else if(is.list(reg)){ # xlim/ylim user-provided (reg) - if(length(reg)!=2) stop("reg is not a list of length 2.") - xlim <- sort(reg[[1]])[1:2] - ylim <- sort(reg[[2]])[1:2] - - } else return(NA) - - - ## main computations ## - - ## handle a buffer around area - bufferx <- (xlim[2]-xlim[1])*buffer - buffery <- (ylim[2]-ylim[1])*buffer - - xlim <- xlim + c(-bufferx, bufferx) - ylim <- ylim + c(-buffery, buffery) - - toKeep <- ( (coords[,1] >= xlim[1]) & (coords[,1] <= xlim[2]) # matching longitude - & (coords[,2] >= ylim[1]) & (coords[,2] <= ylim[2]) ) # matching latitude - - names(toKeep) <- rownames(coords) - - if(res.type=="logical"){ # return a named vector of logicals - return(toKeep) - } - - if(res.type=="integer"){ # return a named vector of node numbers - return(which(toKeep)) - } - - if(res.type=="character"){ # return names of nodes in the area - res <- names(toKeep)[toKeep] - return(res) - } - +setMethod("isInArea", "matrix", function(x, reg = "current", res.type = c("logical", "integer", "character"), buffer = 0) { + ## some checks / definitiona + res.type <- match.arg(res.type) + # env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement + coords <- x + + ## get xlim and ylim + if (exists("zoom.log", envir = .geoGraphEnv) && length(reg) == 1 && reg == "zoom") { # xlim/ylim taken from log + zoomlog <- get("zoom.log", envir = .geoGraphEnv) + zoomlog <- zoomlog[1, ] + + xlim <- zoomlog[1:2] + ylim <- zoomlog[3:4] + } else if (length(reg) == 1 && reg == "current") { # xlim/ylim taken from par("usr") + xlim <- sort(graphics::par("usr")[1:2]) + ylim <- sort(graphics::par("usr")[3:4]) + } else if (is.list(reg)) { # xlim/ylim user-provided (reg) + if (length(reg) != 2) stop("reg is not a list of length 2.") + xlim <- sort(reg[[1]])[1:2] + ylim <- sort(reg[[2]])[1:2] + } else { + return(NA) + } + + + ## main computations ## + + ## handle a buffer around area + bufferx <- (xlim[2] - xlim[1]) * buffer + buffery <- (ylim[2] - ylim[1]) * buffer + + xlim <- xlim + c(-bufferx, bufferx) + ylim <- ylim + c(-buffery, buffery) + + toKeep <- ((coords[, 1] >= xlim[1]) & (coords[, 1] <= xlim[2]) # matching longitude + & (coords[, 2] >= ylim[1]) & (coords[, 2] <= ylim[2])) # matching latitude + + names(toKeep) <- rownames(coords) + + if (res.type == "logical") { # return a named vector of logicals + return(toKeep) + } + + if (res.type == "integer") { # return a named vector of node numbers + return(which(toKeep)) + } + + if (res.type == "character") { # return names of nodes in the area + res <- names(toKeep)[toKeep] + return(res) + } }) # end isInArea for matrix @@ -138,13 +136,12 @@ setMethod("isInArea", "matrix", function(x, reg="current", res.type=c("logical", ################ #' @export #' @describeIn isInArea Method for data.frame -setMethod("isInArea", "data.frame", function(x, reg="current", res.type=c("logical","integer","character"), buffer=0){ - - ## preliminary stuff - x <- as.data.frame(x) +setMethod("isInArea", "data.frame", function(x, reg = "current", res.type = c("logical", "integer", "character"), buffer = 0) { + ## preliminary stuff + x <- as.data.frame(x) - res <- isInArea(x=x, reg=reg, res.type=res.type, buffer=buffer) - return(res) + res <- isInArea(x = x, reg = reg, res.type = res.type, buffer = buffer) + return(res) }) # end isInArea for data.frame @@ -157,14 +154,13 @@ setMethod("isInArea", "data.frame", function(x, reg="current", res.type=c("logic ################ #' @export #' @describeIn isInArea Method for gGraph object -setMethod("isInArea", "gGraph", function(x, reg="current", res.type=c("logical","integer","character"), buffer=0){ - - ## preliminary stuff - if(!is.gGraph(x)) stop("x is not a valid gGraph object") - coords <- getCoords(x) +setMethod("isInArea", "gGraph", function(x, reg = "current", res.type = c("logical", "integer", "character"), buffer = 0) { + ## preliminary stuff + if (!is.gGraph(x)) stop("x is not a valid gGraph object") + coords <- getCoords(x) - res <- isInArea(x=coords, reg=reg, res.type=res.type, buffer=buffer) - return(res) + res <- isInArea(x = coords, reg = reg, res.type = res.type, buffer = buffer) + return(res) }) # end isInArea for gGraph @@ -177,12 +173,11 @@ setMethod("isInArea", "gGraph", function(x, reg="current", res.type=c("logical", ################ #' @export #' @describeIn isInArea Method for gData object -setMethod("isInArea", "gData", function(x, reg="current", res.type=c("logical","integer","character"), buffer=0){ +setMethod("isInArea", "gData", function(x, reg = "current", res.type = c("logical", "integer", "character"), buffer = 0) { + ## preliminary stuff + if (!is.gData(x)) stop("x is not a valid gGraph object") + coords <- getCoords(x) - ## preliminary stuff - if(!is.gData(x)) stop("x is not a valid gGraph object") - coords <- getCoords(x) - - res <- isInArea(x=coords, reg=reg, res.type=res.type, buffer=buffer) - return(res) + res <- isInArea(x = coords, reg = reg, res.type = res.type, buffer = buffer) + return(res) }) # end isInArea for gData diff --git a/R/makeGrid.R b/R/makeGrid.R index 7d3ed1f..d58ad3f 100644 --- a/R/makeGrid.R +++ b/R/makeGrid.R @@ -28,112 +28,113 @@ #' #' ## zoom in to a smaller area #' plot(worldgraph.10k) -#' geo.zoomin(c(-10,0, 50,54)) +#' geo.zoomin(c(-10, 0, 50, 54)) #' #' #' ## make a new gGraph #' newGraph <- makeGrid(1e3) #' newGraph <- findLand(newGraph) -#' newGraph@meta$colors <- data.frame(habitat=c("sea","land"), -#' color=c("blue","green")) +#' newGraph@meta$colors <- data.frame( +#' habitat = c("sea", "land"), +#' color = c("blue", "green") +#' ) #' #' #' ## plot the new gGraph -#' plot(newGraph, reset=TRUE, edge=TRUE) +#' plot(newGraph, reset = TRUE, edge = TRUE) #' -makeGrid <- function(size=NULL, n.lon=NULL, n.lat=NULL, lon.range=NULL, lat.range=NULL){ - ## HANDLE ARGUMENTS ## - if(is.null(n.lon)){ - if(is.null(size)) stop("Please provide either size or n.lon/n.lat") - n.lon <- round(sqrt(size)) - } - - if(is.null(n.lat)){ - if(is.null(size)) stop("Please provide either size or n.lon/n.lat") - n.lat <- round(sqrt(size)) - } - - if(is.null(size)){ - if(is.null(n.lon)|is.null(n.lat)) stop("Please provide either size or n.lon/n.lat") - } - - size <- n.lon*n.lat - if(size<4.1){ - size <- 4 - warning("Minimum grid size is 4 - ignoring required size.") - } - - - ## GET LON/LAT FROM ZOOM LOG ## - ## get zoom log info - #geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) - zoomLog <- get("zoom.log", envir=.geoGraphEnv) - if(nrow(zoomLog)<1) { - curZoom <- c(-180,180,-90,90) - } else { - curZoom <- zoomLog[1,] - } - - if(is.null(lon.range)){ - lon.range <- curZoom[1:2] - } - - if(is.null(lat.range)){ - lat.range <- curZoom[3:4] - } - - lon.range <- sort(lon.range) - lat.range <- sort(lat.range) - - - ## CORRECT LON/LAT ## - if(lon.range[1] < -180){ - lon.range[1] <- -180 - warning("Setting lowest longitude to -180 (i.e. 180 W)") - } - - if(lon.range[2] > 180){ - lon.range[2] <- 180 - warning("Setting largest longitude to 180 (i.e. 180 E)") - } - - if(lat.range[1] < -90){ - lat.range[1] <- -90 - warning("Setting lowest latitude to -90 (i.e. 90 S)") - } - - if(lat.range[2] > 90){ - lat.range[2] <- 90 - warning("Setting largest latitude to 90 (i.e. 90 N)") - } - - - ## BUILD GRID AND FROM/TO MATRIX ## - x.vec <- seq(lon.range[1], lon.range[2], length=n.lon) - y.vec <- seq(lat.range[2], lat.range[1], length=n.lat) - x <- rep(x.vec, each=n.lat) - y <- rep(y.vec, n.lon) - xy <- cbind(x,y) - colnames(xy) <- c("x","y") - - - ## lateral connections - from <- 1:(size-n.lat) - to <- n.lat + (1:(size-n.lat)) - - ## vertical connections - temp <- setdiff(1:(size-1), seq(n.lat, size, length=n.lon)) - from <- c(from, temp) - to <- c(to, temp+1) - ft <- cbind(from, to) - - ## CREATE graphNEL ## - myGraph <- ftM2graphNEL(ft, V=as.character(1:size), edgemode="undirected") - - - ## CREATE gGraph ## - res <- new("gGraph", coords=xy, graph=myGraph) - - return(res) - +makeGrid <- function(size = NULL, n.lon = NULL, n.lat = NULL, lon.range = NULL, lat.range = NULL) { + ## HANDLE ARGUMENTS ## + if (is.null(n.lon)) { + if (is.null(size)) stop("Please provide either size or n.lon/n.lat") + n.lon <- round(sqrt(size)) + } + + if (is.null(n.lat)) { + if (is.null(size)) stop("Please provide either size or n.lon/n.lat") + n.lat <- round(sqrt(size)) + } + + if (is.null(size)) { + if (is.null(n.lon) | is.null(n.lat)) stop("Please provide either size or n.lon/n.lat") + } + + size <- n.lon * n.lat + if (size < 4.1) { + size <- 4 + warning("Minimum grid size is 4 - ignoring required size.") + } + + + ## GET LON/LAT FROM ZOOM LOG ## + ## get zoom log info + # geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) + zoomLog <- get("zoom.log", envir = .geoGraphEnv) + if (nrow(zoomLog) < 1) { + curZoom <- c(-180, 180, -90, 90) + } else { + curZoom <- zoomLog[1, ] + } + + if (is.null(lon.range)) { + lon.range <- curZoom[1:2] + } + + if (is.null(lat.range)) { + lat.range <- curZoom[3:4] + } + + lon.range <- sort(lon.range) + lat.range <- sort(lat.range) + + + ## CORRECT LON/LAT ## + if (lon.range[1] < -180) { + lon.range[1] <- -180 + warning("Setting lowest longitude to -180 (i.e. 180 W)") + } + + if (lon.range[2] > 180) { + lon.range[2] <- 180 + warning("Setting largest longitude to 180 (i.e. 180 E)") + } + + if (lat.range[1] < -90) { + lat.range[1] <- -90 + warning("Setting lowest latitude to -90 (i.e. 90 S)") + } + + if (lat.range[2] > 90) { + lat.range[2] <- 90 + warning("Setting largest latitude to 90 (i.e. 90 N)") + } + + + ## BUILD GRID AND FROM/TO MATRIX ## + x.vec <- seq(lon.range[1], lon.range[2], length = n.lon) + y.vec <- seq(lat.range[2], lat.range[1], length = n.lat) + x <- rep(x.vec, each = n.lat) + y <- rep(y.vec, n.lon) + xy <- cbind(x, y) + colnames(xy) <- c("x", "y") + + + ## lateral connections + from <- 1:(size - n.lat) + to <- n.lat + (1:(size - n.lat)) + + ## vertical connections + temp <- setdiff(1:(size - 1), seq(n.lat, size, length = n.lon)) + from <- c(from, temp) + to <- c(to, temp + 1) + ft <- cbind(from, to) + + ## CREATE graphNEL ## + myGraph <- ftM2graphNEL(ft, V = as.character(1:size), edgemode = "undirected") + + + ## CREATE gGraph ## + res <- new("gGraph", coords = xy, graph = myGraph) + + return(res) } # end makeGrid diff --git a/R/plot.R b/R/plot.R index 34c25a5..dc9c5a2 100644 --- a/R/plot.R +++ b/R/plot.R @@ -68,32 +68,31 @@ #' #' #' ## just the background -#' plot(worldgraph.10k,reset=TRUE,type="n") +#' plot(worldgraph.10k, reset = TRUE, type = "n") #' #' ## basic plot #' plot(worldgraph.10k) #' #' ## zooming and adding edges -#' geo.zoomin(list(x=c(90,150),y=c(0,-50))) -#' plot(worldgraph.10k, edges=TRUE) +#' geo.zoomin(list(x = c(90, 150), y = c(0, -50))) +#' plot(worldgraph.10k, edges = TRUE) #' #' #' ## display edges differently -#' plotEdges(worldgraph.10k, col="red", lwd=2) +#' plotEdges(worldgraph.10k, col = "red", lwd = 2) #' #' #' ## replot points with different color -#' points(worldgraph.10k, col="orange") +#' points(worldgraph.10k, col = "orange") #' #' ## mask points in the sea -#' inSea <- unlist(getNodesAttr(worldgraph.10k,attr.name="habitat"))=="sea" +#' inSea <- unlist(getNodesAttr(worldgraph.10k, attr.name = "habitat")) == "sea" #' head(inSea) -#' points(worldgraph.10k[inSea], col="white", sticky=TRUE) # this will stay +#' points(worldgraph.10k[inSea], col = "white", sticky = TRUE) # this will stay #' #' ## but better, only draw those on land, and use a fancy setup -#' par(bg="blue") -#' plot(worldgraph.10k[!inSea], bg.col="darkgreen", col="purple", edges=TRUE) -#' +#' par(bg = "blue") +#' plot(worldgraph.10k[!inSea], bg.col = "darkgreen", col = "purple", edges = TRUE) #' NULL @@ -105,160 +104,163 @@ NULL ################### #' @export #' @import sp -setMethod("plot", signature(x = "gGraph", y="missing"), function(x, y,shape="world", psize=NULL, pch=19, col=NULL, - edges=FALSE, reset=FALSE, bg.col="gray", border.col="dark gray", - lwd=1, useCosts=NULL, maxLwd=3, col.rules=NULL,...){ - ## some checks - if(!is.gGraph(x)) stop("x is not a valid gGraph object") - - ## create the .geoGraphEnv if it does not exist - # if(!exists(".geoGraphEnv", envir=.GlobalEnv)) { - # assign(".geoGraphEnv", new.env(parent=.GlobalEnv), envir=.GlobalEnv) - # warning(".geoGraphEnv was not present, which may indicate a problem in loading geoGraph.") - # } - - #env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement - env <- .geoGraphEnv - - coords <- getCoords(x) - - - ## store original parameters to be passed to last.plot.param ## - pch.ori <- pch - col.ori <- col - - ## handle reset ## - if(reset){ - assign("sticky.points",FALSE,envir=.geoGraphEnv) - assign("last.points",expression(),envir=.geoGraphEnv) - } - - ## handle xlim and ylim - if((!exists("zoom.log", envir=.geoGraphEnv)) | reset) { # if xlim absent or if reset - temp <- c(range(coords[,1]), range(coords[,2])) - .zoomlog.up(temp) - } - - zoomlog <- get("zoom.log", envir=.geoGraphEnv) - zoomlog <- zoomlog[1,] - - xlim <- zoomlog[1:2] - ylim <- zoomlog[3:4] - - ## handle zoom and psize - if(is.null(psize)){ - psize <- get("psize", envir=.geoGraphEnv) - } - - ## handle color from attribute +setMethod("plot", signature(x = "gGraph", y = "missing"), function(x, y, shape = "world", psize = NULL, pch = 19, col = NULL, + edges = FALSE, reset = FALSE, bg.col = "gray", border.col = "dark gray", + lwd = 1, useCosts = NULL, maxLwd = 3, col.rules = NULL, ...) { + ## some checks + if (!is.gGraph(x)) stop("x is not a valid gGraph object") + + ## create the .geoGraphEnv if it does not exist + # if(!exists(".geoGraphEnv", envir=.GlobalEnv)) { + # assign(".geoGraphEnv", new.env(parent=.GlobalEnv), envir=.GlobalEnv) + # warning(".geoGraphEnv was not present, which may indicate a problem in loading geoGraph.") + # } + + # env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement + env <- .geoGraphEnv + + coords <- getCoords(x) + + + ## store original parameters to be passed to last.plot.param ## + pch.ori <- pch + col.ori <- col + + ## handle reset ## + if (reset) { + assign("sticky.points", FALSE, envir = .geoGraphEnv) + assign("last.points", expression(), envir = .geoGraphEnv) + } + + ## handle xlim and ylim + if ((!exists("zoom.log", envir = .geoGraphEnv)) | reset) { # if xlim absent or if reset + temp <- c(range(coords[, 1]), range(coords[, 2])) + .zoomlog.up(temp) + } + + zoomlog <- get("zoom.log", envir = .geoGraphEnv) + zoomlog <- zoomlog[1, ] + + xlim <- zoomlog[1:2] + ylim <- zoomlog[3:4] + + ## handle zoom and psize + if (is.null(psize)) { + psize <- get("psize", envir = .geoGraphEnv) + } + + ## handle color from attribute + useAttrCol <- FALSE + if (is.null(col.rules)) { + if (!is.null(x@meta$colors)) { + col.rules <- x@meta$colors + useAttrCol <- TRUE + } + } else { + useAttrCol <- TRUE + } + + if (!is.null(col)) { # col overrides rules useAttrCol <- FALSE - if(is.null(col.rules)){ - if(!is.null(x@meta$colors)){ - col.rules <- x@meta$colors - useAttrCol <- TRUE - } - } else { - useAttrCol <- TRUE - } - - if(!is.null(col)) { # col overrides rules - useAttrCol <- FALSE - } + } - toKeep <- isInArea(x, res.type="integer") - coords <- coords[toKeep, ] + toKeep <- isInArea(x, res.type = "integer") + coords <- coords[toKeep, ] - ## store previous last.points in envir (is erased by plotEdges) - if(exists("last.points", envir=.geoGraphEnv)){ - last.points <- get("last.points", envir=.geoGraphEnv) - } else { - last.points <- expression() - } + ## store previous last.points in envir (is erased by plotEdges) + if (exists("last.points", envir = .geoGraphEnv)) { + last.points <- get("last.points", envir = .geoGraphEnv) + } else { + last.points <- expression() + } - ## handle colors - if(useAttrCol){ - col <- getColors(x, nodes=toKeep, attr.name=colnames(col.rules)[1], col.rules=col.rules) - } else if(is.null(col.ori)){ - col <- "red" - } else{ - col <- rep(col.ori, length=length(getNodes(x))) - names(col) <- getNodes(x) - col <- col[toKeep] - } + ## handle colors + if (useAttrCol) { + col <- getColors(x, nodes = toKeep, attr.name = colnames(col.rules)[1], col.rules = col.rules) + } else if (is.null(col.ori)) { + col <- "red" + } else { + col <- rep(col.ori, length = length(getNodes(x))) + names(col) <- getNodes(x) + col <- col[toKeep] + } - ## handle shape - if(!is.null(shape) && is.character(shape) && shape=="world"){ - shape <- worldshape - } + ## handle shape + if (!is.null(shape) && is.character(shape) && shape == "world") { + shape <- worldshape + } - if(!is.null(shape)){ ## plot with background ## - if(!inherits(shape,"SpatialPolygonsDataFrame")) - stop("Shape must be a SpatialPolygonsDataFrame object \n(see readShapePoly in maptools to import such data from a GIS shapefile).") - - ## plot background - plot(shape, col=bg.col, border=border.col, xlim=xlim, ylim=ylim) - - ## subset of points in area - toKeep <- isInArea(x, reg="current", res.type="character") - coords <- getCoords(x)[toKeep, ] - - ## define colors for these points - if(useAttrCol){ - col <- getColors(x, nodes=toKeep, attr.name=colnames(col.rules)[1], col.rules=col.rules) - } else if(is.null(col.ori)){ - col <- "red" - } else{ - col <- rep(col.ori, length=length(getNodes(x))) - names(col) <- getNodes(x) - col <- col[toKeep] - } - - - if(edges){ - ## plotEdges(x, replot=FALSE, lwd=lwd, useCosts=useCosts, maxLwd=maxLwd) - plotEdges(x, lwd=lwd, useCosts=useCosts, maxLwd=maxLwd) - - } - points(coords, cex=psize, pch=pch, col=col, ...) - - } else{ ## plot only points ## - plot(coords, xlab="longitude", ylab="latitude", xlim=xlim, ylim=ylim, - cex=psize, pch=pch, col=col, ...) - if(edges){ - ## plotEdges(x, replot=TRUE, psize=psize, pch=pch, pcol=col, lwd=lwd, - ## useCosts=useCosts, maxLwd=maxLwd) - plotEdges(x, psize=psize, pch=pch, pcol=col, lwd=lwd, - useCosts=useCosts, maxLwd=maxLwd) - } + if (!is.null(shape)) { ## plot with background ## + if (!inherits(shape, "SpatialPolygonsDataFrame")) { + stop("Layer must be a SpatialPolygonsDataFrame object \n(see st_read and as_Spatial in sf to import such data from a GIS shapefile).") } + ## plot background + plot(shape, col = bg.col, border = border.col, xlim = xlim, ylim = ylim) - ## misc assignements in our dedicated environment - assign("usr", graphics::par("usr"), envir=.geoGraphEnv) - - curCall <- sys.call(-1) - assign("last.plot", curCall, envir=.geoGraphEnv) - temp <- get("last.plot.param", envir=.geoGraphEnv) - temp$psize <- psize - temp$pch <- pch.ori - temp$col <- col.ori - assign("last.plot.param", temp, envir=.geoGraphEnv) - - ## must re-assign the last call to points in envir. - assign("last.points", last.points, envir=.geoGraphEnv) - - ## add previously added points if needed ## - sticky.points <- get("sticky.points", envir=.geoGraphEnv) - if(sticky.points){ - temp <- get("last.points", envir=.geoGraphEnv) # this may be a list of calls - invisible(lapply(temp, eval)) - } + ## subset of points in area + toKeep <- isInArea(x, reg = "current", res.type = "character") + coords <- getCoords(x)[toKeep, ] - return(invisible()) + ## define colors for these points + if (useAttrCol) { + col <- getColors(x, nodes = toKeep, attr.name = colnames(col.rules)[1], col.rules = col.rules) + } else if (is.null(col.ori)) { + col <- "red" + } else { + col <- rep(col.ori, length = length(getNodes(x))) + names(col) <- getNodes(x) + col <- col[toKeep] + } + + + if (edges) { + ## plotEdges(x, replot=FALSE, lwd=lwd, useCosts=useCosts, maxLwd=maxLwd) + plotEdges(x, lwd = lwd, useCosts = useCosts, maxLwd = maxLwd) + } + points(coords, cex = psize, pch = pch, col = col, ...) + } else { ## plot only points ## + plot(coords, + xlab = "longitude", ylab = "latitude", xlim = xlim, ylim = ylim, + cex = psize, pch = pch, col = col, ... + ) + if (edges) { + ## plotEdges(x, replot=TRUE, psize=psize, pch=pch, pcol=col, lwd=lwd, + ## useCosts=useCosts, maxLwd=maxLwd) + plotEdges(x, + psize = psize, pch = pch, pcol = col, lwd = lwd, + useCosts = useCosts, maxLwd = maxLwd + ) + } + } + + + ## misc assignements in our dedicated environment + assign("usr", graphics::par("usr"), envir = .geoGraphEnv) + + curCall <- sys.call(-1) + assign("last.plot", curCall, envir = .geoGraphEnv) + temp <- get("last.plot.param", envir = .geoGraphEnv) + temp$psize <- psize + temp$pch <- pch.ori + temp$col <- col.ori + assign("last.plot.param", temp, envir = .geoGraphEnv) + + ## must re-assign the last call to points in envir. + assign("last.points", last.points, envir = .geoGraphEnv) + + ## add previously added points if needed ## + sticky.points <- get("sticky.points", envir = .geoGraphEnv) + if (sticky.points) { + temp <- get("last.points", envir = .geoGraphEnv) # this may be a list of calls + invisible(lapply(temp, eval)) + } + + return(invisible()) }) # end plot method @@ -270,114 +272,116 @@ setMethod("plot", signature(x = "gGraph", y="missing"), function(x, y,shape="wor ## points for gGraph ##################### #' @export -setMethod("points", signature("gGraph"), function(x, psize=NULL, pch=NULL, col=NULL, - edges=FALSE, lwd=1, useCosts=NULL, maxLwd=3, col.rules=NULL, - sticky.points=FALSE,...){ - ## some checks - if(!is.gGraph(x)) stop("x is not a valid gGraph object") +setMethod("points", signature("gGraph"), function(x, psize = NULL, pch = NULL, col = NULL, + edges = FALSE, lwd = 1, useCosts = NULL, maxLwd = 3, col.rules = NULL, + sticky.points = FALSE, ...) { + ## some checks + if (!is.gGraph(x)) stop("x is not a valid gGraph object") - ## create the .geoGraphEnv if it does not exist - # if(!exists(".geoGraphEnv", envir=.GlobalEnv)) { - # assign(".geoGraphEnv", new.env(parent=.GlobalEnv), envir=.GlobalEnv) - # warning(".geoGraphEnv was not present, which may indicate a problem in loading geoGraph.") - # } + ## create the .geoGraphEnv if it does not exist + # if(!exists(".geoGraphEnv", envir=.GlobalEnv)) { + # assign(".geoGraphEnv", new.env(parent=.GlobalEnv), envir=.GlobalEnv) + # warning(".geoGraphEnv was not present, which may indicate a problem in loading geoGraph.") + # } - #env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement + # env <- get(".geoGraphEnv", envir=.GlobalEnv) # env is our target environnement - zoomlog <- get("zoom.log", envir=.geoGraphEnv) - zoomlog <- zoomlog[1,] + zoomlog <- get("zoom.log", envir = .geoGraphEnv) + zoomlog <- zoomlog[1, ] - xlim <- zoomlog[1:2] - ylim <- zoomlog[3:4] + xlim <- zoomlog[1:2] + ylim <- zoomlog[3:4] - ## store original parameters to be passed to last.plot.param ## - pch.ori <- pch - col.ori <- col + ## store original parameters to be passed to last.plot.param ## + pch.ori <- pch + col.ori <- col - ## subset data to visible area ## - coords <- getCoords(x) - toKeep <- isInArea(x, reg="current", res.type="integer") - coords <- coords[toKeep, , drop=FALSE] + ## subset data to visible area ## + coords <- getCoords(x) + toKeep <- isInArea(x, reg = "current", res.type = "integer") + coords <- coords[toKeep, , drop = FALSE] - ## handle plot param - last.plot.param <- get("last.plot.param", envir=.geoGraphEnv) - if(is.null(psize)) psize <- last.plot.param$psize - if(is.null(pch)) pch <- last.plot.param$pch + ## handle plot param + last.plot.param <- get("last.plot.param", envir = .geoGraphEnv) + if (is.null(psize)) psize <- last.plot.param$psize + if (is.null(pch)) pch <- last.plot.param$pch - ## handle color from attribute - useAttrCol <- FALSE - if(is.null(col.rules)){ - if(!is.null(x@meta$colors)){ - col.rules <- x@meta$colors - useAttrCol <- TRUE - } - } else { - useAttrCol <- TRUE + ## handle color from attribute + useAttrCol <- FALSE + if (is.null(col.rules)) { + if (!is.null(x@meta$colors)) { + col.rules <- x@meta$colors + useAttrCol <- TRUE } + } else { + useAttrCol <- TRUE + } - if(!is.null(col)) { # col overrides rules - useAttrCol <- FALSE - } - - - ## handle color - if(useAttrCol){ - col <- getColors(x, nodes=toKeep, attr.name=colnames(col.rules)[1], col.rules=col.rules) - } else if(is.null(col.ori)){ - col <- "red" - } else{ - col <- rep(col.ori, length=length(getNodes(x))) - names(col) <- getNodes(x) - col <- col[toKeep] - } - - - ## define colors for these points - if(useAttrCol){ - col <- getColors(x, nodes=toKeep, attr.name=colnames(col.rules)[1], col.rules=col.rules) - } else if(is.null(col)){ - col <- "red" - } else{ - col <- rep(col, length=length(getNodes(x))) - names(col) <- getNodes(x) - col <- col[toKeep] - } # end handle color - - - ## handle zoom and psize - if(is.null(psize)){ - psize <- get("psize", envir=.geoGraphEnv) - } - - - ## add only points and optionally edges - if(edges){ - ## plotEdges(x, replot=FALSE, lwd=lwd, useCosts=useCosts, maxLwd=maxLwd) - plotEdges(x, lwd=lwd, useCosts=useCosts, maxLwd=maxLwd) + if (!is.null(col)) { # col overrides rules + useAttrCol <- FALSE + } + + + ## handle color + if (useAttrCol) { + col <- getColors(x, nodes = toKeep, attr.name = colnames(col.rules)[1], col.rules = col.rules) + } else if (is.null(col.ori)) { + col <- "red" + } else { + col <- rep(col.ori, length = length(getNodes(x))) + names(col) <- getNodes(x) + col <- col[toKeep] + } + + + ## define colors for these points + if (useAttrCol) { + col <- getColors(x, nodes = toKeep, attr.name = colnames(col.rules)[1], col.rules = col.rules) + } else if (is.null(col)) { + col <- "red" + } else { + col <- rep(col, length = length(getNodes(x))) + names(col) <- getNodes(x) + col <- col[toKeep] + } # end handle color + + + ## handle zoom and psize + if (is.null(psize)) { + psize <- get("psize", envir = .geoGraphEnv) + } + + + ## add only points and optionally edges + if (edges) { + ## plotEdges(x, replot=FALSE, lwd=lwd, useCosts=useCosts, maxLwd=maxLwd) + plotEdges(x, lwd = lwd, useCosts = useCosts, maxLwd = maxLwd) + } + points(coords, + xlab = "longitude", ylab = "latitude", xlim = xlim, ylim = ylim, + cex = psize, pch = pch, col = col, ... + ) + + + ## if sticky points are used, store info in env ## + if (sticky.points) { + curCall <- sys.call(-1) + temp <- get("last.points", envir = .geoGraphEnv) # might be a single expression or a list of expressions + if (!is.list(temp)) { + temp <- list(temp) # make sure it is a list } - points(coords, xlab="longitude", ylab="latitude", xlim=xlim, ylim=ylim, - cex=psize, pch=pch, col=col, ...) - - - ## if sticky points are used, store info in env ## - if(sticky.points) { - curCall <- sys.call(-1) - temp <- get("last.points", envir=.geoGraphEnv) # might be a single expression or a list of expressions - if(!is.list(temp)){ - temp <- list(temp) # make sure it is a list - } - ## do not add an existing expression ## - existExp <- any(sapply(temp, identical, curCall)) - if(!existExp){ - temp[[length(temp)+1]] <- curCall - assign("last.points", temp, envir=.geoGraphEnv) - } - assign("sticky.points", TRUE, envir=.geoGraphEnv) + ## do not add an existing expression ## + existExp <- any(sapply(temp, identical, curCall)) + if (!existExp) { + temp[[length(temp) + 1]] <- curCall + assign("last.points", temp, envir = .geoGraphEnv) } + assign("sticky.points", TRUE, envir = .geoGraphEnv) + } - return(invisible()) + return(invisible()) }) # end points method gGraph @@ -389,124 +393,125 @@ setMethod("points", signature("gGraph"), function(x, psize=NULL, pch=NULL, col=N ## plotEdges ############ #' @export -plotEdges <- function(x, useCosts=NULL, col="black", lwd=1, - lty=1, pch=NULL, psize=NULL, pcol=NULL, maxLwd=3, col.rules=NULL, - sticky.edges=FALSE,...){ - ## some checks - if(!is.gGraph(x)) stop("x is not a valid gGraph object.") - - ## handle weights for edges - if(is.null(useCosts)){ - useCosts <- hasCosts(x) - } - - ## get the environment - #env <- get(".geoGraphEnv", envir=.GlobalEnv) - - - if(exists("last.points", envir=.geoGraphEnv)){ - last.points <- get("last.points", envir=.geoGraphEnv) +plotEdges <- function(x, useCosts = NULL, col = "black", lwd = 1, + lty = 1, pch = NULL, psize = NULL, pcol = NULL, maxLwd = 3, col.rules = NULL, + sticky.edges = FALSE, ...) { + ## some checks + if (!is.gGraph(x)) stop("x is not a valid gGraph object.") + + ## handle weights for edges + if (is.null(useCosts)) { + useCosts <- hasCosts(x) + } + + ## get the environment + # env <- get(".geoGraphEnv", envir=.GlobalEnv) + + + if (exists("last.points", envir = .geoGraphEnv)) { + last.points <- get("last.points", envir = .geoGraphEnv) + } else { + last.points <- expression() + } + + ## handle plot param # ! discarded: now call last points + ## last.plot.param <- get("last.plot.param", envir=.geoGraphEnv) + ## if(is.null(psize)) psize <- last.plot.param$psize + ## if(is.null(pch)) pch <- last.plot.param$pch + ## if(is.null(pcol)) pcol <- last.plot.param$col + ## if(is.null(psize)){ + ## psize <- get("psize", envir=.geoGraphEnv) + ## } + + ## retained coords (those within plotting area) + coords <- getCoords(x) + toKeep <- isInArea(x, reg = "current", res.type = "integer") + keptCoords <- coords[toKeep, , drop = FALSE] + + ## adjust pcol to subset of points in area + + if (is.null(pcol)) { + ## handle color from attribute + useAttrCol <- FALSE + if (is.null(col.rules)) { + if (!is.null(x@meta$colors)) { + col.rules <- x@meta$colors + useAttrCol <- TRUE + } } else { - last.points <- expression() + useAttrCol <- TRUE } - ## handle plot param # ! discarded: now call last points - ## last.plot.param <- get("last.plot.param", envir=.geoGraphEnv) - ## if(is.null(psize)) psize <- last.plot.param$psize - ## if(is.null(pch)) pch <- last.plot.param$pch - ## if(is.null(pcol)) pcol <- last.plot.param$col - ## if(is.null(psize)){ - ## psize <- get("psize", envir=.geoGraphEnv) - ## } - - ## retained coords (those within plotting area) - coords <- getCoords(x) - toKeep <- isInArea(x, reg="current", res.type="integer") - keptCoords <- coords[toKeep, , drop=FALSE] - - ## adjust pcol to subset of points in area - - if(is.null(pcol)) { - ## handle color from attribute - useAttrCol <- FALSE - if(is.null(col.rules)){ - if(!is.null(x@meta$colors)){ - col.rules <- x@meta$colors - useAttrCol <- TRUE - } - } else { - useAttrCol <- TRUE - } - - if(!is.null(pcol)) { # pcol overrides color by attribute - useAttrCol <- FALSE - pcol <- pcol[toKeep] - } - - if(useAttrCol){ - if(is.null(col.rules)){ - col.rules <- colnames(x@meta$colors)[1] # default attribute used for colors - } - - pcol <- getColors(x, nodes=toKeep, attr.name=colnames(col.rules)[1], col.rules=col.rules) - - } else { - pcol <- "black" - } # end handle pcol + if (!is.null(pcol)) { # pcol overrides color by attribute + useAttrCol <- FALSE + pcol <- pcol[toKeep] } + if (useAttrCol) { + if (is.null(col.rules)) { + col.rules <- colnames(x@meta$colors)[1] # default attribute used for colors + } - edges <- getEdges(x, res.type="matNames", unique=TRUE) # retrieve (unique) edges - temp <- (edges[,1] %in% rownames(keptCoords)) & (edges[,2] %in% rownames(keptCoords)) - keptEdges <- edges[temp, ] + pcol <- getColors(x, nodes = toKeep, attr.name = colnames(col.rules)[1], col.rules = col.rules) + } else { + pcol <- "black" + } # end handle pcol + } - if(nrow(keptEdges) < 1) { - cat("\nNo edge to plot.\n") - return(invisible()) - } - ## handle costs - if(useCosts){ - edges.w <- getCosts(x, res.type="vector", unique=TRUE) - edges.w <- edges.w[temp] - lwd <- edges.w / max(edges.w) # max lwd = 1 - lwd <- 1 - lwd # invert scale (to have thiner edges for larger costs) - lwd <- lwd * maxLwd # max lwd = maxLwd - lty <- rep(1, length(lwd)) # make a lty vector - lty[lwd < 1e-5] <- 3 # assign 3 (doted line) to dead edges. - } - - ## plot segments - idx1 <- match(as.character(keptEdges[,1]), rownames(keptCoords)) - idx2 <- match(as.character(keptEdges[,2]), rownames(keptCoords)) - - graphics::segments(keptCoords[idx1, 1], keptCoords[idx1, 2], - keptCoords[idx2, 1], keptCoords[idx2, 2], col=col, lwd=lwd, lty=lty, ...) - - - ## replot points - ##points(keptCoords[,1], keptCoords[,2], pch=pch, cex=psize, col=pcol) - eval(last.points) - - - ## if sticky edges are used, store info in env ## - if(sticky.edges) { - ## curCall <- sys.call(-1) # does not work as plotEdges is not a S4 method - curCall <- match.call() - temp <- get("last.points", envir=.geoGraphEnv) # might be a single expression or a list of expressions - if(!is.list(temp)){ - temp <- list(temp) # make sure it is a list - } - ## do not add an existing expression ## - existExp <- any(sapply(temp, identical, curCall)) - if(!existExp){ - temp[[length(temp)+1]] <- curCall - assign("last.points", temp, envir=.geoGraphEnv) - } - assign("sticky.points", TRUE, envir=.geoGraphEnv) - } + edges <- getEdges(x, res.type = "matNames", unique = TRUE) # retrieve (unique) edges + temp <- (edges[, 1] %in% rownames(keptCoords)) & (edges[, 2] %in% rownames(keptCoords)) + keptEdges <- edges[temp, ] + if (nrow(keptEdges) < 1) { + cat("\nNo edge to plot.\n") return(invisible()) + } + + ## handle costs + if (useCosts) { + edges.w <- getCosts(x, res.type = "vector", unique = TRUE) + edges.w <- edges.w[temp] + lwd <- edges.w / max(edges.w) # max lwd = 1 + lwd <- 1 - lwd # invert scale (to have thiner edges for larger costs) + lwd <- lwd * maxLwd # max lwd = maxLwd + lty <- rep(1, length(lwd)) # make a lty vector + lty[lwd < 1e-5] <- 3 # assign 3 (doted line) to dead edges. + } + + ## plot segments + idx1 <- match(as.character(keptEdges[, 1]), rownames(keptCoords)) + idx2 <- match(as.character(keptEdges[, 2]), rownames(keptCoords)) + + graphics::segments(keptCoords[idx1, 1], keptCoords[idx1, 2], + keptCoords[idx2, 1], keptCoords[idx2, 2], + col = col, lwd = lwd, lty = lty, ... + ) + + + ## replot points + ## points(keptCoords[,1], keptCoords[,2], pch=pch, cex=psize, col=pcol) + eval(last.points) + + + ## if sticky edges are used, store info in env ## + if (sticky.edges) { + ## curCall <- sys.call(-1) # does not work as plotEdges is not a S4 method + curCall <- match.call() + temp <- get("last.points", envir = .geoGraphEnv) # might be a single expression or a list of expressions + if (!is.list(temp)) { + temp <- list(temp) # make sure it is a list + } + ## do not add an existing expression ## + existExp <- any(sapply(temp, identical, curCall)) + if (!existExp) { + temp[[length(temp) + 1]] <- curCall + assign("last.points", temp, envir = .geoGraphEnv) + } + assign("sticky.points", TRUE, envir = .geoGraphEnv) + } + + return(invisible()) } # end plotEdges @@ -568,104 +573,105 @@ plotEdges <- function(x, useCosts=NULL, col="black", lwd=1, #' @examples #' #' -#' myLoc <- list(x=c(3, -8, 11, 28), y=c(50, 57, 71, 67)) # some locations -#' obj <- new("gData", coords=myLoc) # new gData object +#' myLoc <- list(x = c(3, -8, 11, 28), y = c(50, 57, 71, 67)) # some locations +#' obj <- new("gData", coords = myLoc) # new gData object #' obj #' #' obj@gGraph.name <- "worldgraph.10k" -#' obj <- closestNode(obj, attr.name="habitat", attr.value="land") +#' obj <- closestNode(obj, attr.name = "habitat", attr.value = "land") #' #' ## plot the result (original location -> assigned node) -#' plot(obj, type="both",reset=TRUE) +#' plot(obj, type = "both", reset = TRUE) #' title("'x'=location, 'o'=assigned node") #' #' ## using different parameters -#' points(obj, type="both", pch.ori=2, col.ori="red", pch.nodes=20, col.nodes="pink") +#' points(obj, type = "both", pch.ori = 2, col.ori = "red", pch.nodes = 20, col.nodes = "pink") #' #' ## only nodes, fancy plot -#' plot(obj, col.nodes="red", cex=1, pch.node=20) -#' points(obj, col.nodes="red", cex=2) -#' points(obj, col.nodes="orange", cex=3) -#' points(obj, col.nodes="yellow", cex=4) -#' +#' plot(obj, col.nodes = "red", cex = 1, pch.node = 20) +#' points(obj, col.nodes = "red", cex = 2) +#' points(obj, col.nodes = "orange", cex = 3) +#' points(obj, col.nodes = "yellow", cex = 4) #' -setMethod("plot", signature(x="gData", y="missing"), function(x, type=c("nodes","original","both"), - pch.ori=4, pch.nodes=1, - col.ori="black", col.nodes="red", - col.gGraph=NULL, - reset=FALSE, sticky.points=TRUE,...){ - ## some checks - if(!is.gData(x)) stop("x is not a valid gData object") - type <- match.arg(type) - - ## get the environment -# env <- get(".geoGraphEnv", envir=.GlobalEnv) - env <- .geoGraphEnv - - if(!exists(x@gGraph.name, envir=.GlobalEnv)){ # if the gGraph is missing, stop - stop(paste("The gGraph object",x@gGraph.name,"is missing.")) - } - - myGraph <- get(x@gGraph.name, envir=.GlobalEnv) # get the gGraph object - - if((type %in% c("nodes","both")) & (length(x@nodes.id)==0)){ # no nodes assigned - stop("Locations are not assigned to nodes (x@nodes.id is empty).") - } - - - ## cleaning if required ## - if(reset){ - assign("sticky.points", FALSE, envir=.geoGraphEnv) # remove possible sticky points - assign("last.points", expression(), envir=.geoGraphEnv) # remove possible sticky points - } - - ## define visible area if reset ## - if((!exists("zoom.log", envir=.geoGraphEnv)) | reset){ - loc <- getCoords(x) - coords.nodes <- getCoords(myGraph)[x@nodes.id,, drop=FALSE] - temp <- rbind(loc, coords.nodes) - myRegion <- as.vector(apply(temp,2,range)) # return xmin, xmax, ymin, ymax - .zoomlog.up(myRegion) # define new window limits - } - - zoomlog <- get("zoom.log", envir=.geoGraphEnv) - zoomlog <- zoomlog[1,] - - xlim <- zoomlog[1:2] - ylim <- zoomlog[3:4] - - - ## plot the gGraph object ## - plot(myGraph, col=col.gGraph) - - - ## call to points ## - ## store previous last.points in envir (is erased by points) - if(exists("last.points", envir=.geoGraphEnv)){ - last.points <- get("last.points", envir=.geoGraphEnv) - } else { - last.points <- expression() - } - - points(x, type=type, - pch.ori=pch.ori, pch.nodes=pch.nodes,col.ori=col.ori, - col.nodes=col.nodes,sticky.points=sticky.points,...) - - - ## some assignments - curCall <- sys.call(-1) - assign("last.plot", curCall, envir=.geoGraphEnv) - ## must re-assign the last call to points in envir. - assign("last.points", last.points, envir=.geoGraphEnv) - - ## add previously added points if needed ## - sticky.points <- get("sticky.points", envir=.geoGraphEnv) - if(sticky.points){ - temp <- get("last.points", envir=.geoGraphEnv) # this may be a list of calls - invisible(lapply(temp, eval)) - } - - return(invisible()) +setMethod("plot", signature(x = "gData", y = "missing"), function(x, type = c("nodes", "original", "both"), + pch.ori = 4, pch.nodes = 1, + col.ori = "black", col.nodes = "red", + col.gGraph = NULL, + reset = FALSE, sticky.points = TRUE, ...) { + ## some checks + if (!is.gData(x)) stop("x is not a valid gData object") + type <- match.arg(type) + + ## get the environment + # env <- get(".geoGraphEnv", envir=.GlobalEnv) + env <- .geoGraphEnv + + if (!exists(x@gGraph.name, envir = .GlobalEnv)) { # if the gGraph is missing, stop + stop(paste("The gGraph object", x@gGraph.name, "is missing.")) + } + + myGraph <- get(x@gGraph.name, envir = .GlobalEnv) # get the gGraph object + + if ((type %in% c("nodes", "both")) & (length(x@nodes.id) == 0)) { # no nodes assigned + stop("Locations are not assigned to nodes (x@nodes.id is empty).") + } + + + ## cleaning if required ## + if (reset) { + assign("sticky.points", FALSE, envir = .geoGraphEnv) # remove possible sticky points + assign("last.points", expression(), envir = .geoGraphEnv) # remove possible sticky points + } + + ## define visible area if reset ## + if ((!exists("zoom.log", envir = .geoGraphEnv)) | reset) { + loc <- getCoords(x) + coords.nodes <- getCoords(myGraph)[x@nodes.id, , drop = FALSE] + temp <- rbind(loc, coords.nodes) + myRegion <- as.vector(apply(temp, 2, range)) # return xmin, xmax, ymin, ymax + .zoomlog.up(myRegion) # define new window limits + } + + zoomlog <- get("zoom.log", envir = .geoGraphEnv) + zoomlog <- zoomlog[1, ] + + xlim <- zoomlog[1:2] + ylim <- zoomlog[3:4] + + + ## plot the gGraph object ## + plot(myGraph, col = col.gGraph) + + + ## call to points ## + ## store previous last.points in envir (is erased by points) + if (exists("last.points", envir = .geoGraphEnv)) { + last.points <- get("last.points", envir = .geoGraphEnv) + } else { + last.points <- expression() + } + + points(x, + type = type, + pch.ori = pch.ori, pch.nodes = pch.nodes, col.ori = col.ori, + col.nodes = col.nodes, sticky.points = sticky.points, ... + ) + + + ## some assignments + curCall <- sys.call(-1) + assign("last.plot", curCall, envir = .geoGraphEnv) + ## must re-assign the last call to points in envir. + assign("last.points", last.points, envir = .geoGraphEnv) + + ## add previously added points if needed ## + sticky.points <- get("sticky.points", envir = .geoGraphEnv) + if (sticky.points) { + temp <- get("last.points", envir = .geoGraphEnv) # this may be a list of calls + invisible(lapply(temp, eval)) + } + + return(invisible()) }) # end plot method @@ -674,67 +680,66 @@ setMethod("plot", signature(x="gData", y="missing"), function(x, type=c("nodes", ##################### #' @export #' @describeIn plot-gData Plot as points -setMethod("points", signature(x = "gData"), function(x, type=c("nodes","original","both"), - pch.ori=4, pch.nodes=1, - col.ori="black", col.nodes="red", - sticky.points=TRUE,...){ - ## some checks - if(!is.gData(x)) stop("x is not a valid gData object") - type <- match.arg(type) - - ## get the environment - # env <- get(".geoGraphEnv", envir=.GlobalEnv) - - ## subset data to visible area ## - coords.ori <- getCoords(x) - if(type %in% c("nodes","both")){ # need to get coords of nodes - if(!exists(x@gGraph.name, envir=.GlobalEnv)){ # if the gGraph is missing, stop - stop(paste("The gGraph object",x@gGraph.name,"is missing.")) - } - - if(length(x@nodes.id)==0) { # if nodes have not been assigned, stop - stop("No nodes are assigned (@nodes.id empty); nothing to plot.") - } - - myGraph <- get(x@gGraph.name, envir=.GlobalEnv) - coords.nodes <- getCoords(myGraph)[x@nodes.id,, drop=FALSE] - ## toKeep <- isInArea(coords.nodes, reg="usr", res.type="integer") # useless, messy - ## coords.nodes <- coords.nodes[toKeep, , drop=FALSE] - } +setMethod("points", signature(x = "gData"), function(x, type = c("nodes", "original", "both"), + pch.ori = 4, pch.nodes = 1, + col.ori = "black", col.nodes = "red", + sticky.points = TRUE, ...) { + ## some checks + if (!is.gData(x)) stop("x is not a valid gData object") + type <- match.arg(type) - ## restrain coords to current area ## # no need for this - ## toKeep <- isInArea(coords.ori, reg="current", res.type="integer") - ## coords.ori <- coords.ori[toKeep, , drop=FALSE] + ## get the environment + # env <- get(".geoGraphEnv", envir=.GlobalEnv) - ## add points ## - if(type=="original" | type=="both"){ # plot original coordinates - points(coords.ori[,1], coords.ori[,2], pch=pch.ori, col=col.ori, ...) + ## subset data to visible area ## + coords.ori <- getCoords(x) + if (type %in% c("nodes", "both")) { # need to get coords of nodes + if (!exists(x@gGraph.name, envir = .GlobalEnv)) { # if the gGraph is missing, stop + stop(paste("The gGraph object", x@gGraph.name, "is missing.")) } - if(type=="nodes" | type=="both"){ # plot assigned nodes - points(coords.nodes[,1], coords.nodes[,2], pch=pch.nodes, col=col.nodes, ...) + if (length(x@nodes.id) == 0) { # if nodes have not been assigned, stop + stop("No nodes are assigned (@nodes.id empty); nothing to plot.") } - if(type=="both"){ # add arrows from original location to assigned node - graphics::arrows(coords.ori[,1], coords.ori[,2], coords.nodes[,1], coords.nodes[,2], angle=15, length=.1) - } + myGraph <- get(x@gGraph.name, envir = .GlobalEnv) + coords.nodes <- getCoords(myGraph)[x@nodes.id, , drop = FALSE] + ## toKeep <- isInArea(coords.nodes, reg="usr", res.type="integer") # useless, messy + ## coords.nodes <- coords.nodes[toKeep, , drop=FALSE] + } + + ## restrain coords to current area ## # no need for this + ## toKeep <- isInArea(coords.ori, reg="current", res.type="integer") + ## coords.ori <- coords.ori[toKeep, , drop=FALSE] + + ## add points ## + if (type == "original" | type == "both") { # plot original coordinates + points(coords.ori[, 1], coords.ori[, 2], pch = pch.ori, col = col.ori, ...) + } + + if (type == "nodes" | type == "both") { # plot assigned nodes + points(coords.nodes[, 1], coords.nodes[, 2], pch = pch.nodes, col = col.nodes, ...) + } - ## if sticky points are used, store info in env ## - if(sticky.points){ - curCall <- sys.call(-1) - temp <- get("last.points", envir=.geoGraphEnv) # might be a single expression or a list of expressions - if(!is.list(temp)){ - temp <- list(temp) # make sure it is a list - } - ## do not add an existing expression ## - existExp <- any(sapply(temp, identical, curCall)) - if(!existExp){ - temp[[length(temp)+1]] <- curCall - assign("last.points", temp, envir=.geoGraphEnv) - } - assign("sticky.points", TRUE, envir=.geoGraphEnv) + if (type == "both") { # add arrows from original location to assigned node + graphics::arrows(coords.ori[, 1], coords.ori[, 2], coords.nodes[, 1], coords.nodes[, 2], angle = 15, length = .1) + } + + ## if sticky points are used, store info in env ## + if (sticky.points) { + curCall <- sys.call(-1) + temp <- get("last.points", envir = .geoGraphEnv) # might be a single expression or a list of expressions + if (!is.list(temp)) { + temp <- list(temp) # make sure it is a list + } + ## do not add an existing expression ## + existExp <- any(sapply(temp, identical, curCall)) + if (!existExp) { + temp[[length(temp) + 1]] <- curCall + assign("last.points", temp, envir = .geoGraphEnv) } + assign("sticky.points", TRUE, envir = .geoGraphEnv) + } - return(invisible()) + return(invisible()) }) # end points for gData - diff --git a/R/setCosts.R b/R/setCosts.R index e94a647..320487d 100644 --- a/R/setCosts.R +++ b/R/setCosts.R @@ -40,70 +40,71 @@ #' @export #' @examples #' -#' plot(rawgraph.10k, reset=TRUE) +#' plot(rawgraph.10k, reset = TRUE) #' #' ## zooming in -#' geo.zoomin(list(x=c(-6,38), y=c(35,73))) +#' geo.zoomin(list(x = c(-6, 38), y = c(35, 73))) #' title("Europe") #' #' ## defining a new object restrained to visible nodes #' x <- rawgraph.10k[isInArea(rawgraph.10k)] #' #' ## define weights for edges -#' x <- setCosts(x, attr.name="habitat") -#' plot(x,edges=TRUE) +#' 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")){ - ## some checks + argument handling - if(!is.gGraph(x)) stop("x is not a valid gGraph object") - method <- match.arg(method) +setCosts <- function(x, attr.name = NULL, node.costs = NULL, method = c("mean", "product")) { + ## some checks + argument handling + if (!is.gGraph(x)) stop("x is not a valid gGraph object") + method <- match.arg(method) - ## 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.") + node.costs <- rep(node.costs, length = length(getNodes(x))) # recycling node costs + nodeCosts <- node.costs + ## might add some more checks here... + } - ## find costs of edges as a function of terminating vertices - EL <- getGraph(x)@edgeL + ## find costs of edges as a function of terminating vertices + EL <- getGraph(x)@edgeL - ## method == mean ## - if(method=="mean"){ - for(i in 1:length(EL)){ - EL[[i]]$weights <- (nodeCosts[i] + nodeCosts[EL[[i]]$edges]) / 2 - } + ## method == mean ## + if (method == "mean") { + for (i in 1:length(EL)) { + EL[[i]]$weights <- (nodeCosts[i] + nodeCosts[EL[[i]]$edges]) / 2 } + } - ## method == product ## - if(method=="product"){ - for(i in 1:length(EL)){ - EL[[i]]$weights <- nodeCosts[i] * nodeCosts[EL[[i]]$edges] - } + ## method == product ## + if (method == "product") { + for (i in 1:length(EL)) { + EL[[i]]$weights <- 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) + return(res) } # end setCosts diff --git a/R/setDistCosts.R b/R/setDistCosts.R index b893684..3e67b55 100644 --- a/R/setDistCosts.R +++ b/R/setDistCosts.R @@ -23,28 +23,27 @@ #' @keywords utilities methods #' @examples #' -#' if(require(fields)){ -#' ## load data -#' plot(rawgraph.10k,reset=TRUE) -#' geo.zoomin(list(x=c(110,150),y=c(-10,-40))) -#' plotEdges(rawgraph.10k) +#' if (require(fields)) { +#' ## load data +#' plot(rawgraph.10k, reset = TRUE) +#' geo.zoomin(list(x = c(110, 150), y = c(-10, -40))) +#' plotEdges(rawgraph.10k) #' -#' ## compute costs -#' x <- rawgraph.10k[isInArea(rawgraph.10k)] -#' x <- setDistCosts(x) +#' ## compute costs +#' x <- rawgraph.10k[isInArea(rawgraph.10k)] +#' x <- setDistCosts(x) #' -#' ## replot edges -#' plotEdges(x) # no big differences can be seen -#' head(getCosts(x)) +#' ## replot edges +#' plotEdges(x) # no big differences can be seen +#' head(getCosts(x)) #' } #' - ############ ## generic ############ #' @export -setGeneric("setDistCosts", function(x,...) { - standardGeneric("setDistCosts") +setGeneric("setDistCosts", function(x, ...) { + standardGeneric("setDistCosts") }) @@ -56,25 +55,24 @@ setGeneric("setDistCosts", function(x,...) { ################# #' @export #' @describeIn setDistCosts Method for gGraph object -setMethod("setDistCosts", "gGraph", function(x, ...){ - - ## some checks ## - if(!is.gGraph(x)) stop("x is not a valid gGraph object") +setMethod("setDistCosts", "gGraph", function(x, ...) { + ## some checks ## + if (!is.gGraph(x)) stop("x is not a valid gGraph object") - ## get edges and coords ## - E <- getEdges(x, res.type="matNames") + ## get edges and coords ## + E <- getEdges(x, res.type = "matNames") - xy <- getCoords(x) - xy1 <- xy[E[,1],] - xy2 <- xy[E[,2],] + xy <- getCoords(x) + xy1 <- xy[E[, 1], ] + xy2 <- xy[E[, 2], ] - ## get costs ## - w <- sapply(1:nrow(E), function(i) fields::rdist.earth(xy1[i,,drop=FALSE], xy2[i,,drop=FALSE])) # list of costs + ## get costs ## + w <- sapply(1:nrow(E), function(i) fields::rdist.earth(xy1[i, , drop = FALSE], xy2[i, , drop = FALSE])) # list of costs - ## assign costs to the graphNEL ## - edgeData(x@graph, from = E[,1], to = E[,2], attr = "weight") <- w + ## assign costs to the graphNEL ## + edgeData(x@graph, from = E[, 1], to = E[, 2], attr = "weight") <- w - return(x) + return(x) }) # end setDistCosts gGraph diff --git a/R/zoom.R b/R/zoom.R index 7e17d05..c56323a 100644 --- a/R/zoom.R +++ b/R/zoom.R @@ -41,16 +41,15 @@ #' @name zoom #' @examples #' -#' plot(worldgraph.10k, reset=TRUE) +#' plot(worldgraph.10k, reset = TRUE) #' #' ## zooming in -#' x.ini <- c(-100,-60) -#' y.ini <- c(-30,30) -#' for(i in 0:3){ -#' geo.zoomin(list(x=x.ini + i*60, y=y.ini)) +#' x.ini <- c(-100, -60) +#' y.ini <- c(-30, 30) +#' for (i in 0:3) { +#' geo.zoomin(list(x = x.ini + i * 60, y = y.ini)) #' } #' -#' #' \dontrun{ #' ## going back #' geo.back() # you have to click ! @@ -74,21 +73,21 @@ NULL ## .zoomlog.up ############### #' @export -.zoomlog.up <- function(vec){ # vec is xmin, xmax, ymin, ymax - if(!is.vector(vec) || length(vec)!=4 || !is.numeric(vec)) stop("Updating zoomlog using a wrong value.") +.zoomlog.up <- function(vec) { # vec is xmin, xmax, ymin, ymax + if (!is.vector(vec) || length(vec) != 4 || !is.numeric(vec)) stop("Updating zoomlog using a wrong value.") -# geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) - oldZoomLog <- get("zoom.log", envir=.geoGraphEnv) - newZoomLog <- rbind(vec, oldZoomLog) - colnames(newZoomLog) <- colnames(oldZoomLog) + # geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) + oldZoomLog <- get("zoom.log", envir = .geoGraphEnv) + newZoomLog <- rbind(vec, oldZoomLog) + colnames(newZoomLog) <- colnames(oldZoomLog) - if(nrow(newZoomLog) > 100){ - newZoomLog <- newZoomLog[1:100,] - } - assign("zoom.log", newZoomLog,envir=.geoGraphEnv) + if (nrow(newZoomLog) > 100) { + newZoomLog <- newZoomLog[1:100, ] + } + assign("zoom.log", newZoomLog, envir = .geoGraphEnv) - return(invisible()) + return(invisible()) } @@ -101,87 +100,84 @@ NULL #' @export -geo.zoomin <- function(reg=NULL){ # reg should be a list as returned by locator() - ## a few checks - if(is.list(reg)){ - names(reg) <- c("x", "y") - } - - if(is.numeric(reg) && length(reg)==4){ # is reg is a vector: x1, x2, y1, y2 - temp <- reg - reg <- list(x=temp[1:2], y=temp[3:4]) - } - - ## get environment - #geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) +geo.zoomin <- function(reg = NULL) { # reg should be a list as returned by locator() + ## a few checks + if (is.list(reg)) { + names(reg) <- c("x", "y") + } + if (is.numeric(reg) && length(reg) == 4) { # is reg is a vector: x1, x2, y1, y2 + temp <- reg + reg <- list(x = temp[1:2], y = temp[3:4]) + } - ## get last plot - last.plot.call <- get("last.plot", envir=.geoGraphEnv) - + ## get environment + # geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) - ## reg provided => no loop ## - if(!is.null(reg)){ - ## define new xlim and ylim - if(!is.list(reg) || length(reg)!=2) stop("Wrong reg specified.") - reg <- lapply(reg, sort) + ## get last plot + last.plot.call <- get("last.plot", envir = .geoGraphEnv) - ## make it a square - reg.size <- max(diff(reg[[1]]), diff(reg[[2]])) # largest edge of rectangle - reg.cen <- unlist(lapply(reg,mean)) # center of the rectangle - reg[[1]][1] <- reg.cen[1] - reg.size/2 # new x1 - reg[[1]][2] <- reg.cen[1] + reg.size/2 # new x2 - reg[[2]][1] <- reg.cen[2] - reg.size/2 # new y1 - reg[[2]][2] <- reg.cen[2] + reg.size/2 # new y2 - .zoomlog.up(c(reg$x, reg$y)) + ## reg provided => no loop ## + if (!is.null(reg)) { + ## define new xlim and ylim + if (!is.list(reg) || length(reg) != 2) stop("Wrong reg specified.") + reg <- lapply(reg, sort) - ## reconstruct a valid call to plot - temp <- deparse(last.plot.call) - temp <- sub("reset[^,]*,","",temp) # remove subset if provided - temp <- sub(",[[:blank:]]*reset[^)]*", "",temp) # same thing, if last arg + ## make it a square + reg.size <- max(diff(reg[[1]]), diff(reg[[2]])) # largest edge of rectangle + reg.cen <- unlist(lapply(reg, mean)) # center of the rectangle + reg[[1]][1] <- reg.cen[1] - reg.size / 2 # new x1 + reg[[1]][2] <- reg.cen[1] + reg.size / 2 # new x2 + reg[[2]][1] <- reg.cen[2] - reg.size / 2 # new y1 + reg[[2]][2] <- reg.cen[2] + reg.size / 2 # new y2 - ## temp <- sub("ylim[^,]*,","",temp) # idem, ylim - ## temp <- sub(")$","",temp) # idem, ylim - ## temp <- paste(temp, ", xlim = c(", reg$x[1], ",", reg$x[2],")") - ## temp <- paste(temp, ", ylim = c(", reg$y[1], ",", reg$y[2],")") - ## temp <- paste(temp, ")") + .zoomlog.up(c(reg$x, reg$y)) - newCall <- parse(text=temp) - eval(newCall, envir=.GlobalEnv) + ## reconstruct a valid call to plot + temp <- deparse(last.plot.call) + temp <- sub("reset[^,]*,", "", temp) # remove subset if provided + temp <- sub(",[[:blank:]]*reset[^)]*", "", temp) # same thing, if last arg - } else { ## reg not provided => looping ## + ## temp <- sub("ylim[^,]*,","",temp) # idem, ylim + ## temp <- sub(")$","",temp) # idem, ylim + ## temp <- paste(temp, ", xlim = c(", reg$x[1], ",", reg$x[2],")") + ## temp <- paste(temp, ", ylim = c(", reg$y[1], ",", reg$y[2],")") + ## temp <- paste(temp, ")") - reg <- data.frame(x=1:2,y=1:2) + newCall <- parse(text = temp) + eval(newCall, envir = .GlobalEnv) + } else { ## reg not provided => looping ## - ## getting input from the user - while(nrow(reg) > 1) { - reg <- reg[integer(0),] - reg <- data.frame(locator(2)) + reg <- data.frame(x = 1:2, y = 1:2) - if(nrow(reg) > 1) { - ## define new xlim and ylim - reg <- as.list(reg) - reg <- lapply(reg, sort) + ## getting input from the user + while (nrow(reg) > 1) { + reg <- reg[integer(0), ] + reg <- data.frame(locator(2)) - .zoomlog.up(c(reg$x, reg$y)) + if (nrow(reg) > 1) { + ## define new xlim and ylim + reg <- as.list(reg) + reg <- lapply(reg, sort) - ## reconstruct a valid call to plot - temp <- deparse(last.plot.call) - temp <- sub("res..[^,]*,","",temp) # remove 'reset' if provided - temp <- sub(",[[:blank:]]*res..[^)]*", "",temp) # same thing, if last arg + .zoomlog.up(c(reg$x, reg$y)) - newCall <- parse(text=temp) - eval(newCall, envir=.GlobalEnv) + ## reconstruct a valid call to plot + temp <- deparse(last.plot.call) + temp <- sub("res..[^,]*,", "", temp) # remove 'reset' if provided + temp <- sub(",[[:blank:]]*res..[^)]*", "", temp) # same thing, if last arg - reg <- data.frame(reg) - } # end if nrow(reg) > 1 + newCall <- parse(text = temp) + eval(newCall, envir = .GlobalEnv) - } # end while - } # end else + reg <- data.frame(reg) + } # end if nrow(reg) > 1 + } # end while + } # end else - return(invisible()) + return(invisible()) } # end geo.zoomin @@ -192,66 +188,66 @@ geo.zoomin <- function(reg=NULL){ # reg should be a list as returned by locator( ## geo.zoomout ############### #' @export -geo.zoomout <- function(){ - ## get environment - # geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) - - ## loop ## - while(!is.null(locator(1))){ - ## get last plot - last.plot.call <- get("last.plot", envir=.geoGraphEnv) - - ## get former coordinates and go one step back - zoomLog <- get("zoom.log", envir=.geoGraphEnv) - if(nrow(zoomLog) < 2) { - cat("\nNo previous zoom coordinates in zoom history.\n") - return(invisible()) - } - - ## find center of the current frame - size.x <- abs(diff(zoomLog[1,1:2])) - size.y <- abs(diff(zoomLog[1,3:4])) - - newReg <- zoomLog[1,,drop=TRUE] - newReg[1:2] <- newReg[1:2] + c(-size.x*0.5, size.x*0.5) # new region - newReg[3:4] <- newReg[3:4] + c(-size.y*0.5, size.y*0.5) # new region - - ## make sure we are not going to far - fullSize <- 0L - if(newReg[1] < -180) { - newReg[1] <- -180 - fullSize <- fullSize + 1L - } - if(newReg[2] > 180){ - newReg[2] <- 180 - fullSize <- fullSize + 1L - } - if(newReg[3] < -90){ - newReg[3] <- -90 - fullSize <- fullSize + 1L - } - if(newReg[4] > 90){ - newReg[4] <- 90 - fullSize <- fullSize + 1L - } - - if(fullSize==4){ - cat("\nFull area already displayed.\n") - return(invisible()) - } - - ## update zoom log - .zoomlog.up(newReg) +geo.zoomout <- function() { + ## get environment + # geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) - ## reconstruct a valid call to plot - temp <- deparse(last.plot.call) + ## loop ## + while (!is.null(locator(1))) { + ## get last plot + last.plot.call <- get("last.plot", envir = .geoGraphEnv) - newCall <- parse(text=temp) + ## get former coordinates and go one step back + zoomLog <- get("zoom.log", envir = .geoGraphEnv) + if (nrow(zoomLog) < 2) { + cat("\nNo previous zoom coordinates in zoom history.\n") + return(invisible()) + } + + ## find center of the current frame + size.x <- abs(diff(zoomLog[1, 1:2])) + size.y <- abs(diff(zoomLog[1, 3:4])) + + newReg <- zoomLog[1, , drop = TRUE] + newReg[1:2] <- newReg[1:2] + c(-size.x * 0.5, size.x * 0.5) # new region + newReg[3:4] <- newReg[3:4] + c(-size.y * 0.5, size.y * 0.5) # new region + + ## make sure we are not going to far + fullSize <- 0L + if (newReg[1] < -180) { + newReg[1] <- -180 + fullSize <- fullSize + 1L + } + if (newReg[2] > 180) { + newReg[2] <- 180 + fullSize <- fullSize + 1L + } + if (newReg[3] < -90) { + newReg[3] <- -90 + fullSize <- fullSize + 1L + } + if (newReg[4] > 90) { + newReg[4] <- 90 + fullSize <- fullSize + 1L + } - eval(newCall, envir=.GlobalEnv) + if (fullSize == 4) { + cat("\nFull area already displayed.\n") + return(invisible()) } - return(invisible()) + ## update zoom log + .zoomlog.up(newReg) + + ## reconstruct a valid call to plot + temp <- deparse(last.plot.call) + + newCall <- parse(text = temp) + + eval(newCall, envir = .GlobalEnv) + } + + return(invisible()) } # end geo.zoomout @@ -262,34 +258,34 @@ geo.zoomout <- function(){ ## geo.back ############ #' @export -geo.back <- function(){ - ## get environment - #geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) +geo.back <- function() { + ## get environment + # geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) - ## loop ## - while(!is.null(locator(1))){ - ## get last plot - last.plot.call <- get("last.plot", envir=.geoGraphEnv) + ## loop ## + while (!is.null(locator(1))) { + ## get last plot + last.plot.call <- get("last.plot", envir = .geoGraphEnv) - ## get former coordinates and go one step back - zoomLog <- get("zoom.log", envir=.geoGraphEnv) - if(nrow(zoomLog) < 2) { - cat("\nNo previous zoom coordinates in zoom history.\n") - return(invisible()) - } + ## get former coordinates and go one step back + zoomLog <- get("zoom.log", envir = .geoGraphEnv) + if (nrow(zoomLog) < 2) { + cat("\nNo previous zoom coordinates in zoom history.\n") + return(invisible()) + } - zoomLog <- zoomLog[-1,,drop=FALSE] - assign("zoom.log", zoomLog, envir=.geoGraphEnv) + zoomLog <- zoomLog[-1, , drop = FALSE] + assign("zoom.log", zoomLog, envir = .geoGraphEnv) - ## reconstruct a valid call to plot - temp <- deparse(last.plot.call) + ## reconstruct a valid call to plot + temp <- deparse(last.plot.call) - newCall <- parse(text=temp) + newCall <- parse(text = temp) - eval(newCall, envir=.GlobalEnv) - } + eval(newCall, envir = .GlobalEnv) + } - return(invisible()) + return(invisible()) } # end geo.back @@ -300,37 +296,37 @@ geo.back <- function(){ ## geo.slide ############# #' @export -geo.slide <- function(){ - ## get environment - #geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) +geo.slide <- function() { + ## get environment + # geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) - ## loop ## - while(!is.null(spoint <- locator(1))){ - ## get last plot - last.plot.call <- get("last.plot", envir=.geoGraphEnv) + ## loop ## + while (!is.null(spoint <- locator(1))) { + ## get last plot + last.plot.call <- get("last.plot", envir = .geoGraphEnv) - ## get former coordinates and go one step back - zoomLog <- get("zoom.log", envir=.geoGraphEnv) + ## get former coordinates and go one step back + zoomLog <- get("zoom.log", envir = .geoGraphEnv) - ## find center of the current frame - size.x <- abs(diff(zoomLog[1,1:2])) - size.y <- abs(diff(zoomLog[1,3:4])) + ## find center of the current frame + size.x <- abs(diff(zoomLog[1, 1:2])) + size.y <- abs(diff(zoomLog[1, 3:4])) - newReg <- zoomLog[1,,drop=TRUE] - newReg[c(1,3)] <- c(spoint$x - size.x/2, spoint$y - size.y/2) - newReg[c(2,4)] <- c(spoint$x + size.x/2, spoint$y + size.y/2) + newReg <- zoomLog[1, , drop = TRUE] + newReg[c(1, 3)] <- c(spoint$x - size.x / 2, spoint$y - size.y / 2) + newReg[c(2, 4)] <- c(spoint$x + size.x / 2, spoint$y + size.y / 2) - .zoomlog.up(newReg) + .zoomlog.up(newReg) - ## reconstruct a valid call to plot - temp <- deparse(last.plot.call) + ## reconstruct a valid call to plot + temp <- deparse(last.plot.call) - newCall <- parse(text=temp) + newCall <- parse(text = temp) - eval(newCall, envir=.GlobalEnv) - } + eval(newCall, envir = .GlobalEnv) + } - return(invisible()) + return(invisible()) } # end geo.slide @@ -342,35 +338,35 @@ geo.slide <- function(){ ## geo.bookmark ############ #' @export -geo.bookmark <- function(name=NULL){ - ## get environment - #geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) - - if(is.null(name)){ - cat("\nAvailable bookmarks:\n") - return(get("bookmarks", envir=.geoGraphEnv)) - } - - - ## get current zoom coords - zoomLog <- get("zoom.log", envir=.geoGraphEnv) - new.book <- zoomLog[1,] - - ## update bookmarks - bookmarks <- get("bookmarks", envir=.geoGraphEnv) - if(name %in% rownames(bookmarks)){ # erase previous bookmark if it exists - bookmarks[name,] <- new.book - warning("This bookmark already existed; removing previous bookmark.") - } else { - onames <- rownames(bookmarks) - bookmarks <- rbind(bookmarks,as.vector(new.book)) - rownames(bookmarks) <- c(onames, name) - cat("\nBookmark '", name, " 'saved.\n") - } - - assign("bookmarks", bookmarks, envir=.geoGraphEnv) - - return(invisible()) +geo.bookmark <- function(name = NULL) { + ## get environment + # geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) + + if (is.null(name)) { + cat("\nAvailable bookmarks:\n") + return(get("bookmarks", envir = .geoGraphEnv)) + } + + + ## get current zoom coords + zoomLog <- get("zoom.log", envir = .geoGraphEnv) + new.book <- zoomLog[1, ] + + ## update bookmarks + bookmarks <- get("bookmarks", envir = .geoGraphEnv) + if (name %in% rownames(bookmarks)) { # erase previous bookmark if it exists + bookmarks[name, ] <- new.book + warning("This bookmark already existed; removing previous bookmark.") + } else { + onames <- rownames(bookmarks) + bookmarks <- rbind(bookmarks, as.vector(new.book)) + rownames(bookmarks) <- c(onames, name) + cat("\nBookmark '", name, " 'saved.\n") + } + + assign("bookmarks", bookmarks, envir = .geoGraphEnv) + + return(invisible()) } # end geo.bookmark @@ -381,27 +377,27 @@ geo.bookmark <- function(name=NULL){ ## geo.goto ############ #' @export -geo.goto <- function(name){ - ## get environment - #geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) - - ## get next zoom coords - bookmarks <- get("bookmarks", envir=.geoGraphEnv) - zoomLog <- get("zoom.log", envir=.geoGraphEnv) - last.plot.call <- get("last.plot", envir=.geoGraphEnv) - - if(! name %in% rownames(bookmarks)) { - cat("\nUnknown bookmark\n") - return(geo.bookmark(NULL)) - } +geo.goto <- function(name) { + ## get environment + # geoEnv <- get(".geoGraphEnv", envir=.GlobalEnv) - zoomLog <- rbind(as.vector(bookmarks[name, ]), zoomLog) - assign("zoom.log", zoomLog, envir=.geoGraphEnv) + ## get next zoom coords + bookmarks <- get("bookmarks", envir = .geoGraphEnv) + zoomLog <- get("zoom.log", envir = .geoGraphEnv) + last.plot.call <- get("last.plot", envir = .geoGraphEnv) - ## reconstruct a valid call to plot - temp <- deparse(last.plot.call) - newCall <- parse(text=temp) - eval(newCall, envir=.GlobalEnv) + if (!name %in% rownames(bookmarks)) { + cat("\nUnknown bookmark\n") + return(geo.bookmark(NULL)) + } + + zoomLog <- rbind(as.vector(bookmarks[name, ]), zoomLog) + assign("zoom.log", zoomLog, envir = .geoGraphEnv) + + ## reconstruct a valid call to plot + temp <- deparse(last.plot.call) + newCall <- parse(text = temp) + eval(newCall, envir = .GlobalEnv) - return(invisible()) + return(invisible()) } # end geo.goto diff --git a/R/zzz.R b/R/zzz.R index 977c02a..290567f 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,32 +1,34 @@ -.onAttach <- function(libname, pkgname){ - pkg.version <- utils::packageDescription("geoGraph", fields = "Version") +.onAttach <- function(libname, pkgname) { + pkg.version <- utils::packageDescription("geoGraph", fields = "Version") - startup.txt <- paste("\n /// geoGraph ", pkg.version, " is loaded ////////////", - "\n\n > overview: '?geoGraph'", - "\n > tutorials/doc/questions: https://github.com/thibautjombart/geograph' \n", sep="") + startup.txt <- paste("\n /// geoGraph ", pkg.version, " is loaded ////////////", + "\n\n > overview: '?geoGraph'", + "\n > tutorials/doc/questions: https://github.com/thibautjombart/geograph' \n", + sep = "" + ) - packageStartupMessage(startup.txt) + packageStartupMessage(startup.txt) } # store local temporary variables in an environment whose parent is an empty environment # (which should be safe no matter where we are when we create it) -.geoGraphEnv <- new.env(parent=emptyenv()) +.geoGraphEnv <- new.env(parent = emptyenv()) ## declar temporary variables -zoom.log <- matrix(c(-180,180,-90,90),ncol=4) -colnames(zoom.log) <- c("x1","x2","y1","y2") -temp <- list(psize=0.5, pch=19, col="black") -bookmarks <- matrix(numeric(),ncol=4) -colnames(bookmarks) <- c("x1","x2","y1","y2") +zoom.log <- matrix(c(-180, 180, -90, 90), ncol = 4) +colnames(zoom.log) <- c("x1", "x2", "y1", "y2") +temp <- list(psize = 0.5, pch = 19, col = "black") +bookmarks <- matrix(numeric(), ncol = 4) +colnames(bookmarks) <- c("x1", "x2", "y1", "y2") ## assign them to the environment -assign("zoom.log", zoom.log, envir=.geoGraphEnv) -assign("psize", 0.5, envir=.geoGraphEnv) -assign("last.plot.param", temp, envir=.geoGraphEnv) -assign("sticky.points", FALSE, envir=.geoGraphEnv) -assign("bookmarks", bookmarks, envir=.geoGraphEnv) +assign("zoom.log", zoom.log, envir = .geoGraphEnv) +assign("psize", 0.5, envir = .geoGraphEnv) +assign("last.plot.param", temp, envir = .geoGraphEnv) +assign("sticky.points", FALSE, envir = .geoGraphEnv) +assign("bookmarks", bookmarks, envir = .geoGraphEnv) ## remove temp variables rm(zoom.log) diff --git a/README.Rmd b/README.Rmd deleted file mode 100644 index 0b7fd60..0000000 --- a/README.Rmd +++ /dev/null @@ -1,24 +0,0 @@ -[![Travis-CI Build Status](https://travis-ci.org/thibautjombart/geograph.svg?branch=master)](https://travis-ci.org/thibautjombart/geograph) - - - -```{r compileVignette, results="hide",echo=FALSE,message=FALSE} -## recompile vignette -setwd("vignettes") -knit("geograph.Rmd") -setwd("../") -``` - -```{r include, results="asis", echo=FALSE, warning=FALSE} -## read md of the vignette -mdInput <- readLines("vignettes/geograph.md") - -## remove vignette-specific headers -toRemove <- 1:10 -mdInput <- mdInput[-toRemove] - -## restore right path for figures -mdInput <- gsub("figs/","vignettes/figs/",mdInput) -cat(paste(mdInput,collapse="\n")) -``` - diff --git a/README.md b/README.md index 810f195..cd855c6 100644 --- a/README.md +++ b/README.md @@ -1,26 +1,19 @@ -[![Travis-CI Build Status](https://travis-ci.org/thibautjombart/geograph.svg?branch=master)](https://travis-ci.org/thibautjombart/geograph) +# geoGraph + +[![R-CMD-check](https://github.com/dramanica/geograph/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/dramanica/geograph/actions/workflows/R-CMD-check.yaml) + - - - -*geoGraph*: walking through the geographic space using graphs. -================================================= - - - -This document describes the *geoGraph* package for the R software. -*geoGraph* aims at implementing graph approaches for geographic data. -In *geoGraph*, a given geographic area is modelled by a fine regular grid, where each vertice +`geoGraph` aims at implementing graph approaches for geographic data. +In `geoGraph`, a given geographic area is modelled by a fine regular grid, where each vertice has a set of spatial coordinates and a set of attributes, which can be for instance habitat descriptors, or the presence/abundance of a given species. 'Travelling' within the geographic area can then be easily modelled as moving between connected vertices. The cost of moving from one vertex to another can be defined according to attribute values, which allows for instance to define friction routes based on habitat. - -*geoGraph* harnesses the full power of graph algorithms implemented in R by the *graph* +`geoGraph` harnesses the full power of graph algorithms implemented in R by the *graph* and *RBGL* (R Boost Graph Library) packages. In particular, RBGL is an interface between R and the comprehensive *Boost Graph Library* in C++, which provides fast and efficient implementations of a wide range of graph algorithms. @@ -29,1356 +22,21 @@ costs path from one location to another, or find the most parsimonious way of co Interfacing spatial data and graphs can be a complicated task. -The purpose of *geoGraph* is to provide tools to achieve and simplify this 'preliminary' step. +The purpose of `geoGraph` is to provide tools to achieve and simplify this 'preliminary' step. This is achieved by defining new classes of objects which are essentially geo-referenced graphs with node attributes (`gGraph` objects), and interfaced spatial data (`gData` objects). -In this vignette, we show how to install *geoGraph*, construct and handle -`gGraph`/`gData` objects, and illustrate some basic features of graph algorithms. - - - - - - -# First steps - - -## Installing the package -Installing *geoGraph* -------------- +## Installation -All the following instructions should be entered from a new R session to avoid errors due to installing attached packages. +You can install the development version of `geoGraph` from [GitHub](https://github.com/) with: -You may need to install manually the packages *graph* and *RBGL* from *Bioconductor* (try "http" if "https" is not available): -```r -source("https://bioconductor.org/biocLite.R") -biocLite("graph") -biocLite("RBGL") -``` - -*devtools* is also needed to install *geoGraph*: -```r +``` r install.packages("devtools") +devtools::install_github("thibautjombart/geoGraph") ``` +## How the package works -Then, to install *geoGraph*, simply type: -```r -library(devtools) -install_github("thibautjombart/geoGraph") -``` - -Once installed, the package can be loaded using: - -```r -library("geoGraph") -``` - -``` -## Loading required package: graph -## Loading required package: RBGL -## Loading required package: sp -## -## /// geoGraph 1.0-0 is loaded //////////// -## -## > overview: '?geoGraph' -## > tutorials/doc/questions: https://github.com/thibautjombart/geograph' -``` - - - - - -## Data representation - -Data representation refers to the way a given type of data is handled by a computer program. -Two types of objects are used in *geoGraph*: `gGraph`, and `gData` objects. -Both objects are defined as formal (S4) classes and often have methods for similar generic function -(e.g. `getNodes` is defined for both objects). -Essentially, `gGraph` objects contain underlying layers of informations, including a spatial -grid and possibly node attributes, and covering the area of interest. -`gData` are sets of locations (like sampled sites, for instance) which have been interfaced -to a `gGraph` object, to allow further manipulations such as finding paths on the grid between -pairs of locations. - - - - - -### gGraph objects - -The definition of the formal class `gGraph` can be obtained using: - -```r -getClass("gGraph") -``` - -``` -## Class "gGraph" [package "geoGraph"] -## -## Slots: -## -## Name: coords nodes.attr meta graph -## Class: matrix data.frame list graphNEL -``` -and a new empty object can be obtained using the constructor: - -```r -new("gGraph") -``` - -``` -## -## === gGraph object === -## -## @coords: spatial coordinates of 0 nodes -## lon lat -## -## @nodes.attr: 0 nodes attributes -## data frame with 0 columns and 0 rows -## -## @meta: list of meta information with 0 items -## -## @graph: -## A graphNEL graph with undirected edges -## Number of Nodes = 0 -## Number of Edges = 0 -``` - -The documentation `?gGraph` explains the basics about the object's content. -In a nutshell, these objects are spatial grids with nodes and segments connecting neighbouring -nodes, and additional informations on the nodes or on the graph itself. -`coords` is a matrix of longitudes and latitudes of the nodes. -`nodes.attr` is a data.frame storing attributes of the nodes, such as habitat descriptors; each -row corresponds to a node of the grid, while each column corresponds to a variable. -`meta` is a list containing miscellanous informations about the graph itself. -There is no contraint applying to the components of the list, but some typical components such as -`$costs` or `$colors` will be recognised by certain functions. -For instance, you can specify plotting rules for representing a given node attribute by a given -color by defining a component `$colors`. -Similarly, you can associate costs to a given node attribute by defining a component `$costs`. -An example of this can be found in already existing `gGraph` objects. -For instance, `worldgraph.10k` is a graph of the world with approximately 10,000 nodes, and -only on-land connectivity (\textit{i.e.` no travelling on the seas). - -```r -worldgraph.10k -``` - -``` -## -## === gGraph object === -## -## @coords: spatial coordinates of 10242 nodes -## lon lat -## 1 -180.00 90.00 -## 2 144.00 -90.00 -## 3 -33.78 27.19 -## ... -## -## @nodes.attr: 1 nodes attributes -## habitat -## 1 sea -## 2 sea -## 3 sea -## ... -## -## @meta: list of meta information with 2 items -## [1] "$colors" "$costs" -## -## @graph: -## A graphNEL graph with undirected edges -## Number of Nodes = 10242 -## Number of Edges = 6954 -``` - -```r -worldgraph.10k@meta -``` - -``` -## $colors -## habitat color -## 1 sea blue -## 2 land green -## 3 mountain brown -## 4 landbridge light green -## 5 oceanic crossing light blue -## 6 deselected land lightgray -## -## $costs -## habitat cost -## 1 sea 100 -## 2 land 1 -## 3 mountain 10 -## 4 landbridge 5 -## 5 oceanic crossing 20 -## 6 deselected land 100 -``` -Lastly, the `graph` component is a `graphNEL` object, which is the standard class for -graphs in the *graph* and *RBGL* packages. -This object contains all information on the connections between nodes, and the weights (costs) of -these connections. - - -Four main `gGraph` are provided with *geoGraph*: `rawgraph.10k`, `rawgraph.40k`, -`worldgraph.10k`, and `worldgraph.40k`. -These datasets are available using the command `data`. -The grid used in these datasets are the best geometric approximation of a regular grid for the surface of a sphere. -One advantage of working with these grids is that we do not have to use a projection for geographic -coordinates, which is a usual issue in regular GIS. - -The difference between rawgraphs and worldgraphs is that the first are entirely connected, while in the -second connections occur only on land. -Numbers `10k' and `40k' indicate that the grids consist of roughly 10,000 and 40,000 nodes. -For illustrative purposes, we will often use the 10k grids, since they are less heavy to handle. -For most large-scale applications, the 40k versions should provide sufficient resolution. -New `gGraph` can be constructed using the constructor (`new(...)`), but this topic is not -documented in this vignette. - - - - - -### gData objects - -`gData` are essentially sets of locations that are interfaced with a `gGraph` object. -During this operation, each location is assigned to the closest node on the grid of the -`gGraph`, then allowing for travelling between locations using the grid. -Then, it is for instance possible to find the shortest path between two locations through various -types of habitats. - - -Like for `gGraph`, the content of the formal class `gData` can be obtained using: - -```r -getClass("gData") -``` - -``` -## Class "gData" [package "geoGraph"] -## -## Slots: -## -## Name: coords nodes.id data gGraph.name -## Class: matrix character ANY character -``` -and a new empty object can be obtained using the constructor: - -```r -new("gData") -``` - -``` -## -## === gData object === -## -## @coords: spatial coordinates of 0 nodes -## lon lat -## -## @nodes.id: nodes identifiers -## character(0) -## -## @data: data -## NULL -## -## Associated gGraph: -``` -As before, the description of the content of these objects can be found in the documentation (`?gData`). -`coords` is a matrix of xy (longitude/latitude) coordinates in which each row is a location. -`nodes.id` is vector of characters giving the name of the vertices matching the locations; this is -defined automatically when creating a new `gData`, or using the function `closestNode`. -`data` is a slot storing data associated to the locations; it can be any type of object, but a data.frame -should cover most requirements for storing data. -Note that this object should be subsettable (i.e. the `[` operator should be defined), so that data can be subsetted when subsetting the `gData` object. -Lastly, the slot `gGraph.name` contains the name of the `gGraph` object to which the -`gData` has been interfaced. - - - -Contrary to `gGraph` objects, `gData` objects will frequently be constructed by the user. -In the next sections, we illustrate how we can build and use `gData` objects from a set -of locations. - - - - - - - - - -# Using *geoGraph* - - -An overview of the material implemented in the package is summarized the package's manpage, accessible -via: - -```r -?geoGraph -``` -The html version of this manpage may be preferred to browse more easily the content -of *geoGraph*; it is accessible by typing: - -```r -help("geoGraph", package="geoGraph", html=TRUE) -``` -To revert help back to text mode, simply type: - -```r -options(htmlhelp = FALSE) -``` - -In the following, we go through various tasks that can be achieve using *geoGraph*. - - - - - - - - -## Importing geographic data - -GeoGraphic data consist of a set of locations, possibly accompanied by additional information. -For instance, one may want to study the migrations amongst a set of biological populations with known -geographic coordinates. -In *geoGraph*, geographic data are stored in `gData` objects. -These objects match locations to the closest nodes on a grid (a `gGraph` object), and store -additional data if needed. - - - -As a toy example, let us consider four locations: Bordeaux (France), London (UK), Malaga (Spain), and Zagreb (Croatia). -Since we will be working with a crude grid (10,000 nodes), locations need not be exact. -We enter the longitudes and latitudes (in this order, that is, xy coordinates) of these cities in -decimal degrees, as well as approximate population sizes: - -```r -Bordeaux <- c(-1,45) -London <- c(0,51) -Malaga <- c(-4,37) -Zagreb <- c(16,46) -cities.dat <- rbind.data.frame(Bordeaux, London, Malaga, Zagreb) -colnames(cities.dat) <- c("lon","lat") -cities.dat$pop <- c(1e6, 13e6, 5e5, 1.2e6) -row.names(cities.dat) <- c("Bordeaux","London","Malaga","Zagreb") -cities.dat -``` - -``` -## lon lat pop -## Bordeaux -1 45 1.0e+06 -## London 0 51 1.3e+07 -## Malaga -4 37 5.0e+05 -## Zagreb 16 46 1.2e+06 -``` -We load a `gGraph` object which contains the grid that will support the data: - -```r -worldgraph.10k -``` - -``` -## -## === gGraph object === -## -## @coords: spatial coordinates of 10242 nodes -## lon lat -## 1 -180.00 90.00 -## 2 144.00 -90.00 -## 3 -33.78 27.19 -## ... -## -## @nodes.attr: 1 nodes attributes -## habitat -## 1 sea -## 2 sea -## 3 sea -## ... -## -## @meta: list of meta information with 2 items -## [1] "$colors" "$costs" -## -## @graph: -## A graphNEL graph with undirected edges -## Number of Nodes = 10242 -## Number of Edges = 6954 -``` - -```r -plot(worldgraph.10k) -``` - -![plot of chunk wg10plot](vignettes/figs/wg10plot-1.png) - - (we could use `worldgraph.40k` for a better resolution). -In this figure, each node is represented with a color depending on the habitat type, either 'sea' -(blue) or 'land' (green). -We are going to interface the cities data with this grid; to do so, we create a `gData` object using -`new` (see `?gData` object): - -```r -cities <- new("gData", coords=cities.dat[,1:2], data=cities.dat[,3,drop=FALSE], gGraph.name="worldgraph.10k") -cities -``` - -``` -## -## === gData object === -## -## @coords: spatial coordinates of 4 nodes -## lon lat -## 1 -1 45 -## 2 0 51 -## 3 -4 37 -## ... -## -## @nodes.id: nodes identifiers -## 1 2 3 -## "5774" "6413" "4815" -## ... -## -## @data: 4 data -## pop -## Bordeaux 1.0e+06 -## London 1.3e+07 -## Malaga 5.0e+05 -## ... -## -## Associated gGraph: worldgraph.10k -``` - -```r -plot(cities, type="both", reset=TRUE) -plotEdges(worldgraph.10k) -``` - -![plot of chunk citiesplot](vignettes/figs/citiesplot-1.png) - - This figure illustrates the matching of original locations (black crosses) to nodes of the grid -(red circles). -As we can see, an issue occured for Bordeaux, which has been assigned to a node in the sea (in blue). -Locations can be re-assigned to nodes with restrictions for some node attribute values using -`closestNode`; for instance, here we constrain matching nodes to have an `habitat` value -(defined as node attribute in `worldgraph.10k`) equalling `land` (green points): - -```r -cities <- closestNode(cities, attr.name="habitat", attr.value="land") -plot(cities, type="both", reset=TRUE) -plotEdges(worldgraph.10k) -``` - -![plot of chunk closeNode](vignettes/figs/closeNode-1.png) - - Now, all cities have been assigned to a `land' node of the grid (again, better accuracy will be -gained on 40k or finer grids - we use 10k for illustrative purposes only). -Content of `cities` can be accessed via various accessors (see `?gData`). -For instance, we can retrieve original locations, assigned nodes, and stored data using: - -```r -getCoords(cities) -``` - -``` -## lon lat -## 5775 -1 45 -## 6413 0 51 -## 4815 -4 37 -## 7699 16 46 -``` - -```r -getNodes(cities) -``` - -``` -## 5774 6413 4815 7699 -## "5775" "6413" "4815" "7699" -``` - -```r -getData(cities) -``` - -``` -## pop -## Bordeaux 1.0e+06 -## London 1.3e+07 -## Malaga 5.0e+05 -## Zagreb 1.2e+06 -``` -We can also get the coordinates of the matching nodes (\textit{i.e.}, red circle on previous figure) using: - -```r -getCoords(cities, original=FALSE) -``` - -``` -## lon lat -## 5775 1.002e-05 43.73 -## 6413 1.002e-05 51.38 -## 4815 -3.788e+00 37.75 -## 7699 1.548e+01 46.74 -``` -More interestingly, we can now retrieve all the geographic information contained in the underlying -grid (\textit{i.e.}, `gGraph` object) as node attributes: - -```r -getNodesAttr(cities) -``` - -``` -## habitat -## 5775 land -## 6413 land -## 4815 land -## 7699 land -``` -In this example, the information stored in `worldgraph.10k` is rather crude: `habitat` only -distinguishes the land from the sea. -However, more complex habitat information could be incorporated, for instance from GIS shapefiles -(see dedicated section below). - - - - - - - - -## Visualizing data - -An essential aspect of spatial analysis lies in visualizing the data. -In *geoGraph*, the spatial grids (`gGraph`) and spatial data (`gData`) can be plotted -and browsed using a variety of functions. - - - - -### Plotting `gGraph` objects - -Displaying a `gGraph` object is done through `plot` and `points` functions. -The first opens a new plotting region, while the second draws in the current plotting region; -functions have otherwise similar arguments (see `?plot.gGraph`). - -By default, plotting a `gGraph` displays the grid of nodes overlaying a shapefile (by default, -the landmasses). -Edges can be plotted at the same time (argument `edges`), or added afterwards using `plotEdges`. -If the `gGraph` object possesses an adequately formed `meta$colors` component, the -colors of the nodes are chosen according to the node attributes and the color scheme specified in `meta$colors`. -Alternatively, the color of the nodes can be specified via the `col` argument in `plot`/`points`. - -Here is an example using `worldgraph.10k`: - -```r -worldgraph.10k@meta$colors -``` - -``` -## habitat color -## 1 sea blue -## 2 land green -## 3 mountain brown -## 4 landbridge light green -## 5 oceanic crossing light blue -## 6 deselected land lightgray -``` - -```r -head(getNodesAttr(worldgraph.10k)) -``` - -``` -## habitat -## 1 sea -## 2 sea -## 3 sea -## 4 sea -## 5 sea -## 6 sea -``` - -```r -table(getNodesAttr(worldgraph.10k)) -``` - -``` -## -## deselected land land sea -## 290 2632 7320 -``` - -```r -plot(worldgraph.10k, reset=TRUE) -title("Default plotting of worldgraph.10k") -``` - -![plot of chunk wg10kdefplot](vignettes/figs/wg10kdefplot-1.png) - - It may be worth noting that plotting `gGraph` objects involves plotting a fairly -large number of points and edges. -On some graphical devices, the resulting plotting can be slow. -For instance, one may want to disable `cairo` under linux: this graphical device yields better -graphics than `Xlib`, but at the expense of increase computational time. -To switch to `Xlib`, type: - -```r -X11.options(type="Xlib") -``` -and to revert to `cairo`, type: - -```r -X11.options(type="cairo") -``` - - - - -### Zooming in and out, sliding, etc. - -In practice, it is often useful to be able to peer at specific regions, and more generally to -navigate inside the graphical representation of the data. -For this, we can use the interactive functions `geo.zoomin`, `geo.zoomout`, `geo.slide`, -`geo.back`, `geo.bookmark`, and `geo.goto`. -The zoom and slide functions require to left-click on the graphics to zoom in, zoom out, or slide to -adjacent areas; in all cases, a right click ends the function. -Also note that `geo.zoomin` can accept an argument specifying a rectangular region, which will -be adapted by the function to fit best a square area with similar position and centre, and zoom to -this area (see `?geo.zoomin`). -`geo.bookmark` and `geo.goto` respectively set and go to a bookmark, *i.e.* a tagged area. -This is most useful when one has to switch between distant areas repeatedly. - - -Here are some examples based on the previous plotting of `worldgraph.10k`: -Zooming in: - -```r -geo.zoomin() -``` -![img](vignettes/figs/zoomin.png) - - Zooming out: - -```r -geo.zoomout() -``` -![img](vignettes/figs/zoomout.png) - - Sliding to the east: - -```r -geo.slide() -``` -![img](vignettes/figs/slide.png) - - -One important thing which makes plotting `gGraph` objects different from most other plotting in -R is that `geoGraph` keeps the changes made to the plotting area in memory. -This allows to undo one or several moves using `geo.back`. -Moreover, even if the graphical device is killed, plotting again a `gGraph` will use the old -parameters by default. -To disable this behavior, set the argument `reset=TRUE` when calling upon `plot`. -Technically, this 'plotting memory' is implemented by storing plotting information in an environment -defined as the hidden variable `.geoGraphEnv`: - -```r -.geoGraphEnv -``` - -``` -## -``` - -```r -ls(env=.geoGraphEnv) -``` - -``` -## [1] "bookmarks" "last.plot" "last.plot.param" "last.points" -## [5] "psize" "sticky.points" "usr" "zoom.log" -``` - -```r -get("last.plot", .geoGraphEnv) -``` - -``` -## plot(worldgraph.10k, reset = TRUE) -``` -It is recommended not to modify these objects directly, unless you really know what you are doing. -In any case, plotting a `gGraph` object with argument `reset=TRUE` will remove previous -plotting history and undo possible wrong manipulations. - - - - - -### Plotting `gData` objects - -`gData` objects are by default plotted overlaying the corresponding `gGraph`. -For instance, using the `cities` example from above: - -```r -plot(cities, reset=TRUE) -text(getCoords(cities), rownames(getData(cities))) -``` - -![plot of chunk citiesPlot2](vignettes/figs/citiesPlot2-1.png) - - Note the argument `reset=TRUE`, which tells the plotting function to adapt the -plotting area to the geographic extent of the dataset. - - -To plot additional information, it can be useful to extract the spatial coordinates from the data. -This is achieved by `getCoords`. -This method takes an extra argument `original`, which is TRUE if original spatial coordinates -are seeked, or FALSE for coordinates of the nodes on the grid. -We can use this to represent, for instance, the population sizes for the different cities: - -```r -transp <- function(col, alpha=.5){ - res <- apply(col2rgb(col),2, function(c) rgb(c[1]/255, c[2]/255, c[3]/255, alpha)) - return(res) -} - - -plot(cities, reset=TRUE) -par(xpd=TRUE) -text(getCoords(cities)+-.5, rownames(getData(cities))) -symbols(getCoords(cities)[,1], getCoords(cities)[,2], circ=sqrt(unlist(getData(cities))), inch=.2, bg=transp("red"), add=TRUE) -``` - -![plot of chunk unnamed-chunk-18](vignettes/figs/unnamed-chunk-18-1.png) - - - - - - - -## Editing `gGraphs` - -Editing graphs is an essential task in *geoGraph*. -While available `gGraph` objects provide a basis to work with (see `?worldgraph.10k`), -one may want to adapt a graph to a specific case. -For instance, connectivity should be defined according to biological knowledge of the organism under study. -`gGraph` can be modified in different ways: by changing the connectivity, the costs of -edges, or the attribute values. - - - - -### Changing the global connectivity of a `gGraph` - - -There are two main ways of changing the connectivity of a `gGraph`, which match two different objectives. -The first approach is to perform global and systematic changes of the connectivity of the graph. -Typically, one will want to remove all connections over a given type of landscape, which is -uncrossable by the organism under study. -Let's assume we are interested in saltwater fishes. -To model fish dispersal, we have to define a graph which connects only nodes overlaying the sea. -We load the `gGraph` object `rawgraph.10k`, and zoom in to a smaller area (Madagascar) to illustrate -changes in connectivity: - -```r -geo.zoomin(c(35,54,-26,-10)) -plotEdges(rawgraph.10k) -``` - -![plot of chunk unnamed-chunk-19](vignettes/figs/unnamed-chunk-19-1.png) - - We shall set a bookmark for this area, in case we would want to get back to this place -later on: - -```r -geo.bookmark("madagascar") -``` - -``` -## -## Bookmark ' madagascar 'saved. -``` -What we now want to do is remove all but sea-sea connections. -To do so, the easiest approach is to i) define costs for the edges based on habitat, with land being -given large costs and ii) remove all edges with large costs. - - -Costs of a given node attribute (here, `habitat') are indicated in the `meta$costs` slot: - -```r -rawgraph.10k@meta$costs -``` - -``` -## habitat cost -## 1 sea 100 -## 2 land 1 -## 3 mountain 10 -## 4 landbridge 5 -## 5 oceanic crossing 20 -## 6 deselected land 100 -``` - -```r -newGraph <- rawgraph.10k -newGraph@meta$costs[2:6,2] <- 100 -newGraph@meta$costs[1,2] <- 1 -newGraph@meta$costs -``` - -``` -## habitat cost -## 1 sea 1 -## 2 land 100 -## 3 mountain 100 -## 4 landbridge 100 -## 5 oceanic crossing 100 -## 6 deselected land 100 -``` -We have just changed the costs associated to habitat type, but this change is not yet effective on -edges between nodes. -We use `setCosts` to set the cost of an edge to the average of the costs of its nodes: - -```r -newGraph <- setCosts(newGraph, attr.name="habitat") -plot(newGraph,edge=TRUE) -``` - -![plot of chunk unnamed-chunk-22](vignettes/figs/unnamed-chunk-22-1.png) - -On this new graph, we represent the edges with a width inversely proportional to the associated -cost; that is, bold lines for easy travelling and light edges/dotted lines for more costly mouvement. -This is not enough yet, since travelling on land is still possible. -However, we can tell *geoGraph* to remove all edges associated to too strong a cost, as defined -by a given threshold (using `dropDeadEdges`). -Here, only sea-sea connections shall be retained, that is, edges with cost 1. - -```r -newGraph <- dropDeadEdges(newGraph, thres=1.1) -plot(newGraph,edge=TRUE) -``` - -![plot of chunk unnamed-chunk-23](vignettes/figs/unnamed-chunk-23-1.png) - -Here we are: `newGraph` only contains connections in the sea. -Note that, although we restrained the plotting area to Madagascar, this change is effective everywhere. -For instance, travelling to the nort-west Australian coasts: - -```r -geo.zoomin(c(110,130,-27,-12)) -``` - -![plot of chunk unnamed-chunk-24](vignettes/figs/unnamed-chunk-24-1.png) - -```r -geo.bookmark("australia") -``` - -``` -## -## Bookmark ' australia 'saved. -``` - - - - - -### Changing local properties of a `gGraph` - -A second approach to changing a `gGraph` is to refine the graph by hand, adding or removing -locally some connections, or altering the attributes of some nodes. -This can be necessary to connect components such as islands to the main landmasses, or to correct -erroneous data. -Adding and removing edges from the grid of a `gGraph` can be achieved by `geo.add.edges` -and `geo.remove.edges`, respectively. -These functions are interactive, and require the user to select individual nodes or a rectangular -area in which edges are added or removed. -See `?geo.add.edges` for more information on these functions. -For instance, we can remove a few odd connections in the previous graph, near the Australian coasts -(note that we have to save the changes using `<-`): - -```r -geo.goto("autralia") -newGraph <- geo.remove.edges(newGraph) -``` - -![img](vignettes/figs/georemove.png) - - When adding connections within an area or in an entire graph, node addition is based on -another `gGraph`,*i.e.* only connections existing in another `gGraph` serving as -reference can be added to the current `gGraph`. -For graphs based on 10k or 40k grids, the raw graphs provided in `geoGraph` should be used, -(`rawgraph.10k`, `rawgraph.40k`), since they are fully connected. - - - - -In addition to changing grid connectivity, we may also want to modify the attributes of specific nodes. -This is again done interactively, using the function `geo.change.attr`. -For instance, here, we define a new value `shalowwater` (plotted in light blue) for the attribute `habitat`, -selecting affected nodes using the 'area' mode first, and refining the changes using the 'point' mode: - -```r -plot(newGraph, edge=TRUE) -temp <- geo.change.attr(newGraph, mode="area", attr.name="habitat", attr.value="shallowwater", newCol="deepskyblue") -temp <- geo.change.attr(temp, attr.name="habitat", attr.value="shallowwater", newCol="deepskyblue") -newGraph <- temp -``` - -```r -newGraph@meta$colors -``` - -``` -## habitat color -## 1 sea blue -## 2 land green -## 3 mountain brown -## 4 landbridge light green -## 5 oceanic crossing light blue -## 6 deselected land lightgray -## 7 shallowwater deepskyblue -``` - -```r -plot(newGraph,edge=TRUE) -``` - -![plot of chunk unnamed-chunk-29](vignettes/figs/unnamed-chunk-29-1.png) - -Again, note that the changes made to the graph have to be save in an object (using `<-`) to be -effective. - - - - - - - -## Extracting information from GIS shapefiles - -An important feature of *geoGraph* is serving as an interface between *geographic information -system* (GIS) layers and geographic data. -As currently implemented, *geoGraph* can extract information from shapefiles with the Arc GIS -(http://www.esri.com/software/arcgis/index.html) format, using the function `extractFromLayer`. -Here, we illustrate this procedure using the shapefile `world-countries.shp` provided with the -package. -The GIS shapefile is first read in R using `readShapePoly` from the *maptools* package: - -```r -library(maptools) -``` - -``` -## Checking rgeos availability: FALSE -## Note: when rgeos is not available, polygon geometry computations in maptools depend on gpclib, -## which has a restricted licence. It is disabled by default; -## to enable gpclib, type gpclibPermit() -``` - -```r -world.countries <- readShapePoly(system.file("files/shapefiles/world-countries.shp",package="geoGraph")) -class(world.countries) -``` - -``` -## [1] "SpatialPolygonsDataFrame" -## attr(,"package") -## [1] "sp" -``` - -```r -summary(world.countries) -``` - -``` -## Object of class SpatialPolygonsDataFrame -## Coordinates: -## min max -## x -180.0 181.80 -## y -89.9 84.93 -## Is projected: NA -## proj4string : [NA] -## Data attributes: -## WORCNTRY_I ID NAME ISO_2 -## Min. : 1.0 ABW : 1 Afghanistan : 1 AD : 1 -## 1st Qu.: 60.5 AFG : 1 Albania : 1 AE : 1 -## Median :120.0 AGO : 1 Algeria : 1 AF : 1 -## Mean :120.0 AIA : 1 American Samoa: 1 AG : 1 -## 3rd Qu.:179.5 ALB : 1 Andorra : 1 AI : 1 -## Max. :239.0 AND : 1 Angola : 1 AL : 1 -## (Other):233 (Other) :233 (Other):233 -## ISO_NUM CAPITAL POP_1994 CONTINENT -## 10 : 1 N/A : 2 Min. :0.00e+00 Africa :59 -## 100 : 1 Victoria : 2 1st Qu.:1.38e+05 Antarctica : 2 -## 104 : 1 Abidjan : 1 Median :3.58e+06 Asia :73 -## 108 : 1 Abu Dhabi: 1 Mean :2.24e+07 Australia : 2 -## 112 : 1 Accra : 1 3rd Qu.:1.12e+07 Europe :51 -## 116 : 1 (Other) :209 Max. :1.18e+09 North America:34 -## (Other):233 NA's : 23 South America:18 -``` -The summary of `world.countries` shows the data (attributes) stored in the layer. -Let us assume that we are interested in retrieving continent and country information for the -`worldgraph.10k` object. -Note that `extractFromLayer` can extract information to other types of objects than `gGraph` (see `?extractFromLayer`) - -```r -summary(getNodesAttr(worldgraph.10k)) -``` - -``` -## habitat -## deselected land: 290 -## land :2632 -## sea :7320 -``` - -```r -newGraph <- extractFromLayer(worldgraph.10k, layer=world.countries, attr=c("CONTINENT","NAME")) -summary(getNodesAttr(newGraph)) -``` - -``` -## habitat CONTINENT NAME -## deselected land: 290 Asia : 957 Russian Federation: 339 -## land :2632 Africa : 607 Antartica : 241 -## sea :7320 North America: 430 United States : 192 -## South America: 359 Canada : 188 -## Antarctica : 241 China : 184 -## (Other) : 325 (Other) :1775 -## NA's :7323 NA's :7323 -``` -The new object `newGraph` is a `gGraph` which now includes, for each node of the grid, the -corresponding continent and country retrieved from the GIS layer. -We can use the newly acquired information for plotting `newGraph`, by defining new color rules: - -```r -temp <- unique(getNodesAttr(newGraph)$"NAME") -col <- c("transparent", rainbow(length(temp)-1)) -colMat <- data.frame(NAME=temp, color=col) -head(colMat) -``` - -``` -## NAME color -## 1 transparent -## 2 Antartica #FF0000FF -## 3 Saudi Arabia #FF0B00FF -## 4 Yemen #FF1500FF -## 5 Somalia #FF2000FF -## 6 China #FF2B00FF -``` - -```r -tail(colMat) -``` - -``` -## NAME color -## 140 Latvia #FF0040FF -## 141 Belarus #FF0035FF -## 142 Eritrea #FF002AFF -## 143 Djibouti #FF0020FF -## 144 East Timor #FF0015FF -## 145 Jordan #FF000BFF -``` - -```r -plot(newGraph, col.rules=colMat, reset=TRUE) -``` - -![plot of chunk unnamed-chunk-32](vignettes/figs/unnamed-chunk-32-1.png) - - This information could in turn be used to define costs for travelling on the grid. -For instance, one could import habitat descriptors from a GIS, use these values to formulate a -habitat model, and derive costs for dispersal on the grid. - - -As soon as a GIS layer has been extracted to a `gGraph`, this information becomes also available for -any `gData` interfaced with this object. -For instance, we can re-use the `cities` example defined in a previous section, and interface it -with `newGraph` to retrieve continent and country information for the cities of the dataset: - -```r -cities.dat -``` - -``` -## lon lat pop -## Bordeaux -1 45 1.0e+06 -## London 0 51 1.3e+07 -## Malaga -4 37 5.0e+05 -## Zagreb 16 46 1.2e+06 -``` - -```r -cities <- new("gData", coords=cities.dat[,1:2], data=cities.dat[,3,drop=FALSE], gGraph.name="newGraph") -cities <- closestNode(cities, attr.name="habitat", attr.value="land") -getData(cities) -``` - -``` -## pop -## Bordeaux 1.0e+06 -## London 1.3e+07 -## Malaga 5.0e+05 -## Zagreb 1.2e+06 -``` - -```r -getNodesAttr(cities) -``` - -``` -## habitat CONTINENT NAME -## 5775 land Europe France, Metropolitan -## 6413 land Europe United Kingdom -## 4815 land Europe Spain -## 7699 land Europe Austria -``` - - - - - - - -## Finding least-cost paths - -One of the most useful applications of *geoGraph* is the research of least-cost paths between -couples of locations. -This can be achieved using the functions `dijkstraFrom` and `dijkstraBetween` on a -`gData` object which contains all the locations of interest. -These functions return least-cost paths with the format `gPath`. -`dijkstraFrom` compute the paths from a given node of the grid to all locations of the -`gData`, while `dijkstraBetween` computes the paths between pairs of locations of the -`gData`. -Below, we detail the example of the documentation of these functions, which uses the famous dataset of native -Human populations, HGDP: - -```r -hgdp -``` - -``` -## -## === gData object === -## -## @coords: spatial coordinates of 52 nodes -## lon lat -## 1 -3 59 -## 2 39 44 -## 3 40 61 -## ... -## -## @nodes.id: nodes identifiers -## 28179 11012 22532 -## "26898" "11652" "22532" -## ... -## -## @data: 52 data -## Population Region Label n Latitude Longitude Genetic.Div -## 1 Orcadian EUROPE 1 15 59 -3 0.7259 -## 2 Adygei EUROPE 2 17 44 39 0.7298 -## 3 Russian EUROPE 3 25 61 40 0.7320 -## ... -## -## Associated gGraph: worldgraph.40k -``` - -```r -plot(hgdp, reset=TRUE) -``` - -![plot of chunk unnamed-chunk-34](vignettes/figs/unnamed-chunk-34-1.png) - - Populations of the dataset are shown by red circles, while the underlying grid -(`worldgraph.40k`) is represented with colors depending on habitat (blue: sea; green: land; -pink: coasts). -Population genetics predicts that genetic diversity within populations should decay as populations are -located further away from the geographic origin of the species. -Here, we verify this relationship for a theoretical origin in Addis abeba, Ethiopia. -We shall seek all paths through landmasses to the HGDP populations. - - -First, we check that all populations are connected on the grid using `isConnected`: - -```r -isConnected(hgdp) -``` - -``` -## [1] TRUE -``` -Note that in practice, we may often want to assess graphically the connectivity of the underlying grid, especially -if not all locations of the `gData` are connected. -This can be done using `connectivityPlot`, which has methods for both `gGraph` and -`gData`, and represents different connected components using different colors. -For instance, for `worldgraph.10k`: - -```r -connectivityPlot(worldgraph.10k, edges=TRUE, seed=1) -``` - -![plot of chunk connectivityPlot](vignettes/figs/connectivityPlot-1.png) - -```r -geo.zoomin(c(90,150,18,-25)) -title("Different connected components\n in worldgraph.10k") -``` - -![plot of chunk unnamed-chunk-36](vignettes/figs/unnamed-chunk-36-1.png) - - -Since all locations in `hgdp` are connected, we can proceed further. -We have to set the costs of edges in the `gGraph` grid. -To do so, we can choose between i) strictly uniform costs (using `dropCosts`) ii) -distance-based costs -- roughly uniform -- (using `setDistCosts`) or iii) attribute-driven -costs (using `setCosts`). - - -We shall first illustrate the strictly uniform costs. -After setting a `gGraph` with uniform costs, we use `dijkstraFrom` to find the shortest -paths between Addis abeba and the populations of `hgdp`: - -```r -myGraph <- dropCosts(worldgraph.40k) -hgdp@gGraph.name <- "myGraph" -addis <- cbind(38,9) -ori <- closestNode(myGraph, addis) -paths <- dijkstraFrom(hgdp, ori) -``` -The object `paths` contains the identified paths, which are stored as a list with class `gPath` (see `?gPath`). -Paths can be plotted easily: - -```r -addis <- as.vector(addis) -plot(newGraph, col=NA, reset=TRUE) -plot(paths) -points(addis[1], addis[2], pch="x", cex=2) -text(addis[1]+35, addis[2], "Addis abeba", cex=.8, font=2) -points(hgdp, col.node="black") -``` - -![plot of chunk unnamed-chunk-38](vignettes/figs/unnamed-chunk-38-1.png) - -In this graph, each path is plotted with a different color, but several paths overlap in several places. -We can extract the distances from the `origin' using `gPath2dist`, and then examine the -relationship between genetic diversity within populations (stored in `hgdp`) and the distance from the origin: - -```r -div <- getData(hgdp)$"Genetic.Div" -dgeo.unif <- gPath2dist(paths, res.type="vector") -plot(div~dgeo.unif, xlab="GeoGraphic distance (arbitrary units)", ylab="Genetic diversity") -lm.unif <- lm(div~dgeo.unif) -abline(lm.unif, col="red") -summary(lm.unif) -``` - -``` -## -## Call: -## lm(formula = div ~ dgeo.unif) -## -## Residuals: -## Min 1Q Median 3Q Max -## -0.07327 -0.00660 0.00074 0.01015 0.05449 -## -## Coefficients: -## Estimate Std. Error t value Pr(>|t|) -## (Intercept) 7.70e-01 4.58e-03 168.2 <2e-16 *** -## dgeo.unif -8.39e-04 5.31e-05 -15.8 <2e-16 *** -## --- -## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 -## -## Residual standard error: 0.0185 on 50 degrees of freedom -## Multiple R-squared: 0.833, Adjusted R-squared: 0.83 -## F-statistic: 250 on 1 and 50 DF, p-value: <2e-16 -``` - -```r -title("Genetic diversity vs geographic distance \n uniform costs ") -``` - -![plot of chunk unnamed-chunk-39](vignettes/figs/unnamed-chunk-39-1.png) - - -Alternatively, we can use costs based on habitat. -As a toy example, we will consider that coasts are four times more favourable for dispersal than -the rest of the landmasses. -We define these new costs, and then compute and plot the corresponding shortest paths: - -```r -myGraph@meta$costs[7,] <- c("coast", 0.25) -myGraph@meta$costs -``` - -``` -## habitat cost -## 1 sea 100 -## 2 land 1 -## 3 mountain 10 -## 4 landbridge 5 -## 5 oceanic crossing 20 -## 6 deselected land 100 -## 7 coast 0.25 -``` - -```r -myGraph <- setCosts(myGraph, attr.name="habitat") -paths.2 <- dijkstraFrom(hgdp, ori) -``` - -```r -plot(newGraph, col=NA, reset=TRUE) -plot(paths.2) -points(addis[1], addis[2], pch="x", cex=2) -text(addis[1]+35, addis[2], "Addis abeba", cex=.8, font=2) -points(hgdp, col.node="black") -``` - -![plot of chunk unnamed-chunk-41](vignettes/figs/unnamed-chunk-41-1.png) - -The new paths are slightly different from the previous ones. -We can examine the new relationship with genetic distance: - -```r -dgeo.hab <- gPath2dist(paths.2, res.type="vector") -plot(div~dgeo.hab, xlab="GeoGraphic distance (arbitrary units)", ylab="Genetic diversity") -lm.hab <- lm(div~dgeo.hab) -abline(lm.hab, col="red") -summary(lm.hab) -``` - -``` -## -## Call: -## lm(formula = div ~ dgeo.hab) -## -## Residuals: -## Min 1Q Median 3Q Max -## -0.11183 -0.00976 0.00133 0.01216 0.06413 -## -## Coefficients: -## Estimate Std. Error t value Pr(>|t|) -## (Intercept) 0.770137 0.007174 107.36 < 2e-16 *** -## dgeo.hab -0.001421 0.000145 -9.79 3.2e-13 *** -## --- -## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 -## -## Residual standard error: 0.0265 on 50 degrees of freedom -## Multiple R-squared: 0.657, Adjusted R-squared: 0.651 -## F-statistic: 95.9 on 1 and 50 DF, p-value: 3.21e-13 -``` - -```r -title("Genetic diversity vs geographic distance \n habitat costs ") -``` - -![plot of chunk unnamed-chunk-42](vignettes/figs/unnamed-chunk-42-1.png) - -Of course, the distinction between coasts and inner landmasses is a somewhat poor description of habitat. -In practice, complex habitat models can be used as simply. +A detailed introduction to the functionalities of `geoGraph` is found in the +overview article of its website. diff --git a/inst/files/coords/globalcoord.10242.csv b/data-raw/coords/globalcoord.10242.csv similarity index 100% rename from inst/files/coords/globalcoord.10242.csv rename to data-raw/coords/globalcoord.10242.csv diff --git a/inst/files/coords/globalcoord.40962.csv b/data-raw/coords/globalcoord.40962.csv similarity index 100% rename from inst/files/coords/globalcoord.40962.csv rename to data-raw/coords/globalcoord.40962.csv diff --git a/data-raw/shapefiles/world-countries.dbf b/data-raw/shapefiles/world-countries.dbf new file mode 100644 index 0000000..6acffe5 Binary files /dev/null and b/data-raw/shapefiles/world-countries.dbf differ diff --git a/data-raw/shapefiles/world-countries.sbn b/data-raw/shapefiles/world-countries.sbn new file mode 100644 index 0000000..f12623f Binary files /dev/null and b/data-raw/shapefiles/world-countries.sbn differ diff --git a/data-raw/shapefiles/world-countries.sbx b/data-raw/shapefiles/world-countries.sbx new file mode 100644 index 0000000..e6da600 Binary files /dev/null and b/data-raw/shapefiles/world-countries.sbx differ diff --git a/data-raw/shapefiles/world-countries.shp b/data-raw/shapefiles/world-countries.shp new file mode 100644 index 0000000..797d667 Binary files /dev/null and b/data-raw/shapefiles/world-countries.shp differ diff --git a/data-raw/shapefiles/world-countries.shx b/data-raw/shapefiles/world-countries.shx new file mode 100644 index 0000000..ab39ac5 Binary files /dev/null and b/data-raw/shapefiles/world-countries.shx differ diff --git a/data/globalcoord.10k.RData b/data/globalcoord.10k.RData deleted file mode 100644 index c92f287..0000000 Binary files a/data/globalcoord.10k.RData and /dev/null differ diff --git a/data/globalcoord.40k.RData b/data/globalcoord.40k.RData deleted file mode 100644 index 40cfe99..0000000 Binary files a/data/globalcoord.40k.RData and /dev/null differ diff --git a/data/hgdp.RData b/data/hgdp.RData deleted file mode 100644 index beb9585..0000000 Binary files a/data/hgdp.RData and /dev/null differ diff --git a/data/hgdp.rda b/data/hgdp.rda new file mode 100644 index 0000000..597135e Binary files /dev/null and b/data/hgdp.rda differ diff --git a/data/hgdpPlus.RData b/data/hgdpPlus.RData deleted file mode 100644 index a7a1582..0000000 Binary files a/data/hgdpPlus.RData and /dev/null differ diff --git a/data/hgdpPlus.rda b/data/hgdpPlus.rda new file mode 100644 index 0000000..5e646a2 Binary files /dev/null and b/data/hgdpPlus.rda differ diff --git a/data/rawgraph.10k.RData b/data/rawgraph.10k.RData index f4c6619..82c43b2 100644 Binary files a/data/rawgraph.10k.RData and b/data/rawgraph.10k.RData differ diff --git a/data/rawgraph.40k.RData b/data/rawgraph.40k.RData deleted file mode 100644 index c04217a..0000000 Binary files a/data/rawgraph.40k.RData and /dev/null differ diff --git a/data/rawgraph.40k.rda b/data/rawgraph.40k.rda new file mode 100644 index 0000000..53d57a5 Binary files /dev/null and b/data/rawgraph.40k.rda differ diff --git a/data/worldgraph.10k.RData b/data/worldgraph.10k.RData deleted file mode 100644 index 4de61c9..0000000 Binary files a/data/worldgraph.10k.RData and /dev/null differ diff --git a/data/worldgraph.10k.rda b/data/worldgraph.10k.rda new file mode 100644 index 0000000..154056f Binary files /dev/null and b/data/worldgraph.10k.rda differ diff --git a/data/worldgraph.40k.RData b/data/worldgraph.40k.RData deleted file mode 100644 index f98e17b..0000000 Binary files a/data/worldgraph.40k.RData and /dev/null differ diff --git a/data/worldgraph.40k.rda b/data/worldgraph.40k.rda new file mode 100644 index 0000000..712c895 Binary files /dev/null and b/data/worldgraph.40k.rda differ diff --git a/data/worldshape.RData b/data/worldshape.RData deleted file mode 100644 index c8606ca..0000000 Binary files a/data/worldshape.RData and /dev/null differ diff --git a/data/worldshape.rda b/data/worldshape.rda new file mode 100644 index 0000000..7f73020 Binary files /dev/null and b/data/worldshape.rda differ diff --git a/man/auxiliary.Rd b/man/auxiliary.Rd index 6f1a3e6..f749b23 100644 --- a/man/auxiliary.Rd +++ b/man/auxiliary.Rd @@ -23,9 +23,9 @@ geo.segments( \arguments{ \item{x}{a valid \linkS4class{gGraph}.} -\item{x0, y0}{coordinates of points *from* which to draw.} +\item{x0, y0}{coordinates of points \emph{from} which to draw.} -\item{x1, y1}{coordinates of points *to* which to draw.} +\item{x1, y1}{coordinates of points \emph{to} which to draw.} \item{col}{a character string or an integer indicating the color of the segments.} @@ -48,13 +48,13 @@ unlike other functions in \code{geoGraph}, these functions do not generally test for the validity of the provided arguments (for speed purposes).\cr } \details{ -- \code{hasCosts}: tests whether a \linkS4class{gGraph} has costs associated +\itemize{ +\item \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 +\item \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. +\item \code{rebuild}: in development. +} } \examples{ diff --git a/man/buffer.Rd b/man/buffer.Rd index 2eaaa06..82699b6 100644 --- a/man/buffer.Rd +++ b/man/buffer.Rd @@ -26,16 +26,16 @@ should be computed.} } \value{ The output depends on the value of the argument \code{res.type}:\cr -- \code{nodes}: a vector of characters identifying the nodes of the +\itemize{ +\item \code{nodes}: a vector of characters identifying the nodes of the buffers.\cr - -- \code{gGraph}: a \linkS4class{gGraph} object with a new attribute "buffer" +\item \code{gGraph}: a \linkS4class{gGraph} object with a new attribute "buffer" (TRUE: within buffers; FALSE: outside buffers), and new color rules for this attribute in \code{@meta$buf.colors}.\cr - -- \code{gData}: a \linkS4class{gData} object including all the nodes of the +\item \code{gData}: a \linkS4class{gData} object including all the nodes of the buffers.\cr } +} \description{ The generic function \code{buffer} finds buffers around specified locations of a \linkS4class{gGraph} or a \linkS4class{gData} object. Different format diff --git a/man/closestNode.Rd b/man/closestNode.Rd index 0d2dc9d..f7dffca 100644 --- a/man/closestNode.Rd +++ b/man/closestNode.Rd @@ -62,11 +62,11 @@ that it is not possible to specify node attributes (\code{attr.names} and } \section{Functions}{ \itemize{ -\item \code{closestNode,gGraph-method}: Method for gGraph +\item \code{closestNode(gGraph)}: Method for gGraph -\item \code{closestNode,gData-method}: Method for gData -}} +\item \code{closestNode(gData)}: Method for gData +}} \examples{ \dontrun{ diff --git a/man/connectivity.Rd b/man/connectivity.Rd index 9f103b7..436a166 100644 --- a/man/connectivity.Rd +++ b/man/connectivity.Rd @@ -54,36 +54,34 @@ nodes to be used when plotting the \linkS4class{gGraph} object. Defaults to '0', meaning that nodes are invisible.} } \value{ -- \code{areNeighbours}: a vector of logical, having one value for +\itemize{ +\item \code{areNeighbours}: a vector of logical, having one value for each couple of nodes.\cr - -- \code{areConnected}: a single logical value, being TRUE if nodes form a +\item \code{areConnected}: a single logical value, being TRUE if nodes form a connected set.\cr - -- \code{isConnected}: a single logical value, being TRUE if nodes of the +\item \code{isConnected}: a single logical value, being TRUE if nodes of the object form a connected set.\cr } +} \description{ The functions \code{areNeighbours}, \code{areConnected} and the method \code{isConnected} test connectivity in different ways.\cr } \details{ -- \code{areNeighbours}: tests connectivity between couples of nodes on an +\itemize{ +\item \code{areNeighbours}: tests connectivity between couples of nodes on an object inheriting \code{graph} class (like a \linkS4class{graphNEL} object).\cr - -- \code{areConnected}: tests if a set of nodes form a connected set on a +\item \code{areConnected}: tests if a set of nodes form a connected set on a \linkS4class{gGraph} object.\cr - -- \code{isConnected}: tests if the nodes of a \linkS4class{gData} object +\item \code{isConnected}: tests if the nodes of a \linkS4class{gData} object form a connected set. Note that this is a method for \linkS4class{gData}, the generic being defined in the \code{graph} package.\cr - -- \code{isReachable}: tests if one location (actually, the closest node to +\item \code{isReachable}: tests if one location (actually, the closest node to it) is reachable from the set of nodes of a \linkS4class{gData} object.\cr - -- \code{connectivityPlot}: plots connected sets of a \linkS4class{gGraph} or +\item \code{connectivityPlot}: plots connected sets of a \linkS4class{gGraph} or a \linkS4class{gData} object with different colors.\cr +} In \code{connectivityPlot}, isolated nodes (i.e. belonging to no connected set of size > 1) are plotted in light grey. diff --git a/man/extractFromLayer.Rd b/man/extractFromLayer.Rd index 8c496d1..08fb2ed 100644 --- a/man/extractFromLayer.Rd +++ b/man/extractFromLayer.Rd @@ -47,15 +47,15 @@ data are also stored in \code{layer@data}.} The output depends on the nature of the input:\cr - \code{matrix, data.frame, list}: a data.frame with one row per location, and as many columns as requested variables ('attributes').\cr - -- \code{gGraph}: a \linkS4class{gGraph} object with new node attributes +\itemize{ +\item \code{gGraph}: a \linkS4class{gGraph} object with new node attributes (\code{@nodes.attr} slot). If nodes attributes already existed, new attributes are added as new columns.\cr - -- \code{gData}: a \linkS4class{gData} object with new data associated to +\item \code{gData}: a \linkS4class{gData} object with new data associated to locations (\code{@data} slot). New information is merge to older information according to the type of data being stored. \cr } +} \description{ The generic function \code{extractFromLayer} uses information from a GIS shapefile to define node attributes. For each node, information is retrieved diff --git a/man/findLand.Rd b/man/findLand.Rd index eb47c35..cc298ea 100644 --- a/man/findLand.Rd +++ b/man/findLand.Rd @@ -36,11 +36,12 @@ which the output is to be stored.} \value{ The output depends on the nature of the input:\cr - \code{matrix, data.frame}: a factor with two levels being 'land' and 'sea'.\cr - -- \code{gGraph}: a \linkS4class{gGraph} object with a new node attribute, +\itemize{ +\item \code{gGraph}: a \linkS4class{gGraph} object with a new node attribute, possibly added to previously existing node attributes (\code{@nodes.attr} slot).\cr } +} \description{ The generic function \code{findLand} uses information from a GIS shapefile to define which nodes are on land, and which are not. Strickly speaking, diff --git a/man/gGraph-class.Rd b/man/gGraph-class.Rd index 65a100c..dde6eab 100644 --- a/man/gGraph-class.Rd +++ b/man/gGraph-class.Rd @@ -25,9 +25,7 @@ Such data are composed of a set of geographic coordinates of vertices (or 'nodes'), and a graph describing connectivity between these vertices. Data associated to the nodes can also be stored ('nodes attributes'), as well as meta-information used when plotting the object, or when computing weights -associated to the edges based on nodes attributes.\cr % History associated -to a \code{gGraph} object is stored in the slot % \code{history}, as an -object of the class % \linkS4class{gGraphHistory}.\cr +associated to the edges based on nodes attributes.\cr } \details{ In all slots, nodes are uniquely identified by their name (reference is @@ -97,8 +95,7 @@ title("after droping edges with null weight") } \seealso{ -Related classes are:\cr % - \code{\linkS4class{gGraphHistory}}: -slot \code{@history} in \code{gGraph}.\cr - \code{\linkS4class{graphNEL}} +Related classes are:\cr \% - \code{\linkS4class{graphNEL}} (graph package): slot \code{@graph} in \code{gGraph}.\cr } \author{ diff --git a/man/geoGraph-package.Rd b/man/geoGraph-package.Rd index 547b25b..a01dd39 100644 --- a/man/geoGraph-package.Rd +++ b/man/geoGraph-package.Rd @@ -19,72 +19,54 @@ coordinates of a set of nodes (@coords), attributes for these nodes of connections between nodes of class graphNEL (@graph).\cr Several functions are available for handling gGraph data: - -- some accessors allow to access slots of an object, sometimes with +\itemize{ +\item some accessors allow to access slots of an object, sometimes with additional treatment of information: \code{\link{getGraph}}, \code{\link{getNodesAttr}}, \code{\link{getCoords}}, \code{\link{getNodes}}, \code{\link{getEdges}}, \code{\link{getCosts}}.\cr - -- \code{\link{setEdges}}: add/remove edges specified edges.\cr - -- \code{\link{setCosts}}: set costs of edges.\cr - -- \code{\link{hasCosts}}: tests if the graph is weighted (i.e., has +\item \code{\link{setEdges}}: add/remove edges specified edges.\cr +\item \code{\link{setCosts}}: set costs of edges.\cr +\item \code{\link{hasCosts}}: tests if the graph is weighted (i.e., has non-uniform costs).\cr - -- \code{\link{isInArea}}: finds which nodes are in the currently plotted +\item \code{\link{isInArea}}: finds which nodes are in the currently plotted area.\cr - -- \code{\link{areConnected}}: tests if nodes are directly connected.\cr - -- \code{\link{connectivityPlot}}: plot connected components with different +\item \code{\link{areConnected}}: tests if nodes are directly connected.\cr +\item \code{\link{connectivityPlot}}: plot connected components with different colors.\cr - -- \code{\link{dropDeadEdges}}: suppress edges whose weight is null.\cr - -- \code{\link{closestNode}}: given a longitude and a latitude, finds the +\item \code{\link{dropDeadEdges}}: suppress edges whose weight is null.\cr +\item \code{\link{closestNode}}: given a longitude and a latitude, finds the closest node; specific values of node attribute can be provided, for instance, to find the closest node on land.\cr - -- \code{\link{show}}: printing of gGraph objects.\cr - -- \code{\link{extractFromLayer}}: extract information from GIS layers.\cr - -- \code{\link{findLand}}: checks which nodes are on land.\cr - -- \code{\link{setCosts}}: define edges weights accoring to rules specified +\item \code{\link{show}}: printing of gGraph objects.\cr +\item \code{\link{extractFromLayer}}: extract information from GIS layers.\cr +\item \code{\link{findLand}}: checks which nodes are on land.\cr +\item \code{\link{setCosts}}: define edges weights accoring to rules specified in the @meta slot.\cr - -- \code{\link{geo.add.edges}}, \code{\link{geo.remove.edges}}: graphical +\item \code{\link{geo.add.edges}}, \code{\link{geo.remove.edges}}: graphical functions for adding or removing edges.\cr - -- \code{\link{geo.change.attr}}: graphical functions for changing attributes +\item \code{\link{geo.change.attr}}: graphical functions for changing attributes of nodes.\cr +} === GRAPHICS ===\cr \code{geoGraph} aims at providing advanced graphical facilities, such as zooming in or out particular area, moving the plotted area, or visualizing connectivity between nodes. \cr - -- \code{\link{plot}}: plot method with various options, allowing to display +\itemize{ +\item \code{\link{plot}}: plot method with various options, allowing to display a shapefile (by default, the map of the world), using color according to attributes, showing connectivity between nodes, etc.\cr - -- \code{\link{points}}: similar to plot method, except that a new plot is +\item \code{\link{points}}: similar to plot method, except that a new plot is not created.\cr - -- \code{\link{plotEdges}}: the specific function plotting edges. It detects +\item \code{\link{plotEdges}}: the specific function plotting edges. It detects if the object is a weighted graph, and plots edges accordingly.\cr - -- \code{\link{geo.zoomin}}, \code{\link{geo.zoomout}}: zoom in and out a +\item \code{\link{geo.zoomin}}, \code{\link{geo.zoomout}}: zoom in and out a plot.\cr - -- \code{\link{geo.back}}: replot the previous screens.\cr - -- \code{\link{geo.slide}}: slide the plotted area toward the indicated +\item \code{\link{geo.back}}: replot the previous screens.\cr +\item \code{\link{geo.slide}}: slide the plotted area toward the indicated direction.\cr - -- \code{\link{geo.bookmark}}, \code{\link{geo.goto}}: set and goto a +\item \code{\link{geo.bookmark}}, \code{\link{geo.goto}}: set and goto a bookmarked area.\cr +} === DATASETS ===\cr Datasets occupy a central place in \code{geoGraph}, since they provide the spatial models used in later operations. @@ -96,15 +78,10 @@ sizes. Two different resolutions are provided:\cr - \code{\link{worldgraph.40k}}: coverage using about 40,000 nodes\cr Other datasets are:\cr - \code{\link{worldshape}}: shapefile containing -world countries.\cr - \code{\link{globalcoord.10k}}: spatial coordinates -used in \code{\link{worldgraph.10k}}.\cr - \code{\link{globalcoord.40k}}: -spatial coordinates used in \code{\link{worldgraph.40k}}.\cr +world countries.\cr To cite geoGraph, please use the reference given by \code{citation("geoGraph")}. - -\tabular{ll}{ Package: \tab geoGraph\cr Type: \tab Package\cr Version: \tab -1.0-0\cr Date: \tab 2010-07-01 \cr License: \tab GPL (>=2) } } \examples{ @@ -140,10 +117,6 @@ plot(x,edges=TRUE) title("after droping edges with null weight") -} -\author{ -Thibaut Jombart (maintainer)\cr François -Balloux \cr Andrea Manica \cr } \keyword{manip} \keyword{spatial} diff --git a/man/getColors.Rd b/man/getColors.Rd index 4b39e93..03da00a 100644 --- a/man/getColors.Rd +++ b/man/getColors.Rd @@ -46,9 +46,9 @@ See example section to know how this slot should be designed. } \section{Functions}{ \itemize{ -\item \code{getColors,gGraph-method}: Method for gGraph objects -}} +\item \code{getColors(gGraph)}: Method for gGraph objects +}} \examples{ worldgraph.10k # there is a node attribute 'habitat' diff --git a/man/getCosts.Rd b/man/getCosts.Rd index ed1bed0..41d103e 100644 --- a/man/getCosts.Rd +++ b/man/getCosts.Rd @@ -33,13 +33,14 @@ unique edges (TRUE), or if duplicate edges should be considered as well } \value{ The output depends on the value of the argument \code{res.type}:\cr -- \code{asIs}: output is a named list of weights, each slot containing +\itemize{ +\item \code{asIs}: output is a named list of weights, each slot containing weights associated to the edges stemming from one given node. This format is that of the \code{weights} accessor for \linkS4class{graphNEL} objects.\cr - -- \code{vector}: a vector of weights; this output matches matrix outputs of +\item \code{vector}: a vector of weights; this output matches matrix outputs of \code{\link{getEdges}}.\cr } +} \description{ The function \code{getCosts} returns the costs associated to the edges of a \linkS4class{gGraph} object using different possible outputs. These outputs @@ -56,13 +57,13 @@ connectivity there is between the couple of concerned nodes. } \section{Functions}{ \itemize{ -\item \code{getCosts,gGraph-method}: Method for gGraph object +\item \code{getCosts(gGraph)}: Method for gGraph object -\item \code{getNodeCosts}: Function to get the costs values for nodes +\item \code{getNodeCosts()}: Function to get the costs values for nodes -\item \code{getNodeCosts,gGraph-method}: Method to get node costs for gGraph object -}} +\item \code{getNodeCosts(gGraph)}: Method to get node costs for gGraph object +}} \examples{ head(getEdges(worldgraph.10k, res.type="matNames",unique=TRUE)) diff --git a/man/getEdges.Rd b/man/getEdges.Rd index 6b4b235..0f9b22d 100644 --- a/man/getEdges.Rd +++ b/man/getEdges.Rd @@ -23,25 +23,25 @@ unique (TRUE) or if duplicated edges should be allowed (TRUE, default).} } \value{ The output depends on the value of the argument \code{res.type}:\cr -- \code{asIs}: output is a named list of nodes, each slot containing nodes +\itemize{ +\item \code{asIs}: output is a named list of nodes, each slot containing nodes forming an edge with one given node. This format is that of the \code{edges} accessor for \linkS4class{graphNEL} objects.\cr - -- \code{matNames}: a matrix with two columns giving couples of node names +\item \code{matNames}: a matrix with two columns giving couples of node names forming edges.\cr - -- \code{matId}: a matrix with two columns giving couples of node indices +\item \code{matId}: a matrix with two columns giving couples of node indices forming edges.\cr } +} \description{ The function \code{getEdges} returns the edges of a \linkS4class{gGraph} object using different possible outputs. } \section{Functions}{ \itemize{ -\item \code{getEdges,gGraph-method}: Method for gGraph objects -}} +\item \code{getEdges(gGraph)}: Method for gGraph objects +}} \examples{ example(gGraph) diff --git a/man/getNodesAttr.Rd b/man/getNodesAttr.Rd index c5f92c7..22167cf 100644 --- a/man/getNodesAttr.Rd +++ b/man/getNodesAttr.Rd @@ -36,11 +36,11 @@ associated to the nodes (i.e. node attributes) of a \linkS4class{gGraph} or } \section{Functions}{ \itemize{ -\item \code{getNodesAttr,gGraph-method}: Method for gGraph objects +\item \code{getNodesAttr(gGraph)}: Method for gGraph objects -\item \code{getNodesAttr,gData-method}: Method for gData objects -}} +\item \code{getNodesAttr(gData)}: Method for gData objects +}} \examples{ ## gGraph method diff --git a/man/hgdp.Rd b/man/hgdp.Rd index 117cffe..8a0c986 100644 --- a/man/hgdp.Rd +++ b/man/hgdp.Rd @@ -7,10 +7,10 @@ \title{Human genome diversity panel - georeferenced data} \format{ \code{hgdp} is a \linkS4class{gGraph} object with the following -data: % \describe{ % \item{@nodes.attr$habitat}{habitat corresponding to -each % vertice; currently 'land' or 'sea'.} % \item{@meta$color}{a matrix -assigning a color for plotting % vertices (second column) to different -values of habitat (first % column).} % } +data: \% \describe{ \% \item{@nodes.attr$habitat}{habitat corresponding to +each \% vertice; currently 'land' or 'sea'.} \% \item{@meta$color}{a matrix +assigning a color for plotting \% vertices (second column) to different +values of habitat (first \% column).} \% } } \description{ The datasets \code{hgdp} and \code{hgdpPlus} provides genetic diversity diff --git a/man/installDep.geoGraph.Rd b/man/installDep.geoGraph.Rd deleted file mode 100644 index b4af688..0000000 --- a/man/installDep.geoGraph.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/auxil.R -\name{installDep.geoGraph} -\alias{installDep.geoGraph} -\title{Install dependencies for geoGraph} -\usage{ -installDep.geoGraph() -} -\description{ -This simple function installs the latest versions of the packages -\code{graph} and \code{RBGL} on Bioconductor. This function requires a -working internet connection, as well as administrator rights for the -directory where the libraries are installed. -} -\author{ -Thibaut Jombart (\email{t.jombart@imperial.ac.uk}) -} -\keyword{utilities} diff --git a/man/isInArea.Rd b/man/isInArea.Rd index 3fda905..c8a5186 100644 --- a/man/isInArea.Rd +++ b/man/isInArea.Rd @@ -61,15 +61,15 @@ area, as a proportion of current area's dimensions.} } \value{ The output depends on the value of the argument \code{res.type}:\cr -- \code{logical}: a vector of logicals having one value for each node of the +\itemize{ +\item \code{logical}: a vector of logicals having one value for each node of the input.\cr - -- \code{integer}: a vector of integers corresponding to the indices of nodes +\item \code{integer}: a vector of integers corresponding to the indices of nodes falling within the area.\cr - -- \code{character}: a vector of characters corresponding to the names of the +\item \code{character}: a vector of characters corresponding to the names of the nodes falling within the area.\cr } +} \description{ The generic function \code{isInArea} finds which nodes fall in a given area. Nodes can be specified in different ways, including by providing a @@ -78,15 +78,15 @@ the output are also available. } \section{Functions}{ \itemize{ -\item \code{isInArea,matrix-method}: Method for matrix +\item \code{isInArea(matrix)}: Method for matrix -\item \code{isInArea,data.frame-method}: Method for data.frame +\item \code{isInArea(data.frame)}: Method for data.frame -\item \code{isInArea,gGraph-method}: Method for gGraph object +\item \code{isInArea(gGraph)}: Method for gGraph object -\item \code{isInArea,gData-method}: Method for gData object -}} +\item \code{isInArea(gData)}: Method for gData object +}} \examples{ plot(worldgraph.10k, reset=TRUE) diff --git a/man/plot-gData.Rd b/man/plot-gData.Rd index c0418ce..7d7d08e 100644 --- a/man/plot-gData.Rd +++ b/man/plot-gData.Rd @@ -83,9 +83,9 @@ the \code{gData} plot.\cr } \section{Functions}{ \itemize{ -\item \code{points,gData-method}: Plot as points -}} +\item \code{points(gData)}: Plot as points +}} \examples{ @@ -112,11 +112,13 @@ points(obj, col.nodes="yellow", cex=4) } \seealso{ -- Different functions to explore these plots:\cr +\itemize{ +\item Different functions to explore these plots:\cr \code{\link{geo.zoomin}}, \code{\link{geo.zoomout}}, \code{\link{geo.slide}}, \code{\link{geo.back}}, \code{\link{geo.bookmark}}, \code{\link{geo.goto}}.\cr } +} \author{ Thibaut Jombart (\email{t.jombart@imperial.ac.uk}) } diff --git a/man/plot-gGraph.Rd b/man/plot-gGraph.Rd index 1025e61..5444c7f 100644 --- a/man/plot-gGraph.Rd +++ b/man/plot-gGraph.Rd @@ -117,11 +117,12 @@ plot(worldgraph.10k[!inSea], bg.col="darkgreen", col="purple", edges=TRUE) } \seealso{ -- Different functions to explore these plots:\cr +\itemize{ +\item Different functions to explore these plots:\cr \code{\link{geo.zoomin}}, \code{\link{geo.zoomout}}, \code{\link{geo.slide}}, \code{\link{geo.back}}.\cr - -- \code{\link{isInArea}}, to retain a set of visible data.\cr +\item \code{\link{isInArea}}, to retain a set of visible data.\cr +} } \author{ Thibaut Jombart (\email{t.jombart@imperial.ac.uk}) diff --git a/man/setDistCosts.Rd b/man/setDistCosts.Rd index 6cb6c64..8e31a19 100644 --- a/man/setDistCosts.Rd +++ b/man/setDistCosts.Rd @@ -35,9 +35,9 @@ connectivity there is between the couple of concerned nodes. } \section{Functions}{ \itemize{ -\item \code{setDistCosts,gGraph-method}: Method for gGraph object -}} +\item \code{setDistCosts(gGraph)}: Method for gGraph object +}} \examples{ if(require(fields)){ diff --git a/man/setEdges.Rd b/man/setEdges.Rd index 204d022..c2a9d11 100644 --- a/man/setEdges.Rd +++ b/man/setEdges.Rd @@ -37,9 +37,9 @@ a data.frame. This low-level function is called by \code{geo.add.edges} and } \section{Functions}{ \itemize{ -\item \code{setEdges,gGraph-method}: Method for gGraph object -}} +\item \code{setEdges(gGraph)}: Method for gGraph object +}} \seealso{ \code{\link{geo.add.edges}} and \code{\link{geo.remove.edges}} to interactively add or remove edges in a \linkS4class{gGraph} object. \cr diff --git a/man/worldgraph.Rd b/man/worldgraph.Rd index 26f2d80..5b91620 100644 --- a/man/worldgraph.Rd +++ b/man/worldgraph.Rd @@ -7,8 +7,6 @@ \alias{rawgraph.40k} \alias{worldgraph.10k} \alias{worldgraph.40k} -\alias{globalcoord.10k} -\alias{globalcoord.40k} \alias{worldshape} \title{Worldwide geographic graphs} \format{ @@ -35,9 +33,6 @@ references.\cr connectivity between edges at some places. The most noticable change is that all edges involving sea vertices have been removed.\cr -'globalcoord.10k' and 'globalcoord.40k' are matrices of geographic -coordinates of nodes, used to construct 'rawgraph' and 'worlgraph' objects.\cr - 'worldshape' is a shapefile of contries of the world (snapshot from 1994). } \examples{ diff --git a/vignettes/figs/bookmark-1.png b/vignettes/figs/bookmark-1.png deleted file mode 100644 index 16ef227..0000000 Binary files a/vignettes/figs/bookmark-1.png and /dev/null differ diff --git a/vignettes/figs/citiesPlot2-1.png b/vignettes/figs/citiesPlot2-1.png deleted file mode 100644 index 7f68c52..0000000 Binary files a/vignettes/figs/citiesPlot2-1.png and /dev/null differ diff --git a/vignettes/figs/cities_plot-1.png b/vignettes/figs/cities_plot-1.png deleted file mode 100644 index 82efa5a..0000000 Binary files a/vignettes/figs/cities_plot-1.png and /dev/null differ diff --git a/vignettes/figs/citiesplot-1.png b/vignettes/figs/citiesplot-1.png deleted file mode 100644 index b1e8970..0000000 Binary files a/vignettes/figs/citiesplot-1.png and /dev/null differ diff --git a/vignettes/figs/closeNode-1.png b/vignettes/figs/closeNode-1.png deleted file mode 100644 index 0251aed..0000000 Binary files a/vignettes/figs/closeNode-1.png and /dev/null differ diff --git a/vignettes/figs/connectivityPlot-1.png b/vignettes/figs/connectivityPlot-1.png deleted file mode 100644 index 7fe267e..0000000 Binary files a/vignettes/figs/connectivityPlot-1.png and /dev/null differ diff --git a/vignettes/figs/geoslide-1.png b/vignettes/figs/geoslide-1.png deleted file mode 100644 index 1580033..0000000 Binary files a/vignettes/figs/geoslide-1.png and /dev/null differ diff --git a/vignettes/figs/plot_edges-1.png b/vignettes/figs/plot_edges-1.png deleted file mode 100644 index d1feaac..0000000 Binary files a/vignettes/figs/plot_edges-1.png and /dev/null differ diff --git a/vignettes/figs/unnamed-chunk-23-1.png b/vignettes/figs/unnamed-chunk-23-1.png deleted file mode 100644 index 6c79d5e..0000000 Binary files a/vignettes/figs/unnamed-chunk-23-1.png and /dev/null differ diff --git a/vignettes/figs/unnamed-chunk-24-1.png b/vignettes/figs/unnamed-chunk-24-1.png deleted file mode 100644 index ba64bdb..0000000 Binary files a/vignettes/figs/unnamed-chunk-24-1.png and /dev/null differ diff --git a/vignettes/figs/unnamed-chunk-29-1.png b/vignettes/figs/unnamed-chunk-29-1.png deleted file mode 100644 index 23993bb..0000000 Binary files a/vignettes/figs/unnamed-chunk-29-1.png and /dev/null differ diff --git a/vignettes/figs/unnamed-chunk-32-1.png b/vignettes/figs/unnamed-chunk-32-1.png deleted file mode 100644 index 8e9f3db..0000000 Binary files a/vignettes/figs/unnamed-chunk-32-1.png and /dev/null differ diff --git a/vignettes/figs/unnamed-chunk-34-1.png b/vignettes/figs/unnamed-chunk-34-1.png deleted file mode 100644 index e5aecc4..0000000 Binary files a/vignettes/figs/unnamed-chunk-34-1.png and /dev/null differ diff --git a/vignettes/figs/unnamed-chunk-36-1.png b/vignettes/figs/unnamed-chunk-36-1.png deleted file mode 100644 index 655c7d9..0000000 Binary files a/vignettes/figs/unnamed-chunk-36-1.png and /dev/null differ diff --git a/vignettes/figs/unnamed-chunk-38-1.png b/vignettes/figs/unnamed-chunk-38-1.png deleted file mode 100644 index 23c910d..0000000 Binary files a/vignettes/figs/unnamed-chunk-38-1.png and /dev/null differ diff --git a/vignettes/figs/unnamed-chunk-39-1.png b/vignettes/figs/unnamed-chunk-39-1.png deleted file mode 100644 index 5b4f943..0000000 Binary files a/vignettes/figs/unnamed-chunk-39-1.png and /dev/null differ diff --git a/vignettes/figs/unnamed-chunk-41-1.png b/vignettes/figs/unnamed-chunk-41-1.png deleted file mode 100644 index dd65a1d..0000000 Binary files a/vignettes/figs/unnamed-chunk-41-1.png and /dev/null differ diff --git a/vignettes/figs/unnamed-chunk-42-1.png b/vignettes/figs/unnamed-chunk-42-1.png deleted file mode 100644 index 6385d5f..0000000 Binary files a/vignettes/figs/unnamed-chunk-42-1.png and /dev/null differ diff --git a/vignettes/figs/wg10kdefplot-1.png b/vignettes/figs/wg10kdefplot-1.png deleted file mode 100644 index d7b4b0a..0000000 Binary files a/vignettes/figs/wg10kdefplot-1.png and /dev/null differ diff --git a/vignettes/figs/wg10plot-1.png b/vignettes/figs/wg10plot-1.png deleted file mode 100644 index dc7bdcf..0000000 Binary files a/vignettes/figs/wg10plot-1.png and /dev/null differ diff --git a/vignettes/figs/zoomin-1.png b/vignettes/figs/zoomin-1.png deleted file mode 100644 index 9cf879a..0000000 Binary files a/vignettes/figs/zoomin-1.png and /dev/null differ diff --git a/vignettes/figs/zoomout-1.png b/vignettes/figs/zoomout-1.png deleted file mode 100644 index bc7bb6b..0000000 Binary files a/vignettes/figs/zoomout-1.png and /dev/null differ diff --git a/vignettes/geograph.Rmd b/vignettes/geograph.Rmd index 9588a1d..cfe63a6 100644 --- a/vignettes/geograph.Rmd +++ b/vignettes/geograph.Rmd @@ -1,6 +1,6 @@ --- title: "An introduction to geoGraph" -author: "Thibaut Jombart" +author: "Thibaut Jombart and Andrea Manica" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > @@ -11,7 +11,7 @@ vignette: > ```{r setup, echo=FALSE} -knitr::opts_chunk$set(fig.width = 7, fig.height = 6, fig.path="figs/") +#knitr::opts_chunk$set(fig.width = 7, fig.height = 6) options(digits = 4) ``` @@ -85,8 +85,6 @@ BiocManager::install(c("graph", "RBGL")) And then attempt to reinstall *geoGraph* from GitHub. - - ## Data representation Data representation refers to the way a given type of data is handled by a @@ -212,7 +210,7 @@ package's manpage, accessible via: The html version of this manpage may be preferred to browse more easily the content of *geoGraph*; it is accessible by typing: ```{r eval=FALSE} -help("geoGraph", package="geoGraph", html=TRUE) +help("geoGraph", package = "geoGraph", html = TRUE) ``` To revert help back to text mode, simply type: ```{r eval=FALSE} @@ -246,14 +244,14 @@ and latitudes (in this order, that is, xy coordinates) of these cities in decimal degrees, as well as approximate population sizes: ```{r cities} -Bordeaux <- c(-1,45) -London <- c(0,51) -Malaga <- c(-4,37) -Zagreb <- c(16,46) +Bordeaux <- c(-1, 45) +London <- c(0, 51) +Malaga <- c(-4, 37) +Zagreb <- c(16, 46) cities.dat <- rbind.data.frame(Bordeaux, London, Malaga, Zagreb) -colnames(cities.dat) <- c("lon","lat") +colnames(cities.dat) <- c("lon", "lat") cities.dat$pop <- c(1e6, 13e6, 5e5, 1.2e6) -row.names(cities.dat) <- c("Bordeaux","London","Malaga","Zagreb") +row.names(cities.dat) <- c("Bordeaux", "London", "Malaga", "Zagreb") cities.dat ``` We load a `gGraph` object which contains the grid that will support the data: @@ -268,9 +266,9 @@ node is represented with a color depending on the habitat type, either 'sea' grid; to do so, we create a `gData` object using `new` (see `?gData` object): ```{r citiesplot, fig=TRUE} -cities <- new("gData", coords=cities.dat[,1:2], data=cities.dat[,3,drop=FALSE], gGraph.name="worldgraph.10k") +cities <- new("gData", coords = cities.dat[, 1:2], data = cities.dat[, 3, drop = FALSE], gGraph.name = "worldgraph.10k") cities -plot(cities, type="both", reset=TRUE) +plot(cities, type = "both", reset = TRUE) plotEdges(worldgraph.10k) ``` @@ -281,8 +279,8 @@ Locations can be re-assigned to nodes with restrictions for some node attribute `closestNode`; for instance, here we constrain matching nodes to have an `habitat` value (defined as node attribute in `worldgraph.10k`) equalling `land` (green points): ```{r closeNode, fig=TRUE} -cities <- closestNode(cities, attr.name="habitat", attr.value="land") -plot(cities, type="both", reset=TRUE) +cities <- closestNode(cities, attr.name = "habitat", attr.value = "land") +plot(cities, type = "both", reset = TRUE) plotEdges(worldgraph.10k) ``` @@ -297,7 +295,7 @@ getData(cities) ``` We can also get the coordinates of the matching nodes (\textit{i.e.}, red circle on previous figure) using: ```{r } -getCoords(cities, original=FALSE) +getCoords(cities, original = FALSE) ``` More interestingly, we can now retrieve all the geographic information contained in the underlying grid (\textit{i.e.}, `gGraph` object) as node attributes: @@ -344,7 +342,7 @@ Here is an example using `worldgraph.10k`: worldgraph.10k@meta$colors head(getNodesAttr(worldgraph.10k)) table(getNodesAttr(worldgraph.10k)) -plot(worldgraph.10k, reset=TRUE) +plot(worldgraph.10k, reset = TRUE) title("Default plotting of worldgraph.10k") ``` @@ -355,11 +353,11 @@ For instance, one may want to disable `cairo` under linux: this graphical device graphics than `Xlib`, but at the expense of increase computational time. To switch to `Xlib`, type: ```{r eval=FALSE} -X11.options(type="Xlib") +X11.options(type = "Xlib") ``` and to revert to `cairo`, type: ```{r eval=FALSE} -X11.options(type="cairo") +X11.options(type = "cairo") ``` @@ -405,7 +403,7 @@ geo.zoomin(c(-51.26, 76.78, -23.38, 90.00)) geo.slide() ``` ```{r geoslide, echo=FALSE} -geo.zoomin(c( 41.76, 169.80, -28.28, 99.76)) +geo.zoomin(c(41.76, 169.80, -28.28, 99.76)) ``` @@ -418,11 +416,11 @@ To disable this behavior, set the argument `reset=TRUE` when calling upon `plot` Technically, this 'plotting memory' is implemented by storing plotting information in an environment defined as the hidden environment `geoGraph:::.geoGraphEnv`: ```{r} -ls(env=geoGraph:::.geoGraphEnv) +ls(env = geoGraph:::.geoGraphEnv) ``` You can inspect individual variables within this environment: ```{r} -get("last.plot.param", envir=geoGraph:::.geoGraphEnv) +get("last.plot.param", envir = geoGraph:::.geoGraphEnv) ``` However, it is recommended not to modify these objects directly, unless you really know what you are doing. @@ -438,7 +436,7 @@ plotting history and undo possible wrong manipulations. `gData` objects are by default plotted overlaying the corresponding `gGraph`. For instance, using the `cities` example from above: ```{r citiesPlot2, fig=TRUE} -plot(cities, reset=TRUE) +plot(cities, reset = TRUE) text(getCoords(cities), rownames(getData(cities))) ``` @@ -452,16 +450,16 @@ This method takes an extra argument `original`, which is TRUE if original spatia are seeked, or FALSE for coordinates of the nodes on the grid. We can use this to represent, for instance, the population sizes for the different cities: ```{r cities_plot, fig=TRUE} -transp <- function(col, alpha=.5){ - res <- apply(col2rgb(col),2, function(c) rgb(c[1]/255, c[2]/255, c[3]/255, alpha)) - return(res) +transp <- function(col, alpha = .5) { + res <- apply(col2rgb(col), 2, function(c) rgb(c[1] / 255, c[2] / 255, c[3] / 255, alpha)) + return(res) } -plot(cities, reset=TRUE) -par(xpd=TRUE) -text(getCoords(cities)+-.5, rownames(getData(cities))) -symbols(getCoords(cities)[,1], getCoords(cities)[,2], circ=sqrt(unlist(getData(cities))), inch=.2, bg=transp("red"), add=TRUE) +plot(cities, reset = TRUE) +par(xpd = TRUE) +text(getCoords(cities) + -.5, rownames(getData(cities))) +symbols(getCoords(cities)[, 1], getCoords(cities)[, 2], circ = sqrt(unlist(getData(cities))), inch = .2, bg = transp("red"), add = TRUE) ``` @@ -494,7 +492,7 @@ To model fish dispersal, we have to define a graph which connects only nodes ove We load the `gGraph` object `rawgraph.10k`, and zoom in to a smaller area (Madagascar) to illustrate changes in connectivity: ```{r plot_edges,fig=TRUE} -geo.zoomin(c(35,54,-26,-10)) +geo.zoomin(c(35, 54, -26, -10)) plotEdges(rawgraph.10k) ``` @@ -512,16 +510,16 @@ Costs of a given node attribute (here, `habitat') are indicated in the `meta$cos ```{r } rawgraph.10k@meta$costs newGraph <- rawgraph.10k -newGraph@meta$costs[2:6,2] <- 100 -newGraph@meta$costs[1,2] <- 1 +newGraph@meta$costs[2:6, 2] <- 100 +newGraph@meta$costs[1, 2] <- 1 newGraph@meta$costs ``` We have just changed the costs associated to habitat type, but this change is not yet effective on edges between nodes. We use `setCosts` to set the cost of an edge to the average of the costs of its nodes: ```{r fig = TRUE, fig.width = 8} -newGraph <- setCosts(newGraph, attr.name="habitat") -plot(newGraph,edge=TRUE) +newGraph <- setCosts(newGraph, attr.name = "habitat") +plot(newGraph, edge = TRUE) ``` On this new graph, we represent the edges with a width inversely proportional to the associated @@ -531,15 +529,15 @@ However, we can tell *geoGraph* to remove all edges associated to too strong a c by a given threshold (using `dropDeadEdges`). Here, only sea-sea connections shall be retained, that is, edges with cost 1. ```{r fig=TRUE} -newGraph <- dropDeadEdges(newGraph, thres=1.1) -plot(newGraph,edge=TRUE) +newGraph <- dropDeadEdges(newGraph, thres = 1.1) +plot(newGraph, edge = TRUE) ``` Here we are: `newGraph` only contains connections in the sea. Note that, although we restrained the plotting area to Madagascar, this change is effective everywhere. For instance, travelling to the nort-west Australian coasts: ```{r bookmark, fig=TRUE} -geo.zoomin(c(110,130,-27,-12)) +geo.zoomin(c(110, 130, -27, -12)) geo.bookmark("australia") ``` @@ -584,9 +582,9 @@ This is again done interactively, using the function `geo.change.attr`. For instance, here, we define a new value `shalowwater` (plotted in light blue) for the attribute `habitat`, selecting affected nodes using the 'area' mode first, and refining the changes using the 'point' mode: ```{r eval=FALSE} -plot(newGraph, edge=TRUE) -temp <- geo.change.attr(newGraph, mode="area", attr.name="habitat", attr.value="shallowwater", newCol="deepskyblue") -temp <- geo.change.attr(temp, attr.name="habitat", attr.value="shallowwater", newCol="deepskyblue") +plot(newGraph, edge = TRUE) +temp <- geo.change.attr(newGraph, mode = "area", attr.name = "habitat", attr.value = "shallowwater", newCol = "deepskyblue") +temp <- geo.change.attr(temp, attr.name = "habitat", attr.value = "shallowwater", newCol = "deepskyblue") newGraph <- temp ``` ```{r echo=FALSE} @@ -594,7 +592,7 @@ load("Robjects/newGraph2.RData") ``` ```{r fig=TRUE} newGraph@meta$colors -plot(newGraph,edge=TRUE) +plot(newGraph, edge = TRUE) ``` Again, note that the changes made to the graph have to be save in an object (using `<-`) to be @@ -613,11 +611,14 @@ system* (GIS) layers and geographic data. As currently implemented, *geoGraph* can extract information from shapefiles with the Arc GIS (http://www.esri.com/software/arcgis/index.html) format, using the function `extractFromLayer`. Here, we illustrate this procedure using the shapefile `world-countries.shp` provided with the -package. -The GIS shapefile is first read in R using `readShapePoly` from the *maptools* package: +package. *geoGraph* still relies on `SpatialPolygonDataFrame` objects from the `sp` package. +A move to `sf` objects is planned, but for the moment we have to use `sf::st_read()` to read +a GIS shapefile into an `sf` object, and then cast it to a `SpatialPolygonDataFrame` with +`sf::as_Spatial()`: ```{r } -library(maptools) -world.countries <- readShapePoly(system.file("files/shapefiles/world-countries.shp",package="geoGraph")) +library(sf) +world.countries <- sf::st_read(system.file("files/shapefiles/world-countries.shp", package = "geoGraph")) +world.countries <- sf::as_Spatial(world.countries) class(world.countries) summary(world.countries) ``` @@ -627,7 +628,7 @@ Let us assume that we are interested in retrieving continent and country informa Note that `extractFromLayer` can extract information to other types of objects than `gGraph` (see `?extractFromLayer`) ```{r } summary(getNodesAttr(worldgraph.10k)) -newGraph <- extractFromLayer(worldgraph.10k, layer=world.countries, attr=c("CONTINENT","NAME")) +newGraph <- extractFromLayer(worldgraph.10k, layer = world.countries, attr = c("CONTINENT", "NAME")) summary(getNodesAttr(newGraph)) ``` The new object `newGraph` is a `gGraph` which now includes, for each node of the grid, the @@ -635,11 +636,11 @@ corresponding continent and country retrieved from the GIS layer. We can use the newly acquired information for plotting `newGraph`, by defining new color rules: ```{r fig=TRUE} temp <- unique(getNodesAttr(newGraph)$"NAME") -col <- c("transparent", rainbow(length(temp)-1)) -colMat <- data.frame(NAME=temp, color=col) +col <- c("transparent", rainbow(length(temp) - 1)) +colMat <- data.frame(NAME = temp, color = col) head(colMat) tail(colMat) -plot(newGraph, col.rules=colMat, reset=TRUE) +plot(newGraph, col.rules = colMat, reset = TRUE) ``` This information could in turn be used to define costs for travelling on the grid. @@ -653,8 +654,8 @@ For instance, we can re-use the `cities` example defined in a previous section, with `newGraph` to retrieve continent and country information for the cities of the dataset: ```{r } cities.dat -cities <- new("gData", coords=cities.dat[,1:2], data=cities.dat[,3,drop=FALSE], gGraph.name="newGraph") -cities <- closestNode(cities, attr.name="habitat", attr.value="land") +cities <- new("gData", coords = cities.dat[, 1:2], data = cities.dat[, 3, drop = FALSE], gGraph.name = "newGraph") +cities <- closestNode(cities, attr.name = "habitat", attr.value = "land") getData(cities) getNodesAttr(cities) ``` @@ -679,7 +680,7 @@ Below, we detail the example of the documentation of these functions, which uses Human populations, HGDP: ```{r fig=TRUE, fig.width = 8} hgdp -plot(hgdp, reset=TRUE) +plot(hgdp, reset = TRUE) ``` Populations of the dataset are shown by red circles, while the underlying grid @@ -701,10 +702,10 @@ This can be done using `connectivityPlot`, which has methods for both `gGraph` a `gData`, and represents different connected components using different colors. For instance, for `worldgraph.10k`: ```{r connectivityPlot, fig.width = 8} -connectivityPlot(worldgraph.10k, edges=TRUE, seed=1) +connectivityPlot(worldgraph.10k, edges = TRUE, seed = 1) ``` ```{r fig=TRUE} -geo.zoomin(c(90,150,18,-25)) +geo.zoomin(c(90, 150, 18, -25)) title("Different connected components\n in worldgraph.10k") ``` @@ -722,7 +723,7 @@ paths between Addis abeba and the populations of `hgdp`: ```{r } myGraph <- dropCosts(worldgraph.40k) hgdp@gGraph.name <- "myGraph" -addis <- cbind(38,9) +addis <- cbind(38, 9) ori <- closestNode(myGraph, addis) paths <- dijkstraFrom(hgdp, ori) ``` @@ -730,11 +731,11 @@ The object `paths` contains the identified paths, which are stored as a list wit Paths can be plotted easily: ```{r fig=TRUE, fig.width = 8} addis <- as.vector(addis) -plot(myGraph, col=NA, reset=TRUE) +plot(myGraph, col = NA, reset = TRUE) plot(paths) -points(addis[1], addis[2], pch="x", cex=2) -text(addis[1]+35, addis[2], "Addis abeba", cex=.8, font=2) -points(hgdp, col.node="black") +points(addis[1], addis[2], pch = "x", cex = 2) +text(addis[1] + 35, addis[2], "Addis abeba", cex = .8, font = 2) +points(hgdp, col.node = "black") ``` In this graph, each path is plotted with a different color, but several paths overlap in several places. @@ -742,10 +743,10 @@ We can extract the distances from the `origin' using `gPath2dist`, and then exam relationship between genetic diversity within populations (stored in `hgdp`) and the distance from the origin: ```{r fig=TRUE} div <- getData(hgdp)$"Genetic.Div" -dgeo.unif <- gPath2dist(paths, res.type="vector") -plot(div~dgeo.unif, xlab="GeoGraphic distance (arbitrary units)", ylab="Genetic diversity") -lm.unif <- lm(div~dgeo.unif) -abline(lm.unif, col="red") +dgeo.unif <- gPath2dist(paths, res.type = "vector") +plot(div ~ dgeo.unif, xlab = "GeoGraphic distance (arbitrary units)", ylab = "Genetic diversity") +lm.unif <- lm(div ~ dgeo.unif) +abline(lm.unif, col = "red") summary(lm.unif) title("Genetic diversity vs geographic distance \n uniform costs ") ``` @@ -756,26 +757,26 @@ As a toy example, we will consider that coasts are four times more favourable fo the rest of the landmasses. We define these new costs, and then compute and plot the corresponding shortest paths: ```{r } -myGraph@meta$costs[7,] <- c("coast", 0.25) +myGraph@meta$costs[7, ] <- c("coast", 0.25) myGraph@meta$costs -myGraph <- setCosts(myGraph, attr.name="habitat") +myGraph <- setCosts(myGraph, attr.name = "habitat") paths.2 <- dijkstraFrom(hgdp, ori) ``` ```{r fig=TRUE, fig.width = 8} -plot(newGraph, col=NA, reset=TRUE) +plot(newGraph, col = NA, reset = TRUE) plot(paths.2) -points(addis[1], addis[2], pch="x", cex=2) -text(addis[1]+35, addis[2], "Addis abeba", cex=.8, font=2) -points(hgdp, col.node="black") +points(addis[1], addis[2], pch = "x", cex = 2) +text(addis[1] + 35, addis[2], "Addis abeba", cex = .8, font = 2) +points(hgdp, col.node = "black") ``` The new paths are slightly different from the previous ones. We can examine the new relationship with genetic distance: ```{r fig=TRUE} -dgeo.hab <- gPath2dist(paths.2, res.type="vector") -plot(div~dgeo.hab, xlab="GeoGraphic distance (arbitrary units)", ylab="Genetic diversity") -lm.hab <- lm(div~dgeo.hab) -abline(lm.hab, col="red") +dgeo.hab <- gPath2dist(paths.2, res.type = "vector") +plot(div ~ dgeo.hab, xlab = "GeoGraphic distance (arbitrary units)", ylab = "Genetic diversity") +lm.hab <- lm(div ~ dgeo.hab) +abline(lm.hab, col = "red") summary(lm.hab) title("Genetic diversity vs geographic distance \n habitat costs ") ```