Nothing
R/apps_of_riverdistance.R
In riverdist: River Network Distance Computation and Applications
Defines functions
riverdistancetofrom
print.homerange
plothomerangeoverlap
homerangeoverlap
plot.homerange
riverdistancemat
riverdistancematbysurvey
riverdistanceseq
Documented in
homerangeoverlap
plot.homerange
plothomerangeoverlap
riverdistancemat
riverdistancematbysurvey
riverdistanceseq
riverdistancetofrom
#' River Distance Between Sequential Observations
#' @description Returns a matrix of distances traveled by unique fish, between
#' sequential surveys. A plotting method is also provided for the output; see \link{plotseq}
#' @param unique A vector of identifiers for each fish.
#' @param survey A vector of identifiers for each survey. It is recommended to use a numeric or date format (see \link{as.Date}) to preserve survey order.
#' @param seg A vector of river locations (segment component).
#' @param vert A vector of river locations (vertex component).
#' @param rivers The river network object to use.
#' @param logical A boolean vector that can be used for subsetting. If used,
#' \code{riverdistanceseq()} will only return pairwise distances in which a
#' specified condition is met.
#' @param stopiferror Whether or not to exit with an error if a route cannot be
#' found. If this is set to \code{FALSE} and a route cannot be found,
#' the function will return \code{NA} in the appropriate entry. Defaults to \code{TRUE}. See \link{detectroute}.
#' @param algorithm Which route detection algorithm to use (\code{"Dijkstra"},
#' \code{"sequential"}, or \code{"segroutes"}). If left as \code{NULL} (the
#' default), the function will automatically make a selection. See
#' \link{detectroute} for more details.
#' @return A data frame of distances (numeric), with rows defined by unique fish and columns defined by observation increment (1 to 2, 2 to 3, etc.)
#' @seealso \link{riverdistance}, \link{plotseq}
#' @note Building routes from the river mouth to each river network segment and/or distance lookup tables will
#' greatly reduce computation time (see \link{buildsegroutes}).
#' @author Matt Tyers
#' @examples
#' data(Gulk, fakefish)
#' riverdistanceseq(unique=fakefish$fish.id, survey=fakefish$flight,
#' seg=fakefish$seg, vert=fakefish$vert, rivers=Gulk)
#'
#' seqbysurvey <- riverdistanceseq(unique=fakefish$fish.id, survey=fakefish$flight.date,
#' seg=fakefish$seg, vert=fakefish$vert, rivers=Gulk)
#' seqbysurvey
#' plotseq(seqbysurvey)
#' @export
riverdistanceseq <- function(unique,survey,seg,vert,rivers,logical=NULL,stopiferror=TRUE,algorithm=NULL) {
if(!inherits(rivers, "rivernetwork")) stop("Argument 'rivers' must be of class 'rivernetwork'. See help(line2network) for more information.")
if(is.null(logical)) logical <- rep(T,length(unique))
unique<-unique[logical]
survey<-survey[logical]
seg<-seg[logical]
vert<-vert[logical]
tab <- table(unique,survey)
if(max(tab)>1) cat("Warning: multiple entries exist for at least one unique/survey combination (first one used)")
dists <- matrix(NA,nrow=dim(tab)[1],ncol=(dim(tab)[2]-1))
for(i in 1:dim(tab)[1]) {
for(j in 1:(dim(tab)[2]-1)) {
if(tab[i,j]*tab[i,(j+1)]!=0) {
dists[i,j] <- riverdistance(startseg=seg[unique==sort(unique(unique))[i] & survey==sort(unique(survey))[j]][1],
endseg=seg[unique==sort(unique(unique))[i] & survey==sort(unique(survey))[j+1]][1],
startvert=vert[unique==sort(unique(unique))[i] & survey==sort(unique(survey))[j]][1],
endvert=vert[unique==sort(unique(unique))[i] & survey==sort(unique(survey))[j+1]][1],
rivers=rivers,stopiferror=stopiferror,algorithm=algorithm)
}
}
}
dists<-as.data.frame(dists)
row.names(dists) <- row.names(tab)
col.name<-NA
for(j in 1:(length(dimnames(tab)$survey)-1)) col.name[j] <- paste(dimnames(tab)$survey[j],"to",dimnames(tab)$survey[j+1])
names(dists) <- col.name
dists <- dists[rowSums(is.na(dists)) != ncol(dists),]
return(dists)
}
#' River Distance Matrix of All Observations of an Individual
#' @description Returns a matrix of network distances between all observations
#' of one unique fish.
#' @param indiv The unique identifier of the fish in question.
#' @param unique A vector of identifiers for each fish.
#' @param survey A vector of identifiers for each survey. It is recommended to
#' use a numeric or date format (see \link{as.Date}) to preserve survey order.
#' @param seg A vector of river locations (segment component).
#' @param vert A vector of river locations (vertex component).
#' @param rivers The river network object to use.
#' @param full Whether to return the full matrix, with \code{NA} values for
#' missing data (\code{TRUE}), or a the subset of rows and columns
#' corresponding to successful observations. Defaults to \code{TRUE}.
#' @param stopiferror Whether or not to exit with an error if a route cannot be
#' found. If this is set to \code{FALSE} and a route cannot be found, the
#' function will return \code{NA} in the appropriate entry. Defaults to
#' \code{TRUE}. See \link{detectroute}.
#' @param algorithm Which route detection algorithm to use (\code{"Dijkstra"},
#' \code{"sequential"}, or \code{"segroutes"}). If left as \code{NULL} (the
#' default), the function will automatically make a selection. See
#' \link{detectroute} for more details.
#' @return A matrix of distances (numeric), with rows and columns defined by
#' survey.
#' @seealso \link{riverdistance}
#' @note Building routes from the river mouth to each river network segment and/or distance lookup tables will
#' greatly reduce computation time (see \link{buildsegroutes}).
#' @author Matt Tyers
#' @examples
#' data(Gulk, fakefish)
#' riverdistancematbysurvey(indiv=1, unique=fakefish$fish.id, survey=fakefish$flight,
#' seg=fakefish$seg, vert=fakefish$vert, rivers=Gulk)
#'
#' riverdistancematbysurvey(indiv=1, unique=fakefish$fish.id, survey=fakefish$flight,
#' seg=fakefish$seg, vert=fakefish$vert, rivers=Gulk, full=FALSE)
#' @export
riverdistancematbysurvey <- function(indiv,unique,survey,seg,vert,rivers,full=TRUE,stopiferror=TRUE,algorithm=NULL) {
surveys <- sort(unique(survey))
surveys_indiv <- sort(unique(survey[unique==indiv]))
outmat <- matrix(NA,nrow=length(surveys),ncol=length(surveys))
for(ii in 1:length(surveys)) {
for(jj in 1:length(surveys)) {
outmat[ii,jj] <- ifelse((length(seg[unique==indiv & survey==surveys[ii]])==0) | (length(seg[unique==indiv & survey==surveys[jj]])==0),NA,
riverdistance(startseg=seg[unique==indiv & survey==surveys[ii]], endseg=seg[unique==indiv & survey==surveys[jj]],
startvert=vert[unique==indiv & survey==surveys[ii]], endvert=vert[unique==indiv & survey==surveys[jj]],
rivers=rivers,stopiferror=stopiferror,algorithm=algorithm))
}
}
dimnames(outmat)[[1]] <- dimnames(outmat)[[2]] <- as.character(surveys)
if(!full) {
if(!all(is.na(outmat))) {
whichnotna <- NA
iwhichnotna <- 1
for(i in 1:dim(outmat)[1]) {
if(!all(is.na(outmat[,i]))) {
whichnotna[iwhichnotna] <- i
iwhichnotna <- iwhichnotna+1
}
}
outmat <- outmat[whichnotna,whichnotna]
}
if(all(is.na(outmat))) outmat <- NA
}
return(outmat)
}
#' River Distance Matrix
#' @description Returns a matrix of distances between every point and every
#' other point of given river locations (segment and vertex), or of a subset.
#' @param seg A vector of river locations (segment component).
#' @param vert A vector of river locations (vertex component).
#' @param rivers The river network object to use.
#' @param logical A boolean vector that can be used for subsetting. If used,
#' \code{riverdistancemat} will only return pairwise distances in which a
#' specified condition is met.
#' @param ID a vector of observation IDs for aid in interpreting the output
#' table
#' @param stopiferror Whether or not to exit with an error if a route cannot be
#' found. If this is set to \code{FALSE} and a route cannot be found,
#' the function will return \code{NA} in the appropriate entry. Defaults to \code{TRUE}. See \link{detectroute}
#' @param algorithm Which route detection algorithm to use (\code{"Dijkstra"},
#' \code{"sequential"}, or \code{"segroutes"}). If left as \code{NULL} (the
#' default), the function will automatically make a selection. See
#' \link{detectroute} for more details.
#' @return A matrix of distances (numeric) with rows and columns labeled by corresponding values of \code{ID}.
#' @seealso \link{riverdistance}
#' @note Building routes from the river mouth to each river network segment and/or distance lookup tables will
#' greatly reduce computation time (see \link{buildsegroutes}).
#' @author Matt Tyers
#' @examples
#' data(Gulk, fakefish)
#'
#' logi1 <- (fakefish$flight.date==as.Date("2015-11-25"))
#'
#' riverdistancemat(seg=fakefish$seg, vert=fakefish$vert, rivers=Gulk, logical=logi1)
#' @export
riverdistancemat <- function(seg,vert,rivers,logical=NULL,ID=NULL,stopiferror=TRUE,algorithm=NULL) {
if(!inherits(rivers, "rivernetwork")) stop("Argument 'rivers' must be of class 'rivernetwork'. See help(line2network) for more information.")
if(is.null(logical)) logical <- rep(T,length(unique))
len <- length(vert)
seg<-seg[logical]
vert<-vert[logical]
if(is.null(ID)) ID <- 1:len
ID <- ID[logical]
dists <- matrix(NA,nrow=length(vert),ncol=length(vert))
for(i in 1:length(vert)) {
for(j in 1:length(vert)) {
dists[i,j] <- riverdistance(startseg=seg[i],endseg=seg[j],startvert=vert[i],endvert=vert[j],rivers=rivers,
stopiferror=stopiferror,algorithm=algorithm)
}
}
dimnames(dists)[[1]] <- dimnames(dists)[[2]] <- ID
return(dists)
}
#' Home Range
#' @description Returns the minimum observed home range for multiple
#' observations of each individual fish.
#' @param unique A vector of unique identifiers for each fish. If the default (\code{NULL}) is used, the function will assume all observations come from a single individual.
#' @param survey A vector of survey identifiers for each fish. This argument is not needed for home range calculation, but can affect plotting (see \link{plot.homerange}).
#' @param seg A vector of river locations (segment component).
#' @param vert A vector of river locations (vertex component).
#' @param rivers The river network object to use.
#' @param map Deprecated, use \link{plot.homerange} for plotting instead. Originally, whether to produce sanity-check maps
#' of observed locations and calculated home range for each fish.
#' @param algorithm Which route detection algorithm to use (\code{"Dijkstra"},
#' \code{"sequential"}, or \code{"segroutes"}). If left as \code{NULL} (the
#' default), the function will automatically make a selection. See
#' \link{detectroute} for more details.
#' @param main Deprecated, use \link{plot.homerange} for plotting instead. Originally, plot title, if \code{map} is set to \code{TRUE}. If unspecified, the unique ID will be used for the title.
#' @param ... Deprecated, use \link{plot.homerange} for plotting instead. Originally, additional plotting arguments, if \code{map} is set to \code{TRUE}.
#' @return An object of the \link{homerange-class}. The \code{$ranges} element is a data frame with two columns: \code{$ID} is a list of unique fish
#' (as specified by \code{unique=}), and \code{$range} is calculated minimum
#' home range, in the units of the coordinate system (this will likely be
#' meters). The other elements are used for plotting, see \link{homerange-class} for more details.
#' @note Building routes from the river mouth to each river network segment and/or distance lookup tables will
#' greatly reduce computation time (see \link{buildsegroutes}).
#' @seealso \link{plot.homerange}, \link{homerangeoverlap}, \link{plothomerangeoverlap}
#' @author Matt Tyers
#' @examples
#' data(Gulk, fakefish)
#' ranges <- with(fakefish, homerange(unique=fish.id, survey=flight, seg=seg, vert=vert, rivers=Gulk))
#' ranges
#'
#' # 19 plots will be produced, recommend calling par(mfrow=c(4,5))
#' plot(ranges)
#' plot(ranges,cumulative=TRUE,label=TRUE)
#'
#' homerangeoverlap(ranges)
#'
#' plothomerangeoverlap(ranges)
#' with(fakefish, riverpoints(seg=seg, vert=vert, rivers=Gulk))
#' @importFrom graphics plot
#' @importFrom graphics lines
#' @export
homerange <- function (unique=NULL, survey=NULL, seg, vert, rivers, map = FALSE, algorithm = NULL,
main = NULL, ...)
{
if (!inherits(rivers, "rivernetwork"))
stop("Argument 'rivers' must be of class 'rivernetwork'. See help(line2network) for more information.")
if(is.null(unique)) unique <- rep(1,length(seg))
if ((length(unique) != length(seg)) | (length(seg) != length(vert)))
stop("Input vectors must be the same length.")
if(!missing(map)) warning("Argument map= is deprecated. Use plot() instead, on the object returned from homerange().")
if(is.null(survey)) survey1 <- 1:length(seg)
else survey1 <- survey
ID <- sort(unique(unique))
range <- rep(0, length(ID))
alllengths <- function(xy) {
n <- dim(xy)[1]
if (n == 1)
dist <- 0
if (n == 2)
dist <- pdist(xy[1, ], xy[2, ])
if (n > 2)
dist <- sqrt(((xy[1:(n - 1), 1] - xy[2:n, 1])^2) +
((xy[1:(n - 1), 2] - xy[2:n, 2])^2))
return(dist)
}
subseg_length <- list()
for (i in 1:length(rivers$lines)) {
subseg_length[[i]] <- alllengths(rivers$lines[[i]])
}
subseg_n <- list()
for (i in 1:length(ID)) {
subseg_n[[i]] <- list()
if (map == T) {
if (is.null(main)) {
main1 <- ID[i]
}
else {
main1 <- main
}
plot(x = rivers, main = main1, color = F, segmentnum = F,
... = ...)
}
n.entries <- length(unique[unique == ID[i]])
if (n.entries > 1) {
seg1 <- (seg[unique == ID[i]])[order(survey1[unique==ID[i]])]
vert1 <- (vert[unique == ID[i]])[order(survey1[unique==ID[i]])]
routes <- NA
routes <- list()
vert2 <- NA
vert2 <- list()
for (jj in 1:(n.entries-1)) {
routes[[jj]] <- detectroute(start = seg1[jj], end = seg1[jj+1], rivers = rivers, algorithm = algorithm)
vert2[[jj]] <- c(vert1[jj], vert1[jj+1])
}
seg.rep.max2 <- rep(0, length(rivers$lines))
for (j in 1:length(rivers$lines)) {
linelength <- dim(rivers$lines[[j]])[1]
subseg_n[[i]][[j]] <- rep(0, length(subseg_length[[j]]))
for (k in 1:length(routes)) {
if (length(routes[[k]][routes[[k]] == j]) >
0) {
if (length(routes[[k]]) > 2 & routes[[k]][1] !=
j & routes[[k]][length(routes[[k]])] !=
j) {
if (map)
lines(rivers$lines[[j]], col = 4, lwd = 3)
subseg_n[[i]][[j]] <- subseg_n[[i]][[j]]+1
}
if (length(routes[[k]]) == 1) {
if (vert2[[k]][1] != vert2[[k]][2]) {
subseg_n[[i]][[j]][min((linelength - 1), min(vert2[[k]])):(max(vert2[[k]]) - 1)] <- subseg_n[[i]][[j]][min((linelength - 1), min(vert2[[k]])):(max(vert2[[k]]) - 1)]+1
if (map)
lines(rivers$lines[[j]][(vert2[[k]][1]:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
}
if (routes[[k]][1] == j & length(routes[[k]]) >
1) {
if (rivers$connections[routes[[k]][1],
routes[[k]][[2]]] <= 2) {
if (vert2[[k]][1] > 1) subseg_n[[i]][[j]][1:(vert2[[k]][1] - 1)] <- subseg_n[[i]][[j]][1:(vert2[[k]][1] - 1)]+1
if (map)
lines(rivers$lines[[j]][(1:vert2[[k]][1]),
, drop = F], col = 4, lwd = 3)
}
if (any(rivers$connections[routes[[k]][1],
routes[[k]][[2]]] == 3:4)) {
if (vert2[[k]][1] < linelength) {
subseg_n[[i]][[j]][(vert2[[k]][1]):(linelength - 1)] <- subseg_n[[i]][[j]][(vert2[[k]][1]):(linelength - 1)]+1
}
if (map)
lines(rivers$lines[[j]][(vert2[[k]][1]):linelength,
, drop = F], col = 4, lwd = 3)
}
if (length(routes[[k]] == 2) & rivers$connections[j,
routes[[k]][2]] == 5) {
d1 <- rivers$cumuldist[[j]][vert2[[k]][1]] +
rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]]
d2 <- (rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][1]]) +
(rivers$lengths[routes[[k]][2]] - rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]])
if (d1 <= d2) {
if (vert2[[k]][1] > 1) subseg_n[[i]][[j]][1:(vert2[[k]][1] - 1)] <- subseg_n[[i]][[j]][1:(vert2[[k]][1] - 1)]+1
if (map)
lines(rivers$lines[[j]][(vert2[[k]][1]:1),
, drop = F], col = 4, lwd = 3)
}
else {
if (vert2[[k]][1] < linelength) {
subseg_n[[i]][[j]][(vert2[[k]][1]):(linelength - 1)] <- subseg_n[[i]][[j]][(vert2[[k]][1]):(linelength - 1)]+1
}
if (map)
lines(rivers$lines[[j]][(vert2[[k]][1]:linelength),
, drop = F], col = 4, lwd = 3)
}
}
if (length(routes[[k]] == 2) & rivers$connections[j,
routes[[k]][2]] == 6) {
d1 <- rivers$cumuldist[[j]][vert2[[k]][1]] +
(rivers$lengths[routes[[k]][2]] - rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]])
d2 <- (rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][1]]) +
rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]]
if (d1 <= d2) {
if (vert2[[k]][1] > 1) subseg_n[[i]][[j]][1:(vert2[[k]][1] - 1)] <- subseg_n[[i]][[j]][1:(vert2[[k]][1] - 1)]+1
if (map)
lines(rivers$lines[[j]][(vert2[[k]][1]:1),
, drop = F], col = 4, lwd = 3)
}
else {
if (vert2[[k]][1] < linelength) {
subseg_n[[i]][[j]][(vert2[[k]][1]):(linelength - 1)] <- subseg_n[[i]][[j]][(vert2[[k]][1]):(linelength - 1)]+1
}
if (map)
lines(rivers$lines[[j]][(vert2[[k]][1]:linelength),
, drop = F], col = 4, lwd = 3)
}
}
}
if (routes[[k]][length(routes[[k]])] == j &
length(routes[[k]]) > 1) {
if (rivers$connections[routes[[k]][length(routes[[k]])],
routes[[k]][[length(routes[[k]]) - 1]]] <=
2) {
if (vert2[[k]][2] > 1) subseg_n[[i]][[j]][1:(vert2[[k]][2] - 1)] <- subseg_n[[i]][[j]][1:(vert2[[k]][2] - 1)]+1
if (map)
lines(rivers$lines[[j]][(1:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
if (any(rivers$connections[routes[[k]][length(routes[[k]])],
routes[[k]][[length(routes[[k]]) - 1]]] ==
3:4)) {
if (vert2[[k]][2] < linelength) {
subseg_n[[i]][[j]][(vert2[[k]][2]):(linelength - 1)] <- subseg_n[[i]][[j]][(vert2[[k]][2]):(linelength - 1)]+1
}
if (map)
lines(rivers$lines[[j]][(linelength:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
if (length(routes[[k]] == 2) & rivers$connections[routes[[k]][1],
routes[[k]][2]] == 5) {
d1 <- rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]] +
rivers$cumuldist[[j]][vert2[[k]][2]]
d2 <- (rivers$lengths[routes[[k]][1]] -
rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]]) +
(rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][2]])
if (d1 <= d2) {
if (vert2[[k]][2] > 1) subseg_n[[i]][[j]][1:(vert2[[k]][2] - 1)] <- subseg_n[[i]][[j]][1:(vert2[[k]][2] - 1)]+1
if (map)
lines(rivers$lines[[j]][(1:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
else {
if (vert2[[k]][2] < linelength) {
subseg_n[[i]][[j]][(vert2[[k]][2]):(linelength - 1)] <- subseg_n[[i]][[j]][(vert2[[k]][2]):(linelength - 1)]+1
}
if (map)
lines(rivers$lines[[j]][(linelength:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
}
if (length(routes[[k]] == 2) & rivers$connections[routes[[k]][1],
routes[[k]][2]] == 6) {
d1 <- (rivers$lengths[routes[[k]][1]] -
rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]]) +
rivers$cumuldist[[j]][vert2[[k]][2]]
d2 <- rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]] +
(rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][2]])
if (d1 <= d2) {
if (vert2[[k]][2] > 1) subseg_n[[i]][[j]][1:(vert2[[k]][2] - 1)] <- subseg_n[[i]][[j]][1:(vert2[[k]][2] - 1)]+1
if (map)
lines(rivers$lines[[j]][(1:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
else {
if (vert2[[k]][2] < linelength) {
subseg_n[[i]][[j]][(vert2[[k]][2]):(linelength - 1)] <- subseg_n[[i]][[j]][(vert2[[k]][2]):(linelength - 1)]+1
}
if (map)
lines(rivers$lines[[j]][(linelength:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
}
}
}
}
seg.rep.max2[j] <- sum((subseg_n[[i]][[j]]>0) * subseg_length[[j]])
}
range[i] <- sum(seg.rep.max2)
}
if (map)
riverpoints(seg = seg[unique == ID[i]], vert = vert[unique ==
ID[i]], rivers = rivers, pch = 15, col = 4)
names(subseg_n)[i] <- ID[i]
}
thing <- data.frame(ID, range)
thing2 <- subset(thing, range > 0)
out <- list(ranges=thing2,subseg_n=subseg_n,subseg_length=subseg_length,seg=seg,vert=vert,unique=unique,survey=survey,rivers=rivers)
class(out) <- "homerange"
return(out)
}
# homerange <- function(unique=NULL,seg,vert,rivers,map=FALSE,algorithm=NULL,main=NULL,...) {
# if(!inherits(rivers, "rivernetwork")) stop("Argument 'rivers' must be of class 'rivernetwork'. See help(line2network) for more information.")
# if(is.null(unique)) unique <- rep(1,length(seg))
# if((length(unique)!=length(seg))|(length(seg)!=length(vert))) stop("Input vectors must be the same length.")
# ID <- sort(unique(unique))
# range <- rep(0,length(ID))
#
# alllengths <- function(xy) {
# n <- dim(xy)[1]
# if(n==1) dist <- 0
# if(n==2) dist <- pdist(xy[1,],xy[2,])
# if(n>2) dist <- sqrt(((xy[1:(n-1),1] - xy[2:n,1])^2) + ((xy[1:(n-1),2] - xy[2:n,2])^2))
# return(dist)
# }
# subseglength <- list()
# for(i in 1:length(rivers$lines)) {
# subseglength[[i]] <- alllengths(rivers$lines[[i]])
# }
#
# for(i in 1:length(ID)) {
# # i <- 7
# if(map==T) {
# if(is.null(main)) {
# main1 <- ID[i]
# } else{
# main1 <- main
# }
# plot(x=rivers,main=main1,color=F,segmentnum=F,...=...)
# }
#
# n.entries <- length(unique[unique==ID[i]])
# if(n.entries>1) {
# # create a list of routes taken for fish i
# seg1 <- seg[unique==ID[i]]
# vert1 <- vert[unique==ID[i]]
# routes <- NA
# routes <- list()
# vert2 <- NA
# vert2 <- list()
# for(j in 1:n.entries) {
# for(k in 1:n.entries) {
# routes[[((j-1)*n.entries+k)]] <- detectroute(start=seg1[j],end=seg1[k],rivers=rivers,algorithm=algorithm)
# vert2[[((j-1)*n.entries+k)]] <- c(vert1[j],vert1[k])
# }
# }
# seg.rep.max2 <- rep(0,length(rivers$lines))
#
#
# # calculate amounts of each segment represented in each route
# for(j in 1:length(rivers$lines)) { # segment j
# linelength <- dim(rivers$lines[[j]])[1]
#
# subsegused <- rep(F,length(subseglength[[j]]))
#
# for(k in 1:length(routes)) { # route k
#
# # if segment j shows up in route k
# if(length(routes[[k]][routes[[k]]==j])>0) {
#
# #middle
# if(length(routes[[k]])>2 & routes[[k]][1]!=j & routes[[k]][length(routes[[k]])]!=j) {
# if(map) lines(rivers$lines[[j]],col=4,lwd=3)
# subsegused[] <- T
# }
#
# #only
# if(length(routes[[k]])==1) {
# if(vert2[[k]][1] != vert2[[k]][2]) {
# subsegused[min((linelength-1),min(vert2[[k]])):(max(vert2[[k]])-1)] <- T
# if(map) lines(rivers$lines[[j]][(vert2[[k]][1]:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# }
# }
#
# #beginning
# if(routes[[k]][1]==j & length(routes[[k]])>1) {
# # connected at beginning
# if(rivers$connections[routes[[k]][1],routes[[k]][[2]]]<=2) {
# subsegused[1:(vert2[[k]][1]-1)] <- T
# if(map) lines(rivers$lines[[j]][(1:vert2[[k]][1]),,drop=F],col=4,lwd=3)
# }
# # connected at end
# if(any(rivers$connections[routes[[k]][1],routes[[k]][[2]]]==3:4)) {
# if(vert2[[k]][1] < linelength) subsegused[(vert2[[k]][1]):(linelength-1)] <- T
# if(map) lines(rivers$lines[[j]][(vert2[[k]][1]):linelength,,drop=F],col=4,lwd=3)
# }
# #special braided case
# if(length(routes[[k]]==2) & rivers$connections[j,routes[[k]][2]]==5) {
# d1 <- rivers$cumuldist[[j]][vert2[[k]][1]] + rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]]
# d2 <- (rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][1]]) + (rivers$lengths[routes[[k]][2]] - rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]])
# if(d1 <= d2) {
# subsegused[1:(vert2[[k]][1]-1)] <- T
# if(map) lines(rivers$lines[[j]][(vert2[[k]][1]:1),,drop=F],col=4,lwd=3)
# } else {
# if(vert2[[k]][1] < linelength) subsegused[(vert2[[k]][1]):(linelength-1)] <- T
# if(map) lines(rivers$lines[[j]][(vert2[[k]][1]:linelength),,drop=F],col=4,lwd=3)
# }
# }
# if(length(routes[[k]]==2) & rivers$connections[j,routes[[k]][2]]==6) {
# d1 <- rivers$cumuldist[[j]][vert2[[k]][1]] + (rivers$lengths[routes[[k]][2]] - rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]])
# d2 <- (rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][1]]) + rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]]
# if(d1 <= d2) {
# subsegused[1:(vert2[[k]][1]-1)] <- T
# if(map) lines(rivers$lines[[j]][(vert2[[k]][1]:1),,drop=F],col=4,lwd=3)
# } else {
# if(vert2[[k]][1] < linelength) subsegused[(vert2[[k]][1]):(linelength-1)] <- T
# if(map) lines(rivers$lines[[j]][(vert2[[k]][1]:linelength),,drop=F],col=4,lwd=3)
# }
# }
# }
#
# #end
# if(routes[[k]][length(routes[[k]])]==j & length(routes[[k]])>1) {
# # connected at beginning
# if(rivers$connections[routes[[k]][length(routes[[k]])],routes[[k]][[length(routes[[k]])-1]]]<=2) {
# subsegused[1:(vert2[[k]][2]-1)] <- T
# if(map) lines(rivers$lines[[j]][(1:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# }
# # connected at end
# if(any(rivers$connections[routes[[k]][length(routes[[k]])],routes[[k]][[length(routes[[k]])-1]]]==3:4)) {
# if(vert2[[k]][2] < linelength) subsegused[(vert2[[k]][2]):(linelength-1)] <- T
# if(map) lines(rivers$lines[[j]][(linelength:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# }
#
# #special braided case
# if(length(routes[[k]]==2) & rivers$connections[routes[[k]][1],routes[[k]][2]]==5) {
# d1 <- rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]] + rivers$cumuldist[[j]][vert2[[k]][2]]
# d2 <- (rivers$lengths[routes[[k]][1]] - rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]]) + (rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][2]])
# if(d1 <= d2) {
# subsegused[1:(vert2[[k]][2]-1)] <- T
# if(map) lines(rivers$lines[[j]][(1:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# } else {
# if(vert2[[k]][2] < linelength) subsegused[(vert2[[k]][2]):(linelength-1)] <- T
# if(map) lines(rivers$lines[[j]][(linelength:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# }
# }
# if(length(routes[[k]]==2) & rivers$connections[routes[[k]][1],routes[[k]][2]]==6) {
# d1 <- (rivers$lengths[routes[[k]][1]] - rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]]) + rivers$cumuldist[[j]][vert2[[k]][2]]
# d2 <- rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]] + (rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][2]])
# if(d1 <= d2) {
# subsegused[1:(vert2[[k]][2]-1)] <- T
# if(map) lines(rivers$lines[[j]][(1:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# } else {
# if(vert2[[k]][2] < linelength) subsegused[(vert2[[k]][2]):(linelength-1)] <- T
# if(map) lines(rivers$lines[[j]][(linelength:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# }
# }
# }
# }
# }
# seg.rep.max2[j] <- sum(subsegused*subseglength[[j]])
# }
# range[i] <- sum(seg.rep.max2)
# }
# if(map) riverpoints(seg=seg[unique==ID[i]],vert=vert[unique==ID[i]],rivers=rivers,pch=15,col=4)
# }
#
# thing <- data.frame(ID,range)
# thing2 <- subset(thing,range>0)
# return(thing2)
# }
#' Plot Home Range
#' @description Plotting method for home range, the minimum observed home range for multiple
#' observations of each individual fish.
#' @param x An object returned from \link{homerange}.
#' @param cumulative Whether to plot travel as cumulative, with line thickness depending on the number of times a given region was traveled by a given individual. Defaults to \code{FALSE}.
#' @param lwd The line width for plotting homerange, or minimum line width if \code{cumulative} is \code{TRUE}. Defaults to 3.
#' @param maxlwd The maximum line width if \code{cumulative} is \code{TRUE}. Defaults to 10.
#' @param col The line color to use. Defaults to \code{"blue"}.
#' @param pch The point character to use for individual points. Defaults to open circles, the color of lines.
#' @param label Whether to add survey labels to individual points, if used in \link{homerange}. Defaults to \code{FALSE}.
#' @param main Plot title. If the default \code{NULL} is used, plots will be titled according to unique individual.
#' @param ... Additional plotting parameters, see \link{plot.rivernetwork}.
#' @seealso \link{homerange}, \link{homerangeoverlap}, \link{plothomerangeoverlap}
#' @author Matt Tyers, bug fix by Jordy Bernard
#' @examples
#' data(Gulk, fakefish)
#' ranges <- with(fakefish, homerange(unique=fish.id, survey=flight, seg=seg, vert=vert, rivers=Gulk))
#' ranges
#'
#' # 19 plots will be produced, recommend calling par(mfrow=c(4,5))
#' plot(ranges)
#' plot(ranges,cumulative=TRUE,label=TRUE)
#'
#' homerangeoverlap(ranges)
#'
#' plothomerangeoverlap(ranges)
#' with(fakefish, riverpoints(seg=seg, vert=vert, rivers=Gulk))
#' @importFrom graphics plot
#' @importFrom graphics lines
#' @export
plot.homerange <- function(x,cumulative=FALSE,lwd=3,maxlwd=10,col=4,pch=21,label=FALSE,main=NULL,...) {
if(is.null(x$survey) & cumulative) warning("Argument survey= will ensure points are chronological order. Entry order used.")
if(is.null(main)) mains <- names(x$subseg_n)
if(length(main)==1) mains <- rep(main,length(x$subseg_n))
if(length(main)>1) mains <- main
maxlwds <- max(unlist(x$subseg_n),na.rm=T)
lwdfactor <- ifelse(maxlwds==1,0,(maxlwd-lwd)/(maxlwds-1))
for(i in seq_along(x$subseg_n)) {
# print(mains)
plot(x$rivers,empty=T,main=mains[i],...=...)
for(j in seq_along(x$subseg_n[[i]])) {
a <- x$subseg_n[[i]][[j]]
if(!cumulative) a <- 1*(a>0)
n <- length(a)
firsts <- c(1,(which(a[-n]!=a[-1])+1))
lasts <- c(which(a[-n]!=a[-1]),n)
denses <- a[firsts]
for(k in seq_along(denses)) {
if(denses[k]>0){
if(!is.null(dim(x$rivers$lines[[j]][(firsts[k]:lasts[k]),]))){
lines(x$rivers$lines[[j]][(firsts[k]:lasts[k]),],lwd=(lwd+cumulative*(lwdfactor*denses[k]-1)),col=col)
}
}
}
}
riverpoints(seg=x$seg[x$unique==names(x$subseg_n)[i]],vert=x$vert[x$unique==names(x$subseg_n)[i]],rivers=x$rivers,pch=pch,bg="white",col=col)
if(label) {
segs <- x$seg[x$unique==names(x$subseg_n)[i]]
verts <- x$vert[x$unique==names(x$subseg_n)[i]]
texx <- texy <- rep(NA,length(segs))
for(k in 1:length(segs)) {
texx[k] <- x$rivers$lines[[segs[k]]][verts[k],1]
texy[k] <- x$rivers$lines[[segs[k]]][verts[k],2]
}
text(x=texx,y=texy,labels=x$survey[x$unique==names(x$subseg_n)[i]],pos=4,cex=1)
}
}
}
#' Home Range Overlap
#' @description Returns matrices describing the overlap of the minimum observed home range for multiple
#' observations of each individual fish.
#' @param x An object returned from \link{homerange}.
#' @return A list of three matrices, with \code{$either} giving the distances represented by the union of home ranges of each pair of individuals, and \code{$both} giving the distances represented by the intersection of home ranges of each pair of individuals. Element \code{$prop_both} gives the proportion of overlap, defined as intersection/union.
#' @seealso \link{homerange}, \link{plot.homerange}, \link{plothomerangeoverlap}
#' @author Matt Tyers
#' @examples
#' data(Gulk, fakefish)
#' ranges <- with(fakefish, homerange(unique=fish.id, survey=flight, seg=seg, vert=vert, rivers=Gulk))
#' ranges
#'
#' # 19 plots will be produced, recommend calling par(mfrow=c(4,5))
#' plot(ranges)
#' plot(ranges,cumulative=TRUE,label=TRUE)
#'
#' homerangeoverlap(ranges)
#'
#' plothomerangeoverlap(ranges)
#' with(fakefish, riverpoints(seg=seg, vert=vert, rivers=Gulk))
#' @export
homerangeoverlap <- function(x) {
if(!inherits(x, "homerange")) stop("Input must be of class homerange. See help(homerange) or help(homerange-class) for more details.")
n <- length(x$subseg_n)
either <- both <- matrix(0,nrow=n,ncol=n)
for(i in 1:n) {
for(j in 1:n) {
for(k in 1:length(x$subseg_length)) {
either[i,j] <- either[i,j] + sum(x$subseg_length[[k]]*(x$subseg_n[[i]][[k]]>0 | x$subseg_n[[j]][[k]]>0))
both[i,j] <- both[i,j] + sum(x$subseg_length[[k]]*(x$subseg_n[[i]][[k]]>0 & x$subseg_n[[j]][[k]]>0))
}
}
}
dimnames(either)[[1]] <- dimnames(either)[[2]] <- dimnames(both)[[1]] <- dimnames(both)[[2]] <- names(x$subseg_n)
return(list(either=either,both=both,prop_both=both/either))
}
#' Plot Home Range Overlap
#' @description Produces a plot of the overlap of the minimum observed home range for multiple
#' observations of each individual fish, with line thickness illustrating the respective number of individuals' homeranges represented.
#' @param x An object returned from \link{homerange}.
#' @param lwd Minimum line width to use, defaults to 3.
#' @param maxlwd Maximum line width to use, defaults to 10.
#' @param col Line color to use, defaults to \code{"blue"}.
#' @param ... Additional plotting parameters, see \link{plot.rivernetwork}.
#' @seealso \link{homerange}, \link{plot.homerange}, \link{homerangeoverlap}
#' @author Matt Tyers
#' @examples
#' data(Gulk, fakefish)
#' ranges <- with(fakefish, homerange(unique=fish.id, survey=flight, seg=seg, vert=vert, rivers=Gulk))
#' ranges
#'
#' # 19 plots will be produced, recommend calling par(mfrow=c(4,5))
#' plot(ranges)
#' plot(ranges,cumulative=TRUE,label=TRUE)
#'
#' homerangeoverlap(ranges)
#'
#' plothomerangeoverlap(ranges)
#' with(fakefish, riverpoints(seg=seg, vert=vert, rivers=Gulk))
#' @importFrom graphics plot
#' @importFrom graphics lines
#' @export
plothomerangeoverlap <- function(x,lwd=3,maxlwd=10,col=4,...) {
totsubsegs <- x$subseg_n[[1]]
for(j in 1:length(x$subseg_n[[1]])) {
totsubsegs[[j]][] <- 0
for(i in 1:length(x$subseg_n)) {
totsubsegs[[j]] <- totsubsegs[[j]] + (x$subseg_n[[i]][[j]]>0)
}
}
maxlwds <- max(unlist(totsubsegs),na.rm=T)
lwdfactor <- ifelse(maxlwds==1,0,(maxlwd-lwd)/(maxlwds-1))
plot(x=x$rivers,empty=T,...=...)
for(j in 1:length(totsubsegs)) {
a <- totsubsegs[[j]]
n <- length(a)
firsts <- c(1,(which(a[-n]!=a[-1])+1))
lasts <- c(which(a[-n]!=a[-1]),n)
denses <- a[firsts]
for(k in 1:length(denses)) {
if(denses[k]>0) lines(x$rivers$lines[[j]][(firsts[k]:lasts[k]),],lwd=(lwd+(lwdfactor*(denses[k]-1))),col=col)
}
}
}
#' @export
print.homerange <- function(x,...) {
cat("Minumum home ranges associated with each individual",'\n','\n')
print(x$ranges)
}
#' River Distance Matrix between Two Datasets
#' @description Returns a matrix of distances between each river location in two datasets, with one expressed as rows and the other expressed as columns.
#' @param seg1 First vector of river locations (segment component). These are expressed as rows in the output matrix.
#' @param vert1 First vector of river locations (vertex component). These are expressed as rows in the output matrix.
#' @param seg2 Second vector of river locations (segment component). These are expressed as columns in the output matrix.
#' @param vert2 Second vector of river locations (vertex component). These are expressed as columns in the output matrix.
#' @param rivers The river network object to use.
#' @param logical1 A boolean vector that can be used for subsetting. If used,
#' \code{riverdistancetofrom} will only return distances in which a
#' specified condition is met for the first dataset.
#' @param logical2 A boolean vector that can be used for subsetting. If used,
#' \code{riverdistancetofrom} will only return distances in which a
#' specified condition is met for the second dataset.
#' @param ID1 a vector of observation IDs for the first dataset that will be used as row names in the output matrix.
#' @param ID2 a vector of observation IDs for the second dataset that will be used as column names in the output matrix.
#' @param stopiferror Whether or not to exit with an error if a route cannot be
#' found. If this is set to \code{FALSE} and a route cannot be found,
#' the function will return \code{NA} in the appropriate entry. Defaults to \code{TRUE}. See \link{detectroute}.
#' @param algorithm Which route detection algorithm to use (\code{"Dijkstra"},
#' \code{"sequential"}, or \code{"segroutes"}). If left as \code{NULL} (the
#' default), the function will automatically make a selection. See
#' \link{detectroute} for more details.
#' @return A matrix of distances (numeric) with rows and columns labeled by corresponding values of \code{ID}.
#' @seealso \link{riverdistance}
#' @note Building routes from the river mouth to each river network segment and/or distance lookup tables will
#' greatly reduce computation time (see \link{buildsegroutes}).
#' @author Matt Tyers
#' @examples
#' data(Gulk)
#'
#' streamlocs.seg <- c(1,8,11)
#' streamlocs.vert <- c(50,70,90)
#' streamlocs.ID <- c("A","B","C")
#'
#' fish.seg <- c(1,4,9,12,14)
#' fish.vert <- c(10,11,12,13,14)
#' fish.ID <- c("fish1","fish2","fish3","fish4","fish5")
#'
#' riverdistancetofrom(seg1=streamlocs.seg, vert1=streamlocs.vert,
#' seg2=fish.seg, vert2=fish.vert, rivers=Gulk, ID1=streamlocs.ID, ID2=fish.ID)
#'
#' logi1 <- streamlocs.ID=="B" | streamlocs.ID=="C"
#' logi2 <- fish.ID!="fish3"
#'
#' riverdistancetofrom(seg1=streamlocs.seg, vert1=streamlocs.vert,
#' seg2=fish.seg, vert2=fish.vert, rivers=Gulk, logical1=logi1, logical2=logi2,
#' ID1=streamlocs.ID, ID2=fish.ID)
#' @export
riverdistancetofrom <- function(seg1,vert1,seg2,vert2,rivers,logical1=NULL,logical2=NULL,ID1=NULL,ID2=NULL,stopiferror=TRUE,algorithm=NULL) {
if(is.null(logical1)) logical1 <- rep(T,length(seg1))
if(is.null(logical2)) logical2 <- rep(T,length(seg2))
if(length(logical1) != length(seg1)) stop("logical1 must be the same length as its location vectors")
if(length(logical2) != length(seg2)) stop("logical2 must be the same length as its location vectors")
if(is.null(ID1)) ID1 <- 1:length(seg1)
if(is.null(ID2)) ID2 <- 1:length(seg2)
seg1 <- seg1[logical1]
vert1 <- vert1[logical1]
seg2 <- seg2[logical2]
vert2 <- vert2[logical2]
ID1 <- ID1[logical1]
ID2 <- ID2[logical2]
dists <- matrix(NA,nrow=length(seg1),ncol=length(seg2))
for(i in 1:length(seg1)) {
for(j in 1:length(seg2)) {
dists[i,j] <- riverdistance(startseg=seg1[i],startvert=vert1[i],endseg=seg2[j],endvert=vert2[j],rivers=rivers,
stopiferror=stopiferror,algorithm=algorithm)
}
}
class(ID1) <- "list"
class(ID2) <- "list"
dimnames(dists)[[1]] <- ID1
dimnames(dists)[[2]] <- ID2
return(dists)
}
Try the riverdist package in your browser
Any scripts or data that you put into this service are public.
riverdist documentation built on Aug. 22, 2023, 5:06 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions riverdistancetofrom print.homerange plothomerangeoverlap homerangeoverlap plot.homerange riverdistancemat riverdistancematbysurvey riverdistanceseq
Documented in homerangeoverlap plot.homerange plothomerangeoverlap riverdistancemat riverdistancematbysurvey riverdistanceseq riverdistancetofrom
#' River Distance Between Sequential Observations
#' @description Returns a matrix of distances traveled by unique fish, between
#' sequential surveys. A plotting method is also provided for the output; see \link{plotseq}
#' @param unique A vector of identifiers for each fish.
#' @param survey A vector of identifiers for each survey. It is recommended to use a numeric or date format (see \link{as.Date}) to preserve survey order.
#' @param seg A vector of river locations (segment component).
#' @param vert A vector of river locations (vertex component).
#' @param rivers The river network object to use.
#' @param logical A boolean vector that can be used for subsetting. If used,
#' \code{riverdistanceseq()} will only return pairwise distances in which a
#' specified condition is met.
#' @param stopiferror Whether or not to exit with an error if a route cannot be
#' found. If this is set to \code{FALSE} and a route cannot be found,
#' the function will return \code{NA} in the appropriate entry. Defaults to \code{TRUE}. See \link{detectroute}.
#' @param algorithm Which route detection algorithm to use (\code{"Dijkstra"},
#' \code{"sequential"}, or \code{"segroutes"}). If left as \code{NULL} (the
#' default), the function will automatically make a selection. See
#' \link{detectroute} for more details.
#' @return A data frame of distances (numeric), with rows defined by unique fish and columns defined by observation increment (1 to 2, 2 to 3, etc.)
#' @seealso \link{riverdistance}, \link{plotseq}
#' @note Building routes from the river mouth to each river network segment and/or distance lookup tables will
#' greatly reduce computation time (see \link{buildsegroutes}).
#' @author Matt Tyers
#' @examples
#' data(Gulk, fakefish)
#' riverdistanceseq(unique=fakefish$fish.id, survey=fakefish$flight,
#' seg=fakefish$seg, vert=fakefish$vert, rivers=Gulk)
#'
#' seqbysurvey <- riverdistanceseq(unique=fakefish$fish.id, survey=fakefish$flight.date,
#' seg=fakefish$seg, vert=fakefish$vert, rivers=Gulk)
#' seqbysurvey
#' plotseq(seqbysurvey)
#' @export
riverdistanceseq <- function(unique,survey,seg,vert,rivers,logical=NULL,stopiferror=TRUE,algorithm=NULL) {
if(!inherits(rivers, "rivernetwork")) stop("Argument 'rivers' must be of class 'rivernetwork'. See help(line2network) for more information.")
if(is.null(logical)) logical <- rep(T,length(unique))
unique<-unique[logical]
survey<-survey[logical]
seg<-seg[logical]
vert<-vert[logical]
tab <- table(unique,survey)
if(max(tab)>1) cat("Warning: multiple entries exist for at least one unique/survey combination (first one used)")
dists <- matrix(NA,nrow=dim(tab)[1],ncol=(dim(tab)[2]-1))
for(i in 1:dim(tab)[1]) {
for(j in 1:(dim(tab)[2]-1)) {
if(tab[i,j]*tab[i,(j+1)]!=0) {
dists[i,j] <- riverdistance(startseg=seg[unique==sort(unique(unique))[i] & survey==sort(unique(survey))[j]][1],
endseg=seg[unique==sort(unique(unique))[i] & survey==sort(unique(survey))[j+1]][1],
startvert=vert[unique==sort(unique(unique))[i] & survey==sort(unique(survey))[j]][1],
endvert=vert[unique==sort(unique(unique))[i] & survey==sort(unique(survey))[j+1]][1],
rivers=rivers,stopiferror=stopiferror,algorithm=algorithm)
}
}
}
dists<-as.data.frame(dists)
row.names(dists) <- row.names(tab)
col.name<-NA
for(j in 1:(length(dimnames(tab)$survey)-1)) col.name[j] <- paste(dimnames(tab)$survey[j],"to",dimnames(tab)$survey[j+1])
names(dists) <- col.name
dists <- dists[rowSums(is.na(dists)) != ncol(dists),]
return(dists)
}
#' River Distance Matrix of All Observations of an Individual
#' @description Returns a matrix of network distances between all observations
#' of one unique fish.
#' @param indiv The unique identifier of the fish in question.
#' @param unique A vector of identifiers for each fish.
#' @param survey A vector of identifiers for each survey. It is recommended to
#' use a numeric or date format (see \link{as.Date}) to preserve survey order.
#' @param seg A vector of river locations (segment component).
#' @param vert A vector of river locations (vertex component).
#' @param rivers The river network object to use.
#' @param full Whether to return the full matrix, with \code{NA} values for
#' missing data (\code{TRUE}), or a the subset of rows and columns
#' corresponding to successful observations. Defaults to \code{TRUE}.
#' @param stopiferror Whether or not to exit with an error if a route cannot be
#' found. If this is set to \code{FALSE} and a route cannot be found, the
#' function will return \code{NA} in the appropriate entry. Defaults to
#' \code{TRUE}. See \link{detectroute}.
#' @param algorithm Which route detection algorithm to use (\code{"Dijkstra"},
#' \code{"sequential"}, or \code{"segroutes"}). If left as \code{NULL} (the
#' default), the function will automatically make a selection. See
#' \link{detectroute} for more details.
#' @return A matrix of distances (numeric), with rows and columns defined by
#' survey.
#' @seealso \link{riverdistance}
#' @note Building routes from the river mouth to each river network segment and/or distance lookup tables will
#' greatly reduce computation time (see \link{buildsegroutes}).
#' @author Matt Tyers
#' @examples
#' data(Gulk, fakefish)
#' riverdistancematbysurvey(indiv=1, unique=fakefish$fish.id, survey=fakefish$flight,
#' seg=fakefish$seg, vert=fakefish$vert, rivers=Gulk)
#'
#' riverdistancematbysurvey(indiv=1, unique=fakefish$fish.id, survey=fakefish$flight,
#' seg=fakefish$seg, vert=fakefish$vert, rivers=Gulk, full=FALSE)
#' @export
riverdistancematbysurvey <- function(indiv,unique,survey,seg,vert,rivers,full=TRUE,stopiferror=TRUE,algorithm=NULL) {
surveys <- sort(unique(survey))
surveys_indiv <- sort(unique(survey[unique==indiv]))
outmat <- matrix(NA,nrow=length(surveys),ncol=length(surveys))
for(ii in 1:length(surveys)) {
for(jj in 1:length(surveys)) {
outmat[ii,jj] <- ifelse((length(seg[unique==indiv & survey==surveys[ii]])==0) | (length(seg[unique==indiv & survey==surveys[jj]])==0),NA,
riverdistance(startseg=seg[unique==indiv & survey==surveys[ii]], endseg=seg[unique==indiv & survey==surveys[jj]],
startvert=vert[unique==indiv & survey==surveys[ii]], endvert=vert[unique==indiv & survey==surveys[jj]],
rivers=rivers,stopiferror=stopiferror,algorithm=algorithm))
}
}
dimnames(outmat)[[1]] <- dimnames(outmat)[[2]] <- as.character(surveys)
if(!full) {
if(!all(is.na(outmat))) {
whichnotna <- NA
iwhichnotna <- 1
for(i in 1:dim(outmat)[1]) {
if(!all(is.na(outmat[,i]))) {
whichnotna[iwhichnotna] <- i
iwhichnotna <- iwhichnotna+1
}
}
outmat <- outmat[whichnotna,whichnotna]
}
if(all(is.na(outmat))) outmat <- NA
}
return(outmat)
}
#' River Distance Matrix
#' @description Returns a matrix of distances between every point and every
#' other point of given river locations (segment and vertex), or of a subset.
#' @param seg A vector of river locations (segment component).
#' @param vert A vector of river locations (vertex component).
#' @param rivers The river network object to use.
#' @param logical A boolean vector that can be used for subsetting. If used,
#' \code{riverdistancemat} will only return pairwise distances in which a
#' specified condition is met.
#' @param ID a vector of observation IDs for aid in interpreting the output
#' table
#' @param stopiferror Whether or not to exit with an error if a route cannot be
#' found. If this is set to \code{FALSE} and a route cannot be found,
#' the function will return \code{NA} in the appropriate entry. Defaults to \code{TRUE}. See \link{detectroute}
#' @param algorithm Which route detection algorithm to use (\code{"Dijkstra"},
#' \code{"sequential"}, or \code{"segroutes"}). If left as \code{NULL} (the
#' default), the function will automatically make a selection. See
#' \link{detectroute} for more details.
#' @return A matrix of distances (numeric) with rows and columns labeled by corresponding values of \code{ID}.
#' @seealso \link{riverdistance}
#' @note Building routes from the river mouth to each river network segment and/or distance lookup tables will
#' greatly reduce computation time (see \link{buildsegroutes}).
#' @author Matt Tyers
#' @examples
#' data(Gulk, fakefish)
#'
#' logi1 <- (fakefish$flight.date==as.Date("2015-11-25"))
#'
#' riverdistancemat(seg=fakefish$seg, vert=fakefish$vert, rivers=Gulk, logical=logi1)
#' @export
riverdistancemat <- function(seg,vert,rivers,logical=NULL,ID=NULL,stopiferror=TRUE,algorithm=NULL) {
if(!inherits(rivers, "rivernetwork")) stop("Argument 'rivers' must be of class 'rivernetwork'. See help(line2network) for more information.")
if(is.null(logical)) logical <- rep(T,length(unique))
len <- length(vert)
seg<-seg[logical]
vert<-vert[logical]
if(is.null(ID)) ID <- 1:len
ID <- ID[logical]
dists <- matrix(NA,nrow=length(vert),ncol=length(vert))
for(i in 1:length(vert)) {
for(j in 1:length(vert)) {
dists[i,j] <- riverdistance(startseg=seg[i],endseg=seg[j],startvert=vert[i],endvert=vert[j],rivers=rivers,
stopiferror=stopiferror,algorithm=algorithm)
}
}
dimnames(dists)[[1]] <- dimnames(dists)[[2]] <- ID
return(dists)
}
#' Home Range
#' @description Returns the minimum observed home range for multiple
#' observations of each individual fish.
#' @param unique A vector of unique identifiers for each fish. If the default (\code{NULL}) is used, the function will assume all observations come from a single individual.
#' @param survey A vector of survey identifiers for each fish. This argument is not needed for home range calculation, but can affect plotting (see \link{plot.homerange}).
#' @param seg A vector of river locations (segment component).
#' @param vert A vector of river locations (vertex component).
#' @param rivers The river network object to use.
#' @param map Deprecated, use \link{plot.homerange} for plotting instead. Originally, whether to produce sanity-check maps
#' of observed locations and calculated home range for each fish.
#' @param algorithm Which route detection algorithm to use (\code{"Dijkstra"},
#' \code{"sequential"}, or \code{"segroutes"}). If left as \code{NULL} (the
#' default), the function will automatically make a selection. See
#' \link{detectroute} for more details.
#' @param main Deprecated, use \link{plot.homerange} for plotting instead. Originally, plot title, if \code{map} is set to \code{TRUE}. If unspecified, the unique ID will be used for the title.
#' @param ... Deprecated, use \link{plot.homerange} for plotting instead. Originally, additional plotting arguments, if \code{map} is set to \code{TRUE}.
#' @return An object of the \link{homerange-class}. The \code{$ranges} element is a data frame with two columns: \code{$ID} is a list of unique fish
#' (as specified by \code{unique=}), and \code{$range} is calculated minimum
#' home range, in the units of the coordinate system (this will likely be
#' meters). The other elements are used for plotting, see \link{homerange-class} for more details.
#' @note Building routes from the river mouth to each river network segment and/or distance lookup tables will
#' greatly reduce computation time (see \link{buildsegroutes}).
#' @seealso \link{plot.homerange}, \link{homerangeoverlap}, \link{plothomerangeoverlap}
#' @author Matt Tyers
#' @examples
#' data(Gulk, fakefish)
#' ranges <- with(fakefish, homerange(unique=fish.id, survey=flight, seg=seg, vert=vert, rivers=Gulk))
#' ranges
#'
#' # 19 plots will be produced, recommend calling par(mfrow=c(4,5))
#' plot(ranges)
#' plot(ranges,cumulative=TRUE,label=TRUE)
#'
#' homerangeoverlap(ranges)
#'
#' plothomerangeoverlap(ranges)
#' with(fakefish, riverpoints(seg=seg, vert=vert, rivers=Gulk))
#' @importFrom graphics plot
#' @importFrom graphics lines
#' @export
homerange <- function (unique=NULL, survey=NULL, seg, vert, rivers, map = FALSE, algorithm = NULL,
main = NULL, ...)
{
if (!inherits(rivers, "rivernetwork"))
stop("Argument 'rivers' must be of class 'rivernetwork'. See help(line2network) for more information.")
if(is.null(unique)) unique <- rep(1,length(seg))
if ((length(unique) != length(seg)) | (length(seg) != length(vert)))
stop("Input vectors must be the same length.")
if(!missing(map)) warning("Argument map= is deprecated. Use plot() instead, on the object returned from homerange().")
if(is.null(survey)) survey1 <- 1:length(seg)
else survey1 <- survey
ID <- sort(unique(unique))
range <- rep(0, length(ID))
alllengths <- function(xy) {
n <- dim(xy)[1]
if (n == 1)
dist <- 0
if (n == 2)
dist <- pdist(xy[1, ], xy[2, ])
if (n > 2)
dist <- sqrt(((xy[1:(n - 1), 1] - xy[2:n, 1])^2) +
((xy[1:(n - 1), 2] - xy[2:n, 2])^2))
return(dist)
}
subseg_length <- list()
for (i in 1:length(rivers$lines)) {
subseg_length[[i]] <- alllengths(rivers$lines[[i]])
}
subseg_n <- list()
for (i in 1:length(ID)) {
subseg_n[[i]] <- list()
if (map == T) {
if (is.null(main)) {
main1 <- ID[i]
}
else {
main1 <- main
}
plot(x = rivers, main = main1, color = F, segmentnum = F,
... = ...)
}
n.entries <- length(unique[unique == ID[i]])
if (n.entries > 1) {
seg1 <- (seg[unique == ID[i]])[order(survey1[unique==ID[i]])]
vert1 <- (vert[unique == ID[i]])[order(survey1[unique==ID[i]])]
routes <- NA
routes <- list()
vert2 <- NA
vert2 <- list()
for (jj in 1:(n.entries-1)) {
routes[[jj]] <- detectroute(start = seg1[jj], end = seg1[jj+1], rivers = rivers, algorithm = algorithm)
vert2[[jj]] <- c(vert1[jj], vert1[jj+1])
}
seg.rep.max2 <- rep(0, length(rivers$lines))
for (j in 1:length(rivers$lines)) {
linelength <- dim(rivers$lines[[j]])[1]
subseg_n[[i]][[j]] <- rep(0, length(subseg_length[[j]]))
for (k in 1:length(routes)) {
if (length(routes[[k]][routes[[k]] == j]) >
0) {
if (length(routes[[k]]) > 2 & routes[[k]][1] !=
j & routes[[k]][length(routes[[k]])] !=
j) {
if (map)
lines(rivers$lines[[j]], col = 4, lwd = 3)
subseg_n[[i]][[j]] <- subseg_n[[i]][[j]]+1
}
if (length(routes[[k]]) == 1) {
if (vert2[[k]][1] != vert2[[k]][2]) {
subseg_n[[i]][[j]][min((linelength - 1), min(vert2[[k]])):(max(vert2[[k]]) - 1)] <- subseg_n[[i]][[j]][min((linelength - 1), min(vert2[[k]])):(max(vert2[[k]]) - 1)]+1
if (map)
lines(rivers$lines[[j]][(vert2[[k]][1]:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
}
if (routes[[k]][1] == j & length(routes[[k]]) >
1) {
if (rivers$connections[routes[[k]][1],
routes[[k]][[2]]] <= 2) {
if (vert2[[k]][1] > 1) subseg_n[[i]][[j]][1:(vert2[[k]][1] - 1)] <- subseg_n[[i]][[j]][1:(vert2[[k]][1] - 1)]+1
if (map)
lines(rivers$lines[[j]][(1:vert2[[k]][1]),
, drop = F], col = 4, lwd = 3)
}
if (any(rivers$connections[routes[[k]][1],
routes[[k]][[2]]] == 3:4)) {
if (vert2[[k]][1] < linelength) {
subseg_n[[i]][[j]][(vert2[[k]][1]):(linelength - 1)] <- subseg_n[[i]][[j]][(vert2[[k]][1]):(linelength - 1)]+1
}
if (map)
lines(rivers$lines[[j]][(vert2[[k]][1]):linelength,
, drop = F], col = 4, lwd = 3)
}
if (length(routes[[k]] == 2) & rivers$connections[j,
routes[[k]][2]] == 5) {
d1 <- rivers$cumuldist[[j]][vert2[[k]][1]] +
rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]]
d2 <- (rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][1]]) +
(rivers$lengths[routes[[k]][2]] - rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]])
if (d1 <= d2) {
if (vert2[[k]][1] > 1) subseg_n[[i]][[j]][1:(vert2[[k]][1] - 1)] <- subseg_n[[i]][[j]][1:(vert2[[k]][1] - 1)]+1
if (map)
lines(rivers$lines[[j]][(vert2[[k]][1]:1),
, drop = F], col = 4, lwd = 3)
}
else {
if (vert2[[k]][1] < linelength) {
subseg_n[[i]][[j]][(vert2[[k]][1]):(linelength - 1)] <- subseg_n[[i]][[j]][(vert2[[k]][1]):(linelength - 1)]+1
}
if (map)
lines(rivers$lines[[j]][(vert2[[k]][1]:linelength),
, drop = F], col = 4, lwd = 3)
}
}
if (length(routes[[k]] == 2) & rivers$connections[j,
routes[[k]][2]] == 6) {
d1 <- rivers$cumuldist[[j]][vert2[[k]][1]] +
(rivers$lengths[routes[[k]][2]] - rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]])
d2 <- (rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][1]]) +
rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]]
if (d1 <= d2) {
if (vert2[[k]][1] > 1) subseg_n[[i]][[j]][1:(vert2[[k]][1] - 1)] <- subseg_n[[i]][[j]][1:(vert2[[k]][1] - 1)]+1
if (map)
lines(rivers$lines[[j]][(vert2[[k]][1]:1),
, drop = F], col = 4, lwd = 3)
}
else {
if (vert2[[k]][1] < linelength) {
subseg_n[[i]][[j]][(vert2[[k]][1]):(linelength - 1)] <- subseg_n[[i]][[j]][(vert2[[k]][1]):(linelength - 1)]+1
}
if (map)
lines(rivers$lines[[j]][(vert2[[k]][1]:linelength),
, drop = F], col = 4, lwd = 3)
}
}
}
if (routes[[k]][length(routes[[k]])] == j &
length(routes[[k]]) > 1) {
if (rivers$connections[routes[[k]][length(routes[[k]])],
routes[[k]][[length(routes[[k]]) - 1]]] <=
2) {
if (vert2[[k]][2] > 1) subseg_n[[i]][[j]][1:(vert2[[k]][2] - 1)] <- subseg_n[[i]][[j]][1:(vert2[[k]][2] - 1)]+1
if (map)
lines(rivers$lines[[j]][(1:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
if (any(rivers$connections[routes[[k]][length(routes[[k]])],
routes[[k]][[length(routes[[k]]) - 1]]] ==
3:4)) {
if (vert2[[k]][2] < linelength) {
subseg_n[[i]][[j]][(vert2[[k]][2]):(linelength - 1)] <- subseg_n[[i]][[j]][(vert2[[k]][2]):(linelength - 1)]+1
}
if (map)
lines(rivers$lines[[j]][(linelength:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
if (length(routes[[k]] == 2) & rivers$connections[routes[[k]][1],
routes[[k]][2]] == 5) {
d1 <- rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]] +
rivers$cumuldist[[j]][vert2[[k]][2]]
d2 <- (rivers$lengths[routes[[k]][1]] -
rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]]) +
(rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][2]])
if (d1 <= d2) {
if (vert2[[k]][2] > 1) subseg_n[[i]][[j]][1:(vert2[[k]][2] - 1)] <- subseg_n[[i]][[j]][1:(vert2[[k]][2] - 1)]+1
if (map)
lines(rivers$lines[[j]][(1:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
else {
if (vert2[[k]][2] < linelength) {
subseg_n[[i]][[j]][(vert2[[k]][2]):(linelength - 1)] <- subseg_n[[i]][[j]][(vert2[[k]][2]):(linelength - 1)]+1
}
if (map)
lines(rivers$lines[[j]][(linelength:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
}
if (length(routes[[k]] == 2) & rivers$connections[routes[[k]][1],
routes[[k]][2]] == 6) {
d1 <- (rivers$lengths[routes[[k]][1]] -
rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]]) +
rivers$cumuldist[[j]][vert2[[k]][2]]
d2 <- rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]] +
(rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][2]])
if (d1 <= d2) {
if (vert2[[k]][2] > 1) subseg_n[[i]][[j]][1:(vert2[[k]][2] - 1)] <- subseg_n[[i]][[j]][1:(vert2[[k]][2] - 1)]+1
if (map)
lines(rivers$lines[[j]][(1:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
else {
if (vert2[[k]][2] < linelength) {
subseg_n[[i]][[j]][(vert2[[k]][2]):(linelength - 1)] <- subseg_n[[i]][[j]][(vert2[[k]][2]):(linelength - 1)]+1
}
if (map)
lines(rivers$lines[[j]][(linelength:vert2[[k]][2]),
, drop = F], col = 4, lwd = 3)
}
}
}
}
}
seg.rep.max2[j] <- sum((subseg_n[[i]][[j]]>0) * subseg_length[[j]])
}
range[i] <- sum(seg.rep.max2)
}
if (map)
riverpoints(seg = seg[unique == ID[i]], vert = vert[unique ==
ID[i]], rivers = rivers, pch = 15, col = 4)
names(subseg_n)[i] <- ID[i]
}
thing <- data.frame(ID, range)
thing2 <- subset(thing, range > 0)
out <- list(ranges=thing2,subseg_n=subseg_n,subseg_length=subseg_length,seg=seg,vert=vert,unique=unique,survey=survey,rivers=rivers)
class(out) <- "homerange"
return(out)
}
# homerange <- function(unique=NULL,seg,vert,rivers,map=FALSE,algorithm=NULL,main=NULL,...) {
# if(!inherits(rivers, "rivernetwork")) stop("Argument 'rivers' must be of class 'rivernetwork'. See help(line2network) for more information.")
# if(is.null(unique)) unique <- rep(1,length(seg))
# if((length(unique)!=length(seg))|(length(seg)!=length(vert))) stop("Input vectors must be the same length.")
# ID <- sort(unique(unique))
# range <- rep(0,length(ID))
#
# alllengths <- function(xy) {
# n <- dim(xy)[1]
# if(n==1) dist <- 0
# if(n==2) dist <- pdist(xy[1,],xy[2,])
# if(n>2) dist <- sqrt(((xy[1:(n-1),1] - xy[2:n,1])^2) + ((xy[1:(n-1),2] - xy[2:n,2])^2))
# return(dist)
# }
# subseglength <- list()
# for(i in 1:length(rivers$lines)) {
# subseglength[[i]] <- alllengths(rivers$lines[[i]])
# }
#
# for(i in 1:length(ID)) {
# # i <- 7
# if(map==T) {
# if(is.null(main)) {
# main1 <- ID[i]
# } else{
# main1 <- main
# }
# plot(x=rivers,main=main1,color=F,segmentnum=F,...=...)
# }
#
# n.entries <- length(unique[unique==ID[i]])
# if(n.entries>1) {
# # create a list of routes taken for fish i
# seg1 <- seg[unique==ID[i]]
# vert1 <- vert[unique==ID[i]]
# routes <- NA
# routes <- list()
# vert2 <- NA
# vert2 <- list()
# for(j in 1:n.entries) {
# for(k in 1:n.entries) {
# routes[[((j-1)*n.entries+k)]] <- detectroute(start=seg1[j],end=seg1[k],rivers=rivers,algorithm=algorithm)
# vert2[[((j-1)*n.entries+k)]] <- c(vert1[j],vert1[k])
# }
# }
# seg.rep.max2 <- rep(0,length(rivers$lines))
#
#
# # calculate amounts of each segment represented in each route
# for(j in 1:length(rivers$lines)) { # segment j
# linelength <- dim(rivers$lines[[j]])[1]
#
# subsegused <- rep(F,length(subseglength[[j]]))
#
# for(k in 1:length(routes)) { # route k
#
# # if segment j shows up in route k
# if(length(routes[[k]][routes[[k]]==j])>0) {
#
# #middle
# if(length(routes[[k]])>2 & routes[[k]][1]!=j & routes[[k]][length(routes[[k]])]!=j) {
# if(map) lines(rivers$lines[[j]],col=4,lwd=3)
# subsegused[] <- T
# }
#
# #only
# if(length(routes[[k]])==1) {
# if(vert2[[k]][1] != vert2[[k]][2]) {
# subsegused[min((linelength-1),min(vert2[[k]])):(max(vert2[[k]])-1)] <- T
# if(map) lines(rivers$lines[[j]][(vert2[[k]][1]:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# }
# }
#
# #beginning
# if(routes[[k]][1]==j & length(routes[[k]])>1) {
# # connected at beginning
# if(rivers$connections[routes[[k]][1],routes[[k]][[2]]]<=2) {
# subsegused[1:(vert2[[k]][1]-1)] <- T
# if(map) lines(rivers$lines[[j]][(1:vert2[[k]][1]),,drop=F],col=4,lwd=3)
# }
# # connected at end
# if(any(rivers$connections[routes[[k]][1],routes[[k]][[2]]]==3:4)) {
# if(vert2[[k]][1] < linelength) subsegused[(vert2[[k]][1]):(linelength-1)] <- T
# if(map) lines(rivers$lines[[j]][(vert2[[k]][1]):linelength,,drop=F],col=4,lwd=3)
# }
# #special braided case
# if(length(routes[[k]]==2) & rivers$connections[j,routes[[k]][2]]==5) {
# d1 <- rivers$cumuldist[[j]][vert2[[k]][1]] + rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]]
# d2 <- (rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][1]]) + (rivers$lengths[routes[[k]][2]] - rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]])
# if(d1 <= d2) {
# subsegused[1:(vert2[[k]][1]-1)] <- T
# if(map) lines(rivers$lines[[j]][(vert2[[k]][1]:1),,drop=F],col=4,lwd=3)
# } else {
# if(vert2[[k]][1] < linelength) subsegused[(vert2[[k]][1]):(linelength-1)] <- T
# if(map) lines(rivers$lines[[j]][(vert2[[k]][1]:linelength),,drop=F],col=4,lwd=3)
# }
# }
# if(length(routes[[k]]==2) & rivers$connections[j,routes[[k]][2]]==6) {
# d1 <- rivers$cumuldist[[j]][vert2[[k]][1]] + (rivers$lengths[routes[[k]][2]] - rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]])
# d2 <- (rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][1]]) + rivers$cumuldist[[routes[[k]][2]]][vert2[[k]][2]]
# if(d1 <= d2) {
# subsegused[1:(vert2[[k]][1]-1)] <- T
# if(map) lines(rivers$lines[[j]][(vert2[[k]][1]:1),,drop=F],col=4,lwd=3)
# } else {
# if(vert2[[k]][1] < linelength) subsegused[(vert2[[k]][1]):(linelength-1)] <- T
# if(map) lines(rivers$lines[[j]][(vert2[[k]][1]:linelength),,drop=F],col=4,lwd=3)
# }
# }
# }
#
# #end
# if(routes[[k]][length(routes[[k]])]==j & length(routes[[k]])>1) {
# # connected at beginning
# if(rivers$connections[routes[[k]][length(routes[[k]])],routes[[k]][[length(routes[[k]])-1]]]<=2) {
# subsegused[1:(vert2[[k]][2]-1)] <- T
# if(map) lines(rivers$lines[[j]][(1:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# }
# # connected at end
# if(any(rivers$connections[routes[[k]][length(routes[[k]])],routes[[k]][[length(routes[[k]])-1]]]==3:4)) {
# if(vert2[[k]][2] < linelength) subsegused[(vert2[[k]][2]):(linelength-1)] <- T
# if(map) lines(rivers$lines[[j]][(linelength:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# }
#
# #special braided case
# if(length(routes[[k]]==2) & rivers$connections[routes[[k]][1],routes[[k]][2]]==5) {
# d1 <- rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]] + rivers$cumuldist[[j]][vert2[[k]][2]]
# d2 <- (rivers$lengths[routes[[k]][1]] - rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]]) + (rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][2]])
# if(d1 <= d2) {
# subsegused[1:(vert2[[k]][2]-1)] <- T
# if(map) lines(rivers$lines[[j]][(1:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# } else {
# if(vert2[[k]][2] < linelength) subsegused[(vert2[[k]][2]):(linelength-1)] <- T
# if(map) lines(rivers$lines[[j]][(linelength:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# }
# }
# if(length(routes[[k]]==2) & rivers$connections[routes[[k]][1],routes[[k]][2]]==6) {
# d1 <- (rivers$lengths[routes[[k]][1]] - rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]]) + rivers$cumuldist[[j]][vert2[[k]][2]]
# d2 <- rivers$cumuldist[[routes[[k]][1]]][vert2[[k]][1]] + (rivers$lengths[j] - rivers$cumuldist[[j]][vert2[[k]][2]])
# if(d1 <= d2) {
# subsegused[1:(vert2[[k]][2]-1)] <- T
# if(map) lines(rivers$lines[[j]][(1:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# } else {
# if(vert2[[k]][2] < linelength) subsegused[(vert2[[k]][2]):(linelength-1)] <- T
# if(map) lines(rivers$lines[[j]][(linelength:vert2[[k]][2]),,drop=F],col=4,lwd=3)
# }
# }
# }
# }
# }
# seg.rep.max2[j] <- sum(subsegused*subseglength[[j]])
# }
# range[i] <- sum(seg.rep.max2)
# }
# if(map) riverpoints(seg=seg[unique==ID[i]],vert=vert[unique==ID[i]],rivers=rivers,pch=15,col=4)
# }
#
# thing <- data.frame(ID,range)
# thing2 <- subset(thing,range>0)
# return(thing2)
# }
#' Plot Home Range
#' @description Plotting method for home range, the minimum observed home range for multiple
#' observations of each individual fish.
#' @param x An object returned from \link{homerange}.
#' @param cumulative Whether to plot travel as cumulative, with line thickness depending on the number of times a given region was traveled by a given individual. Defaults to \code{FALSE}.
#' @param lwd The line width for plotting homerange, or minimum line width if \code{cumulative} is \code{TRUE}. Defaults to 3.
#' @param maxlwd The maximum line width if \code{cumulative} is \code{TRUE}. Defaults to 10.
#' @param col The line color to use. Defaults to \code{"blue"}.
#' @param pch The point character to use for individual points. Defaults to open circles, the color of lines.
#' @param label Whether to add survey labels to individual points, if used in \link{homerange}. Defaults to \code{FALSE}.
#' @param main Plot title. If the default \code{NULL} is used, plots will be titled according to unique individual.
#' @param ... Additional plotting parameters, see \link{plot.rivernetwork}.
#' @seealso \link{homerange}, \link{homerangeoverlap}, \link{plothomerangeoverlap}
#' @author Matt Tyers, bug fix by Jordy Bernard
#' @examples
#' data(Gulk, fakefish)
#' ranges <- with(fakefish, homerange(unique=fish.id, survey=flight, seg=seg, vert=vert, rivers=Gulk))
#' ranges
#'
#' # 19 plots will be produced, recommend calling par(mfrow=c(4,5))
#' plot(ranges)
#' plot(ranges,cumulative=TRUE,label=TRUE)
#'
#' homerangeoverlap(ranges)
#'
#' plothomerangeoverlap(ranges)
#' with(fakefish, riverpoints(seg=seg, vert=vert, rivers=Gulk))
#' @importFrom graphics plot
#' @importFrom graphics lines
#' @export
plot.homerange <- function(x,cumulative=FALSE,lwd=3,maxlwd=10,col=4,pch=21,label=FALSE,main=NULL,...) {
if(is.null(x$survey) & cumulative) warning("Argument survey= will ensure points are chronological order. Entry order used.")
if(is.null(main)) mains <- names(x$subseg_n)
if(length(main)==1) mains <- rep(main,length(x$subseg_n))
if(length(main)>1) mains <- main
maxlwds <- max(unlist(x$subseg_n),na.rm=T)
lwdfactor <- ifelse(maxlwds==1,0,(maxlwd-lwd)/(maxlwds-1))
for(i in seq_along(x$subseg_n)) {
# print(mains)
plot(x$rivers,empty=T,main=mains[i],...=...)
for(j in seq_along(x$subseg_n[[i]])) {
a <- x$subseg_n[[i]][[j]]
if(!cumulative) a <- 1*(a>0)
n <- length(a)
firsts <- c(1,(which(a[-n]!=a[-1])+1))
lasts <- c(which(a[-n]!=a[-1]),n)
denses <- a[firsts]
for(k in seq_along(denses)) {
if(denses[k]>0){
if(!is.null(dim(x$rivers$lines[[j]][(firsts[k]:lasts[k]),]))){
lines(x$rivers$lines[[j]][(firsts[k]:lasts[k]),],lwd=(lwd+cumulative*(lwdfactor*denses[k]-1)),col=col)
}
}
}
}
riverpoints(seg=x$seg[x$unique==names(x$subseg_n)[i]],vert=x$vert[x$unique==names(x$subseg_n)[i]],rivers=x$rivers,pch=pch,bg="white",col=col)
if(label) {
segs <- x$seg[x$unique==names(x$subseg_n)[i]]
verts <- x$vert[x$unique==names(x$subseg_n)[i]]
texx <- texy <- rep(NA,length(segs))
for(k in 1:length(segs)) {
texx[k] <- x$rivers$lines[[segs[k]]][verts[k],1]
texy[k] <- x$rivers$lines[[segs[k]]][verts[k],2]
}
text(x=texx,y=texy,labels=x$survey[x$unique==names(x$subseg_n)[i]],pos=4,cex=1)
}
}
}
#' Home Range Overlap
#' @description Returns matrices describing the overlap of the minimum observed home range for multiple
#' observations of each individual fish.
#' @param x An object returned from \link{homerange}.
#' @return A list of three matrices, with \code{$either} giving the distances represented by the union of home ranges of each pair of individuals, and \code{$both} giving the distances represented by the intersection of home ranges of each pair of individuals. Element \code{$prop_both} gives the proportion of overlap, defined as intersection/union.
#' @seealso \link{homerange}, \link{plot.homerange}, \link{plothomerangeoverlap}
#' @author Matt Tyers
#' @examples
#' data(Gulk, fakefish)
#' ranges <- with(fakefish, homerange(unique=fish.id, survey=flight, seg=seg, vert=vert, rivers=Gulk))
#' ranges
#'
#' # 19 plots will be produced, recommend calling par(mfrow=c(4,5))
#' plot(ranges)
#' plot(ranges,cumulative=TRUE,label=TRUE)
#'
#' homerangeoverlap(ranges)
#'
#' plothomerangeoverlap(ranges)
#' with(fakefish, riverpoints(seg=seg, vert=vert, rivers=Gulk))
#' @export
homerangeoverlap <- function(x) {
if(!inherits(x, "homerange")) stop("Input must be of class homerange. See help(homerange) or help(homerange-class) for more details.")
n <- length(x$subseg_n)
either <- both <- matrix(0,nrow=n,ncol=n)
for(i in 1:n) {
for(j in 1:n) {
for(k in 1:length(x$subseg_length)) {
either[i,j] <- either[i,j] + sum(x$subseg_length[[k]]*(x$subseg_n[[i]][[k]]>0 | x$subseg_n[[j]][[k]]>0))
both[i,j] <- both[i,j] + sum(x$subseg_length[[k]]*(x$subseg_n[[i]][[k]]>0 & x$subseg_n[[j]][[k]]>0))
}
}
}
dimnames(either)[[1]] <- dimnames(either)[[2]] <- dimnames(both)[[1]] <- dimnames(both)[[2]] <- names(x$subseg_n)
return(list(either=either,both=both,prop_both=both/either))
}
#' Plot Home Range Overlap
#' @description Produces a plot of the overlap of the minimum observed home range for multiple
#' observations of each individual fish, with line thickness illustrating the respective number of individuals' homeranges represented.
#' @param x An object returned from \link{homerange}.
#' @param lwd Minimum line width to use, defaults to 3.
#' @param maxlwd Maximum line width to use, defaults to 10.
#' @param col Line color to use, defaults to \code{"blue"}.
#' @param ... Additional plotting parameters, see \link{plot.rivernetwork}.
#' @seealso \link{homerange}, \link{plot.homerange}, \link{homerangeoverlap}
#' @author Matt Tyers
#' @examples
#' data(Gulk, fakefish)
#' ranges <- with(fakefish, homerange(unique=fish.id, survey=flight, seg=seg, vert=vert, rivers=Gulk))
#' ranges
#'
#' # 19 plots will be produced, recommend calling par(mfrow=c(4,5))
#' plot(ranges)
#' plot(ranges,cumulative=TRUE,label=TRUE)
#'
#' homerangeoverlap(ranges)
#'
#' plothomerangeoverlap(ranges)
#' with(fakefish, riverpoints(seg=seg, vert=vert, rivers=Gulk))
#' @importFrom graphics plot
#' @importFrom graphics lines
#' @export
plothomerangeoverlap <- function(x,lwd=3,maxlwd=10,col=4,...) {
totsubsegs <- x$subseg_n[[1]]
for(j in 1:length(x$subseg_n[[1]])) {
totsubsegs[[j]][] <- 0
for(i in 1:length(x$subseg_n)) {
totsubsegs[[j]] <- totsubsegs[[j]] + (x$subseg_n[[i]][[j]]>0)
}
}
maxlwds <- max(unlist(totsubsegs),na.rm=T)
lwdfactor <- ifelse(maxlwds==1,0,(maxlwd-lwd)/(maxlwds-1))
plot(x=x$rivers,empty=T,...=...)
for(j in 1:length(totsubsegs)) {
a <- totsubsegs[[j]]
n <- length(a)
firsts <- c(1,(which(a[-n]!=a[-1])+1))
lasts <- c(which(a[-n]!=a[-1]),n)
denses <- a[firsts]
for(k in 1:length(denses)) {
if(denses[k]>0) lines(x$rivers$lines[[j]][(firsts[k]:lasts[k]),],lwd=(lwd+(lwdfactor*(denses[k]-1))),col=col)
}
}
}
#' @export
print.homerange <- function(x,...) {
cat("Minumum home ranges associated with each individual",'\n','\n')
print(x$ranges)
}
#' River Distance Matrix between Two Datasets
#' @description Returns a matrix of distances between each river location in two datasets, with one expressed as rows and the other expressed as columns.
#' @param seg1 First vector of river locations (segment component). These are expressed as rows in the output matrix.
#' @param vert1 First vector of river locations (vertex component). These are expressed as rows in the output matrix.
#' @param seg2 Second vector of river locations (segment component). These are expressed as columns in the output matrix.
#' @param vert2 Second vector of river locations (vertex component). These are expressed as columns in the output matrix.
#' @param rivers The river network object to use.
#' @param logical1 A boolean vector that can be used for subsetting. If used,
#' \code{riverdistancetofrom} will only return distances in which a
#' specified condition is met for the first dataset.
#' @param logical2 A boolean vector that can be used for subsetting. If used,
#' \code{riverdistancetofrom} will only return distances in which a
#' specified condition is met for the second dataset.
#' @param ID1 a vector of observation IDs for the first dataset that will be used as row names in the output matrix.
#' @param ID2 a vector of observation IDs for the second dataset that will be used as column names in the output matrix.
#' @param stopiferror Whether or not to exit with an error if a route cannot be
#' found. If this is set to \code{FALSE} and a route cannot be found,
#' the function will return \code{NA} in the appropriate entry. Defaults to \code{TRUE}. See \link{detectroute}.
#' @param algorithm Which route detection algorithm to use (\code{"Dijkstra"},
#' \code{"sequential"}, or \code{"segroutes"}). If left as \code{NULL} (the
#' default), the function will automatically make a selection. See
#' \link{detectroute} for more details.
#' @return A matrix of distances (numeric) with rows and columns labeled by corresponding values of \code{ID}.
#' @seealso \link{riverdistance}
#' @note Building routes from the river mouth to each river network segment and/or distance lookup tables will
#' greatly reduce computation time (see \link{buildsegroutes}).
#' @author Matt Tyers
#' @examples
#' data(Gulk)
#'
#' streamlocs.seg <- c(1,8,11)
#' streamlocs.vert <- c(50,70,90)
#' streamlocs.ID <- c("A","B","C")
#'
#' fish.seg <- c(1,4,9,12,14)
#' fish.vert <- c(10,11,12,13,14)
#' fish.ID <- c("fish1","fish2","fish3","fish4","fish5")
#'
#' riverdistancetofrom(seg1=streamlocs.seg, vert1=streamlocs.vert,
#' seg2=fish.seg, vert2=fish.vert, rivers=Gulk, ID1=streamlocs.ID, ID2=fish.ID)
#'
#' logi1 <- streamlocs.ID=="B" | streamlocs.ID=="C"
#' logi2 <- fish.ID!="fish3"
#'
#' riverdistancetofrom(seg1=streamlocs.seg, vert1=streamlocs.vert,
#' seg2=fish.seg, vert2=fish.vert, rivers=Gulk, logical1=logi1, logical2=logi2,
#' ID1=streamlocs.ID, ID2=fish.ID)
#' @export
riverdistancetofrom <- function(seg1,vert1,seg2,vert2,rivers,logical1=NULL,logical2=NULL,ID1=NULL,ID2=NULL,stopiferror=TRUE,algorithm=NULL) {
if(is.null(logical1)) logical1 <- rep(T,length(seg1))
if(is.null(logical2)) logical2 <- rep(T,length(seg2))
if(length(logical1) != length(seg1)) stop("logical1 must be the same length as its location vectors")
if(length(logical2) != length(seg2)) stop("logical2 must be the same length as its location vectors")
if(is.null(ID1)) ID1 <- 1:length(seg1)
if(is.null(ID2)) ID2 <- 1:length(seg2)
seg1 <- seg1[logical1]
vert1 <- vert1[logical1]
seg2 <- seg2[logical2]
vert2 <- vert2[logical2]
ID1 <- ID1[logical1]
ID2 <- ID2[logical2]
dists <- matrix(NA,nrow=length(seg1),ncol=length(seg2))
for(i in 1:length(seg1)) {
for(j in 1:length(seg2)) {
dists[i,j] <- riverdistance(startseg=seg1[i],startvert=vert1[i],endseg=seg2[j],endvert=vert2[j],rivers=rivers,
stopiferror=stopiferror,algorithm=algorithm)
}
}
class(ID1) <- "list"
class(ID2) <- "list"
dimnames(dists)[[1]] <- ID1
dimnames(dists)[[2]] <- ID2
return(dists)
}
Try the riverdist package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.