#' Dissolve
#' @description Acts like a spatial dissolve within a GIS environment. Simplifies a river network object by combining "runs" of segments with no other connections.
#' @param rivers The river network object to use
#' @return A new river network object with segments combined
#' @seealso line2network
#' @note This function is called within \link{cleanup}, which is recommended in most cases.
#' @author Matt Tyers
#' @examples
#' data(Kenai2)
#' plot(x=Kenai2)
#'
#' Kenai2dissolve <- dissolve(rivers=Kenai2)
#' plot(x=Kenai2dissolve)
#' @importFrom methods new
#' @export
dissolve <- function(rivers) {
if(!inherits(rivers, "rivernetwork")) stop("Argument 'rivers' must be of class 'rivernetwork'. See help(line2network) for more information.")
tolerance <- rivers$tolerance
lines <- rivers$lines
connections <- rivers$connections
length <- length(lines)
if(!is.na(rivers$mouth$mouth.seg) & !is.na(rivers$mouth$mouth.vert)) {
mouthcoords <- rivers$lines[[rivers$mouth$mouth.seg]][rivers$mouth$mouth.vert,]
}
#internal functions
n.top <- function(seg,connections) {
return(length(connections[seg,][(connections[seg,]==1 | connections[seg,]==2 | connections[seg,]==5 | connections[seg,]==6) & is.na(connections[seg,])==F]))
}
n.bot <- function(seg,connections) {
return(length(connections[seg,][(connections[seg,]==3 | connections[seg,]==4 | connections[seg,]==5 | connections[seg,]==6) & is.na(connections[seg,])==F]))
}
who.top <- function(seg,connections) {
return(which((connections[seg,]==1 | connections[seg,]==2 | connections[seg,]==5 | connections[seg,]==6) & is.na(connections[seg,])==F))
}
who.bot <- function(seg,connections) {
return(which((connections[seg,]==3 | connections[seg,]==4 | connections[seg,]==5 | connections[seg,]==6) & is.na(connections[seg,])==F))
}
# the first big algorithm, it detects "runs" of segments. this is what we ultimately want to combine.
runs <- list(0)
run.i <- 0
used <- rep(F,length)
for(seg in 1:length) {
if(((n.top(seg,connections) != 1) | (n.bot(seg,connections) != 1)) & !used[seg]) {
used[seg] <- T
run.i <- run.i+1
run.done <- F
runs[[run.i]] <- seg
i <- 1
if(n.top(seg,connections) != 1) nextone<-"bot"
if(n.bot(seg,connections) != 1) nextone<-"top"
#take the first one out of avail
while(!run.done) {
if(nextone=="top" & n.top(runs[[run.i]][[i]],connections)!=1) run.done<-T
if(nextone=="bot" & n.bot(runs[[run.i]][[i]],connections)!=1) run.done<-T
if(nextone=="top" & n.top(runs[[run.i]][i],connections)==1) {
i <- i+1
runs[[run.i]][i] <- who.top(runs[[run.i]][i-1],connections)
if(n.top(runs[[run.i]][i],connections)==1) {
if(who.top(runs[[run.i]][i],connections)==runs[[run.i]][i-1]) nextnext <- "bot"
}
if(n.bot(runs[[run.i]][i],connections)==1) {
if(who.bot(runs[[run.i]][i],connections)==runs[[run.i]][i-1]) nextnext <- "top"
}
}
if(nextone=="bot" & n.bot(runs[[run.i]][i],connections)==1) {
i <- i+1
runs[[run.i]][i] <- who.bot(runs[[run.i]][i-1],connections)
if(n.top(runs[[run.i]][i],connections)==1) {
if(who.top(runs[[run.i]][i],connections)==runs[[run.i]][i-1]) nextnext <- "bot"
}
if(n.bot(runs[[run.i]][i],connections)==1) {
if(who.bot(runs[[run.i]][i],connections)==runs[[run.i]][i-1]) nextnext <- "top"
}
}
if(!run.done) nextone <- nextnext
if(run.done) used[runs[[run.i]][length(runs[[run.i]])]] <- T
}
}
}
# the second big algorithm, it uses the information from the "runs" detected and combines where applicable
newlines <- list()
for(run.i in 1:length(runs)) {
newlines[[run.i]] <- lines[[runs[[run.i]][1]]]
if(length(runs[[run.i]]) > 1) {
for(i in 2:length(runs[[run.i]])) {
if(connections[runs[[run.i]][i-1],runs[[run.i]][i]]==1) {
len <- dim(newlines[[run.i]])[1]
newlines[[run.i]] <- rbind(newlines[[run.i]][len:1,],lines[[runs[[run.i]][i]]])
}
if(connections[runs[[run.i]][i-1],runs[[run.i]][i]]==3) {
newlines[[run.i]] <- rbind(newlines[[run.i]],lines[[runs[[run.i]][i]]])
}
if(connections[runs[[run.i]][i-1],runs[[run.i]][i]]==2) {
len <- dim(newlines[[run.i]])[1]
newlines[[run.i]] <- rbind(lines[[runs[[run.i]][i]]],newlines[[run.i]])
}
if(connections[runs[[run.i]][i-1],runs[[run.i]][i]]==4) {
len <- dim(newlines[[run.i]])[1]
newlines[[run.i]] <- rbind(lines[[runs[[run.i]][i]]],newlines[[run.i]][len:1,])
}
}
}
}
# updating the connectivity matrix with the new segments
length <- length(newlines)
connections <- calculateconnections(lines=newlines, tolerance=tolerance)
# updating lengths
lengths <- rep(NA,length)
for(i in 1:length) {
lengths[i] <- pdisttot(newlines[[i]])
}
#updating rivers object
rivers1 <- rivers
rivers1$sequenced <- F
rivers1$names <- rep(NA,length)
rivers1$lines <- newlines
if(!is.na(rivers$mouth$mouth.seg) & !is.na(rivers$mouth$mouth.vert)) {
for(i in 1:length(rivers1$lines)) {
for(j in 1:(dim(rivers1$lines[[i]])[1])) {
if(all(mouthcoords==rivers1$lines[[i]][j,])) {
rivers1$mouth$mouth.seg <- i
rivers1$mouth$mouth.vert <- j
}
}
}
}
rivers1$connections <- connections
if(any(connections %in% 5:6)) rivers1$braided <- TRUE
rivers1$lengths <- lengths
# Id <- 0
# rivers1$sp@data <- data.frame(Id)
# rivers1$sp@lines <- list(rivers$sp@lines[[1]])
# rivers1$sp@lines[[1]]@Lines <- list(rivers1$sp@lines[[1]]@Lines[[1]])
# for(i in 1:length) {
# rivers1$sp@lines[[1]]@Lines[[i]] <- new("Line",coords = rivers1$lines[[i]])
# }
#
# rivID <- 1:length
# sp_line <- rep(1,length)
# sp_seg <- 1:length
# rivers1$lineID <- data.frame(rivID,sp_line,sp_seg)
rivers1 <- update_sf(rivers1)
if(!is.na(rivers1$mouth$mouth.seg) & !is.na(rivers1$mouth$mouth.vert)) {
if(rivers1$mouth$mouth.vert > 1 & rivers1$mouth$mouth.vert < dim(rivers1$lines[[rivers1$mouth$mouth.seg]])[1]) {
suppressMessages(rivers1 <- splitsegmentat(seg=rivers1$mouth$mouth.seg, vert=rivers1$mouth$mouth.vert, rivers=rivers1))
}
}
if(!is.null(rivers1$segroutes)) {
rivers1 <- buildsegroutes(rivers1,lookup=F)
}
rivers1 <- addcumuldist(rivers1)
if(!is.null(rivers1$distlookup)) rivers1 <- buildlookup(rivers1)
message("Note: any point data already using the input river network must be re-transformed to river coordinates using xy2segvert() or ptshp2segvert().")
return(rivers1)
}
#' Zoom to segment
#' @description Calls \link{plot.rivernetwork} and automatically zooms to a specified
#' segment or vector of segments. Not intended for any real mapping - just
#' investigating and error checking.
#' @param seg A segment or vector of segments to zoom to
#' @param rivers The river network object to use
#' @param ... Additional plotting arguments (see \link[graphics]{par})
#' @author Matt Tyers
#' @examples
#' data(Kenai3)
#' plot(x=Kenai3)
#'
#' # checking out a particularly messy region...
#' zoomtoseg(c(110,63), rivers=Kenai3)
#' @importFrom graphics plot
#' @export
zoomtoseg <- function(seg,rivers,...) {
if(!inherits(rivers, "rivernetwork")) stop("Argument 'rivers' must be of class 'rivernetwork'. See help(line2network) for more information.")
if(max(seg,na.rm=T)>length(rivers$lines) | min(seg,na.rm=T)<1) stop("Invalid segment numbers specified.")
coords <- rivers$lines[[seg[1]]]
if(length(seg)>1) {
for(i in 2:length(seg)) {
coords <- rbind(coords,rivers$lines[[seg[i]]])
}
}
x <- coords[,1]
y <- coords[,2]
minx <- min(x)
maxx <- max(x)
miny <- min(y)
maxy <- max(y)
plot(x=rivers,xlim=c(minx,maxx),ylim=c(miny,maxy),...=...)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.