# CREATE THE DISPERSAL (or breeding) MATRIX
#' @title Create dispersal or breeding window kernels and connectivity matrices
#'
#' @description Automatically create the dispersal and breeding window probability kernels and connectivity matrices of patch IDs based on the provided cell size, number of cells in the x and y directions on the landscape, and the mean and standard deviation of the dispersal kernel. Additionally, two distributions are able to be summed for creating the dispersal kernel.
#'
#' @param cell.size The size in unites distance of a single patch (or cell), which based on the parameters given below will influence how large the landscape is and how many cells are within one unit sigma.
#'
#' @param horizontal.land The size of the landscape in the horizontal direction. Units are the same as cell.size.
#'
#' @param vertical.land The size of the landscape in the vertical direction. Units are the same as cell.size.
#'
#' @param dist.mean The mean distance for the kernel's distribution. Default is zero (i.e. most dispersal occurs to the natal patch).
#'
#' @param dist.sd Sigma (one standard deviation) for the distribution of dispersal distances.
#'
#' @param breed.window A boolean parameter with default FALSE. Change to true if making a breeding window and not a dispersal kernel. This changes the ID of the patch that is at the absorbing boundary of the landscape.
#'
#' @param two.kernels A boolean parameter with default FALSE. If two distributions are being summed to create the kernel, this should be TRUE.
#'
#' @param kernel.weighting The weighting of the first distribution for creating the summed kernels (the second distribution will be one minus this).
#'
#' @param second.dist.mean The mean of the second distribution being summed with the first distribution. The default is zero, as above, but should match the first distribution's mean if that is ever changed from zero.
#'
#' @param second.dist.sd Sigma (one standard deviation) for the distribution of dispersal distances of the second distribution.
#'
#' @return
#'
#' Returns the array of probabilities for the dispersal or breeding window kernels and prints the connectivity matrix to a file.
#'
#' @author Kimberly J Gilbert
#'
#' @import graphics
#'
#' @examples
#'
#' make.kernel.and.matrix(cell.size=50, horizontal.land=1000, vertical.land=2000, dist.mean=0,
#' dist.sd=25, breed.window=TRUE, two.kernels=FALSE, second.dist.mean=0, second.dist.sd=NULL)
#'
#'
#' @export make.kernel.and.matrix
make.kernel.and.matrix <- function(cell.size, horizontal.land, vertical.land, dist.mean=0, dist.sd, breed.window=FALSE, two.kernels=FALSE, kernel.weighting=0.9, second.dist.mean=0, second.dist.sd=NULL){
cell <- cell.size
cells.x <- vertical.land/cell
cells.y <- horizontal.land/cell
total.cells <- cells.x * cells.y
# scale the landscape, and want to cut off at 4 sigma, so how many cells (in 1-D) are there within 4 sigma:
units <- dist.sd/cell # number of cells per one sigma
four.sigma.units <- 4*units # number of cells per four sigma IN ONE DIRECTION
if(two.kernels==TRUE) sigma.units <- four.sigma.units
center.cell <- four.sigma.units + 1
cells.in.1D.kernel <- four.sigma.units + four.sigma.units + 1
# total cells going across the one-dimensional kernel are those one either side plus the central/natal one
# make the 1-D kernel
kernel.1d <- rep(NA, cells.in.1D.kernel)
k <- 1
for(i in -four.sigma.units:four.sigma.units){
left.boundary <- (i-0.5)*cell
right.boundary <- (i+0.5)*cell
kernel.1d[k] <- pnorm(q=right.boundary, sd=dist.sd) - pnorm(q=left.boundary, sd=dist.sd)
k <- k+1
}
# actually just take the first half and copy it to the second half, because the numbers slightly differ at the 12th decimal place otherwise.
# might be slightly inaccurate, but will ensure accuracy down the line and a perfect mirror image
kernel.1d <- c(kernel.1d[1:center.cell], kernel.1d[(center.cell-1):1])
# correct to have the halves because the center cell in a sense can be thought of as zero space since not migrating leaves you there
# still need to renormalize because only have the cumulative within 4 sigma
normalized.kernel.1d <- kernel.1d/sum(kernel.1d) # normalize the probabilities to sum to 1
plot(1:cells.in.1D.kernel, normalized.kernel.1d)
middle.of.kernel <- center.cell
# ceiling(length(disp.kernel[,1])/2)
# works because there are an odd number for the length/width
max.dist.include.natal <- middle.of.kernel
# the maximum number of cells an individual might migrate including 1 as staying in natal patch
max.dist.exclude.natal <- middle.of.kernel - 1
# multiply it by itself to create the 2-D
horizontal.to.multiply <- matrix(NA, nrow=length(normalized.kernel.1d), ncol=length(normalized.kernel.1d))
vertical.to.multiply <- matrix(NA, nrow=length(normalized.kernel.1d), ncol=length(normalized.kernel.1d))
for(j in 1:length(normalized.kernel.1d)){
horizontal.to.multiply[j,] <- normalized.kernel.1d
vertical.to.multiply[,j] <- normalized.kernel.1d
}
multiplied.kernels <- horizontal.to.multiply * vertical.to.multiply
# plot the multiplied matrix
#library(graphics) # can be removed because brought in by 'depends'
contour(multiplied.kernels, asp=1, nlevels= 2*four.sigma.units, main="Contour plot of 2-D kernel from multiplying")
# find the cutoff value for distance travelled
# i.e. which contours don't make the full circle around because they travel farther than the central column/row?
lower.cutoff <- multiplied.kernels[1, center.cell]
multiplied.kernels[multiplied.kernels < lower.cutoff] <- 0
# replace values lower than the cutoff with zero
# plot the multiplied matrix that's been cut off to circular distances
contour(multiplied.kernels, asp=1, nlevels= 2*four.sigma.units, main="Contour plot of 2-D kernel from multiplying after cutoff to 8 sigma")
########################################################################################################################
########################################################################################################################
#
# for summing 2 distributions to create kurtosis:
#
# do the above again for a second distribution, sum the 1-D kernels and normalize
#
# *** NOTE ***
# WHEN SUMMING THE KERNELS, MAKE SURE TO ADD AFTER CENTERING AROUND 0
#
# dispersal kernel from 1 patch to surrounding patches
# want it to be Gaussian and vary to having more LDD (long distance dispersal)
if(two.kernels==TRUE){
#second.dist.mean # mean should stay at zero as dispersal is centered around natal patch
#second.dist.sd # this is sigma, one standard deviation, in meters
# scale the landscape, and want to cut off at 4 sigma, so how many cells (in 1-D) are there within 4 sigma:
second.units <- second.dist.sd/cell # number of cells per one sigma
second.four.sigma.units <- sigma.units # number of cells per four sigma IN ONE DIRECTION
second.center.cell <- second.four.sigma.units + 1
second.cells.in.1D.kernel <- second.four.sigma.units + second.four.sigma.units + 1
# total cells going across the one-dimensional kernel are those one either side plus the central/natal one
# make the 1-D kernel
second.kernel.1d <- rep(NA, second.cells.in.1D.kernel)
k <- 1
for(i in -second.four.sigma.units:second.four.sigma.units){
left.boundary <- (i-0.5)*cell
right.boundary <- (i+0.5)*cell
second.kernel.1d[k] <- pnorm(q=right.boundary, sd=second.dist.sd) - pnorm(q=left.boundary, sd=second.dist.sd)
k <- k+1
}
# actually just take the first half and copy it to the second half
# because the numbers slightly differ at the 12th decimal place otherwise.
# might be slightly inaccurate, but will ensure accuracy down the line and a perfect mirror image
second.kernel.1d <- c(second.kernel.1d[1:second.center.cell], second.kernel.1d[(second.center.cell-1):1])
# correct to have the halves because the center cell in a sense can be thought of
# as zero space since not migrating leaves you there
# still need to renormalize because only have the cumulative within 4 sigma
second.normalized.kernel.1d <- second.kernel.1d/sum(second.kernel.1d) # normalize the probabilities to sum to 1
plot(second.normalized.kernel.1d, main="Second 1-D Dispersal Kernel, Normalized")
# DON'T SUM KERNELS UNTIL LATER, FIRST MAKE 2-D TO CORRECT FOR LEPTOKURTIC DIST
# multiply it by itself to create the 2-D
horizontal.to.multiply <- matrix(NA, nrow=length(second.normalized.kernel.1d), ncol=length(second.normalized.kernel.1d))
vertical.to.multiply <- matrix(NA, nrow=length(second.normalized.kernel.1d), ncol=length(second.normalized.kernel.1d))
for(j in 1:length(second.normalized.kernel.1d)){
horizontal.to.multiply[j,] <- second.normalized.kernel.1d
vertical.to.multiply[,j] <- second.normalized.kernel.1d
}
second.multiplied.kernels <- horizontal.to.multiply * vertical.to.multiply
# plot the multiplied matrix
#library(graphics) # can be removed because brought in by 'depends'
contour(second.multiplied.kernels, asp=1, nlevels= 2*second.four.sigma.units, main="Contour plot of 2-D kernel from second distribution")
center.cell <- second.four.sigma.units + 1 ## DO NOT DELETE THIS LINE, NEEDED FOR THE SUMMING OF KERNELS TO CORRECTLY DRAW CUTOFF
# find the cutoff value for distance travelled
# i.e. which contours don't make the full circle around because they travel farther than the central column/row?
lower.cutoff <- second.multiplied.kernels[1, center.cell]
second.multiplied.kernels[second.multiplied.kernels < lower.cutoff] <- 0
# replace values lower than the cutoff with zero
# plot the multiplied matrix that's been cut off to circular distances
filled.contour(second.multiplied.kernels, asp=1, nlevels= 2*second.four.sigma.units, main="Contour plot of 2-D kernel from second distribution after trimming small values", zlim=c(0,(max(second.multiplied.kernels)-max(second.multiplied.kernels)*.1)))
# NOW SUM THE KERNELS AFTER WEIGHTING THEM
prop.first.kernel <- kernel.weighting
prop.second.kernel <- 1 - prop.first.kernel
first.kernel <- prop.first.kernel * multiplied.kernels
second.kernel <- prop.second.kernel * second.multiplied.kernels
multiplied.kernels <- first.kernel + second.kernel
}
# restandardize so all sums to 1
restandardized.multiplied.kernels <- multiplied.kernels/sum(multiplied.kernels)
contour(restandardized.multiplied.kernels, asp=1, nlevels= 2*four.sigma.units, main="Contour plot of restandardized 2-D kernel")
disp.kernel <- restandardized.multiplied.kernels
middle.of.kernel <- center.cell
# ceiling(length(disp.kernel[,1])/2)
# works because there are an odd number for the length/width
max.dist.include.natal <- middle.of.kernel
# the maximum number of cells an individual might migrate including 1 as staying in natal patch
max.dist.exclude.natal <- middle.of.kernel - 1
# TRY AND MAKE A ROUNDED KERNEL THAT STILL SUMS TO 1:
for(i in 5:25){
#print(i)
if(sum(signif(disp.kernel, digits=i))==1){
disp.kernel <- signif(disp.kernel, digits=i)
print(i)
break # exit the loop
}
}
#############################################################################################################################
#
# NOW WE HAVE THE DISPERSAL KERNEL
#
# NEED TO LINEARLY LIST IT IN DECREASING ORDER AND MATCH PATCH IDS TO IT
#
#############################################################################################################################
one.dim.length <- max.dist.exclude.natal + max.dist.include.natal
#dim(disp.kernel)
xcoords <- (-max.dist.exclude.natal):max.dist.exclude.natal
ycoords <- max.dist.exclude.natal:(-max.dist.exclude.natal)
disp.kernel.xcoords <- matrix(rep(xcoords, one.dim.length), nrow= one.dim.length, byrow=TRUE)
disp.kernel.ycoords <- matrix(rep(ycoords, one.dim.length), ncol= one.dim.length, byrow=FALSE)
disp.array <- array(c(disp.kernel, disp.kernel.xcoords, disp.kernel.ycoords), dim=c(one.dim.length, one.dim.length,3))
iterate.by <- seq(1, (one.dim.length^2), by= one.dim.length)
disp.array.data.frame <- data.frame(rep(NA,length(disp.kernel)), rep(NA,length(disp.kernel)), rep(NA,length(disp.kernel)))
names(disp.array.data.frame) <- c("dispersal.prob", "x.dist", "y.dist")
j <- 0
for(i in iterate.by){
j <- j+1
#print(i,j, i:(i+ (one.dim.length-1)))
disp.array.data.frame$dispersal.prob[i:(i+ (one.dim.length-1))] <- disp.array[j,,1]
disp.array.data.frame$x.dist[i:(i+ (one.dim.length-1))] <- disp.array[j,,2]
disp.array.data.frame$y.dist[i:(i+ (one.dim.length-1))] <- disp.array[j,,3]
}
disp.array.data.frame <- disp.array.data.frame[disp.array.data.frame$dispersal.prob > 0 ,]
sorted.disp.frame <- disp.array.data.frame[order(-disp.array.data.frame$dispersal.prob), ]
array.sending.patch.coords <- sorted.disp.frame
ghost.cell <- total.cells+1
absorbing.cell <- ghost.cell+1
num.patches.sending <- length(disp.array.data.frame[,1])
conn.mat <- matrix(NA, nrow= total.cells, ncol= num.patches.sending) # make a matrix to store the connectivity matrix
# it's size is patch number by length of total cells possible to disperse into
# make an identifying number for all patches, go down each column before moving on to the next column
patch.number.ids <- matrix(0, nrow= cells.x, ncol= cells.y)
for(i in 1: (cells.x * cells.y)){
patch.number.ids[i] <- i
}
for(i in 1:total.cells){
focal.patch <- i
for(j in 1:num.patches.sending){
skip <- FALSE
if(j==1){
conn.mat[i,j] <- focal.patch
}else{
if(focal.patch%%cells.x == 0){focal.row <- 20}else{focal.row <- focal.patch%%cells.x}
patch.id.row <- (focal.row + sorted.disp.frame$y.dist[j])
patch.id.col <- (ceiling(focal.patch/cells.x) + sorted.disp.frame$x.dist[j])
if(patch.id.row <= 0 || patch.id.row > cells.x){
conn.mat[i,j] <- absorbing.cell
skip <- TRUE
} # if send to a patch outside the landscape, make it the absorbing patch
if(patch.id.col <= 0 || patch.id.col > cells.y){
conn.mat[i,j] <- absorbing.cell
skip <- TRUE
}
if(skip==FALSE) conn.mat[i,j] <- patch.number.ids[patch.id.row, patch.id.col]
}
}
}
# if making a breed window instead of a dispersal kernel, change the absorbing cell to the ghost.cell
if(breed.window == TRUE){
conn.mat[conn.mat == absorbing.cell] <- ghost.cell
}
kernel <- paste(c("{", paste(sorted.disp.frame$dispersal.prob, collapse=","), "}"), collapse=" ")
# add on the extra rows for the ghost and absorbing patches
conn.mat <- rbind(conn.mat, rep(ghost.cell, num.patches.sending), rep(absorbing.cell, num.patches.sending))
# make it into a data frame so it prints out properly
frame.conn.mat <- data.frame(conn.mat)
write.table(frame.conn.mat, file="ConnMatrix.txt", sep=",", col.names=FALSE, row.names=FALSE)
with.commas <- read.table("ConnMatrix.txt")
with.commas$col1 <- "{"
with.commas$col.last <- "}"
final.connectivity.matrix <- cbind(with.commas$col1, paste(with.commas$V1), with.commas$col.last)
if(breed.window == FALSE) write.table(final.connectivity.matrix, file=paste(c(getwd(), "/", "Dispersal_ConnMatrix.txt"), collapse=""), col.names=FALSE, row.names=FALSE, quote=FALSE)
if(breed.window == TRUE) write.table(final.connectivity.matrix, file=paste(c(getwd(), "/", "Breeding_ConnMatrix.txt"), collapse=""), col.names=FALSE, row.names=FALSE, quote=FALSE)
return(kernel)
}
#' @title Create dispersal or breeding window kernels and connectivity matrices that don't cut off at 4 sigma, but instead at 8
#'
#' @description Automatically create the dispersal and breeding window probability kernels and connectivity matrices of patch IDs based on the provided cell size, number of cells in the x and y directions on the landscape, and the mean and standard deviation of the dispersal kernel. Additionally, two distributions are able to be summed for creating the dispersal kernel.
#'
#' @param cell.size The size in unites distance of a single patch (or cell), which based on the parameters given below will influence how large the landscape is and how many cells are within one unit sigma.
#'
#' @param horizontal.land The size of the landscape in the horizontal direction. Units are the same as cell.size.
#'
#' @param vertical.land The size of the landscape in the vertical direction. Units are the same as cell.size.
#'
#' @param dist.mean The mean distance for the kernel's distribution. Default is zero (i.e. most dispersal occurs to the natal patch).
#'
#' @param dist.sd Sigma (one standard deviation) for the distribution of dispersal distances.
#'
#' @param breed.window A boolean parameter with default FALSE. Change to true if making a breeding window and not a dispersal kernel. This changes the ID of the patch that is at the absorbing boundary of the landscape.
#'
#' @param two.kernels A boolean parameter with default FALSE. If two distributions are being summed to create the kernel, this should be TRUE.
#'
#' @param kernel.weighting The weighting of the first distribution for creating the summed kernels (the second distribution will be one minus this).
#'
#' @param second.dist.mean The mean of the second distribution being summed with the first distribution. The default is zero, as above, but should match the first distribution's mean if that is ever changed from zero.
#'
#' @param second.dist.sd Sigma (one standard deviation) for the distribution of dispersal distances of the second distribution.
#'
#' @return
#'
#' Returns the array of probabilities for the dispersal or breeding window kernels and prints the connectivity matrix to a file.
#'
#' @author Kimberly J Gilbert
#'
#' @import graphics
#'
#' @examples
#'
#' make.kernel.and.matrix(cell.size=50, horizontal.land=1000, vertical.land=2000, dist.mean=0,
#' dist.sd=25, breed.window=TRUE, two.kernels=FALSE, second.dist.mean=0, second.dist.sd=NULL)
#'
#'
#' @export make.kernel.and.matrix.8sigma
make.kernel.and.matrix.8sigma <- function(cell.size, horizontal.land, vertical.land, dist.mean=0, dist.sd, breed.window=FALSE, two.kernels=FALSE, kernel.weighting=0.9, second.dist.mean=0, second.dist.sd=NULL){
cell <- cell.size
cells.x <- vertical.land/cell
cells.y <- horizontal.land/cell
total.cells <- cells.x * cells.y
# scale the landscape, and want to cut off at 4 sigma, so how many cells (in 1-D) are there within 4 sigma:
units <- dist.sd/cell # number of cells per one sigma
eight.sigma.units <- 8*units # number of cells per four sigma IN ONE DIRECTION
if(two.kernels==TRUE) sigma.units <- eight.sigma.units
center.cell <- eight.sigma.units + 1
cells.in.1D.kernel <- eight.sigma.units + eight.sigma.units + 1
# total cells going across the one-dimensional kernel are those one either side plus the central/natal one
# make the 1-D kernel
kernel.1d <- rep(NA, cells.in.1D.kernel)
k <- 1
for(i in -eight.sigma.units:eight.sigma.units){
left.boundary <- (i-0.5)*cell
right.boundary <- (i+0.5)*cell
kernel.1d[k] <- pnorm(q=right.boundary, sd=dist.sd) - pnorm(q=left.boundary, sd=dist.sd)
k <- k+1
}
# actually just take the first half and copy it to the second half, because the numbers slightly differ at the 12th decimal place otherwise.
# might be slightly inaccurate, but will ensure accuracy down the line and a perfect mirror image
kernel.1d <- c(kernel.1d[1:center.cell], kernel.1d[(center.cell-1):1])
# correct to have the halves because the center cell in a sense can be thought of as zero space since not migrating leaves you there
# still need to renormalize because only have the cumulative within 4 sigma
normalized.kernel.1d <- kernel.1d/sum(kernel.1d) # normalize the probabilities to sum to 1
plot(1:cells.in.1D.kernel, normalized.kernel.1d)
middle.of.kernel <- center.cell
# ceiling(length(disp.kernel[,1])/2)
# works because there are an odd number for the length/width
max.dist.include.natal <- middle.of.kernel
# the maximum number of cells an individual might migrate including 1 as staying in natal patch
max.dist.exclude.natal <- middle.of.kernel - 1
# multiply it by itself to create the 2-D
horizontal.to.multiply <- matrix(NA, nrow=length(normalized.kernel.1d), ncol=length(normalized.kernel.1d))
vertical.to.multiply <- matrix(NA, nrow=length(normalized.kernel.1d), ncol=length(normalized.kernel.1d))
for(j in 1:length(normalized.kernel.1d)){
horizontal.to.multiply[j,] <- normalized.kernel.1d
vertical.to.multiply[,j] <- normalized.kernel.1d
}
multiplied.kernels <- horizontal.to.multiply * vertical.to.multiply
# plot the multiplied matrix
#library(graphics) # can be removed because brought in by 'depends'
contour(multiplied.kernels, asp=1, nlevels= 2*eight.sigma.units, main="Contour plot of 2-D kernel from multiplying")
# find the cutoff value for distance travelled
# i.e. which contours don't make the full circle around because they travel farther than the central column/row?
lower.cutoff <- multiplied.kernels[1, center.cell]
multiplied.kernels[multiplied.kernels < lower.cutoff] <- 0
# replace values lower than the cutoff with zero
# plot the multiplied matrix that's been cut off to circular distances
contour(multiplied.kernels, asp=1, nlevels= 2*eight.sigma.units, main="Contour plot of 2-D kernel from multiplying after cutoff to 8 sigma")
########################################################################################################################
########################################################################################################################
#
# for summing 2 distributions to create kurtosis:
#
# do the above again for a second distribution, sum the 1-D kernels and normalize
#
# *** NOTE ***
# WHEN SUMMING THE KERNELS, MAKE SURE TO ADD AFTER CENTERING AROUND 0
#
# dispersal kernel from 1 patch to surrounding patches
# want it to be Gaussian and vary to having more LDD (long distance dispersal)
if(two.kernels==TRUE){
#second.dist.mean # mean should stay at zero as dispersal is centered around natal patch
#second.dist.sd # this is sigma, one standard deviation, in meters
# scale the landscape, and want to cut off at 4 sigma, so how many cells (in 1-D) are there within 4 sigma:
second.units <- second.dist.sd/cell # number of cells per one sigma
second.eight.sigma.units <- sigma.units # number of cells per four sigma IN ONE DIRECTION
second.center.cell <- second.eight.sigma.units + 1
second.cells.in.1D.kernel <- second.eight.sigma.units + second.eight.sigma.units + 1
# total cells going across the one-dimensional kernel are those one either side plus the central/natal one
# make the 1-D kernel
second.kernel.1d <- rep(NA, second.cells.in.1D.kernel)
k <- 1
for(i in -second.eight.sigma.units: second.eight.sigma.units){
left.boundary <- (i-0.5)*cell
right.boundary <- (i+0.5)*cell
second.kernel.1d[k] <- pnorm(q=right.boundary, sd=second.dist.sd) - pnorm(q=left.boundary, sd=second.dist.sd)
k <- k+1
}
# actually just take the first half and copy it to the second half
# because the numbers slightly differ at the 12th decimal place otherwise.
# might be slightly inaccurate, but will ensure accuracy down the line and a perfect mirror image
second.kernel.1d <- c(second.kernel.1d[1:second.center.cell], second.kernel.1d[(second.center.cell-1):1])
# correct to have the halves because the center cell in a sense can be thought of
# as zero space since not migrating leaves you there
# still need to renormalize because only have the cumulative within 4 sigma
second.normalized.kernel.1d <- second.kernel.1d/sum(second.kernel.1d) # normalize the probabilities to sum to 1
plot(second.normalized.kernel.1d, main="Second 1-D Dispersal Kernel, Normalized")
# DON'T SUM KERNELS UNTIL LATER, FIRST MAKE 2-D TO CORRECT FOR LEPTOKURTIC DIST
# prop.first.kernel <- kernel.weighting
# prop.second.kernel <- 1 - prop.first.kernel
# summed.1d.kernels <- (long.normalized.kernel.1d * prop.first.kernel) + (second.normalized.kernel.1d * prop.second.kernel)
# multiply it by itself to create the 2-D
horizontal.to.multiply <- matrix(NA, nrow=length(second.normalized.kernel.1d), ncol=length(second.normalized.kernel.1d))
vertical.to.multiply <- matrix(NA, nrow=length(second.normalized.kernel.1d), ncol=length(second.normalized.kernel.1d))
for(j in 1:length(second.normalized.kernel.1d)){
horizontal.to.multiply[j,] <- second.normalized.kernel.1d
vertical.to.multiply[,j] <- second.normalized.kernel.1d
}
second.multiplied.kernels <- horizontal.to.multiply * vertical.to.multiply
# plot the multiplied matrix
#library(graphics) # can be removed because brought in by 'depends'
contour(second.multiplied.kernels, asp=1, nlevels= 2*second.eight.sigma.units, main="Contour plot of 2-D kernel from second distribution")
center.cell <- second.eight.sigma.units + 1 ## DO NOT DELETE THIS LINE, NEEDED FOR THE SUMMING OF KERNELS TO CORRECTLY DRAW CUTOFF
# find the cutoff value for distance travelled
# i.e. which contours don't make the full circle around because they travel farther than the central column/row?
lower.cutoff <- second.multiplied.kernels[1, center.cell]
second.multiplied.kernels[second.multiplied.kernels < lower.cutoff] <- 0
# replace values lower than the cutoff with zero
# plot the multiplied matrix that's been cut off to circular distances
filled.contour(second.multiplied.kernels, asp=1, nlevels= 2*second.eight.sigma.units, main="Contour plot of 2-D kernel from second distribution after trimming small values", zlim=c(0,(max(second.multiplied.kernels)-max(second.multiplied.kernels)*.1)))
# prop.first.kernel <- kernel.weighting
# prop.second.kernel <- 1 - prop.first.kernel
# summed.1d.kernels <- (long.normalized.kernel.1d * prop.first.kernel) + (second.normalized.kernel.1d * prop.second.kernel)
# NOW SUM THE KERNELS AFTER WEIGHTING THEM
prop.first.kernel <- kernel.weighting
prop.second.kernel <- 1 - prop.first.kernel
first.kernel <- prop.first.kernel * multiplied.kernels
second.kernel <- prop.second.kernel * second.multiplied.kernels
multiplied.kernels <- first.kernel + second.kernel
}
# restandardize so all sums to 1
restandardized.multiplied.kernels <- multiplied.kernels/sum(multiplied.kernels)
contour(restandardized.multiplied.kernels, asp=1, nlevels= 2*eight.sigma.units, main="Contour plot of restandardized 2-D kernel")
disp.kernel <- restandardized.multiplied.kernels
middle.of.kernel <- center.cell
# ceiling(length(disp.kernel[,1])/2)
# works because there are an odd number for the length/width
max.dist.include.natal <- middle.of.kernel
# the maximum number of cells an individual might migrate including 1 as staying in natal patch
max.dist.exclude.natal <- middle.of.kernel - 1
# TRY AND MAKE A ROUNDED KERNEL THAT STILL SUMS TO 1:
for(i in 5:25){
#print(i)
if(sum(signif(disp.kernel, digits=i))==1){
disp.kernel <- signif(disp.kernel, digits=i)
print(i)
break # exit the loop
}
}
#############################################################################################################################
#
# NOW WE HAVE THE DISPERSAL KERNEL
#
# NEED TO LINEARLY LIST IT IN DECREASING ORDER AND MATCH PATCH IDS TO IT
#
#############################################################################################################################
one.dim.length <- max.dist.exclude.natal + max.dist.include.natal
#dim(disp.kernel)
xcoords <- (-max.dist.exclude.natal):max.dist.exclude.natal
ycoords <- max.dist.exclude.natal:(-max.dist.exclude.natal)
disp.kernel.xcoords <- matrix(rep(xcoords, one.dim.length), nrow= one.dim.length, byrow=TRUE)
disp.kernel.ycoords <- matrix(rep(ycoords, one.dim.length), ncol= one.dim.length, byrow=FALSE)
disp.array <- array(c(disp.kernel, disp.kernel.xcoords, disp.kernel.ycoords), dim=c(one.dim.length, one.dim.length,3))
iterate.by <- seq(1, (one.dim.length^2), by= one.dim.length)
disp.array.data.frame <- data.frame(rep(NA,length(disp.kernel)), rep(NA,length(disp.kernel)), rep(NA,length(disp.kernel)))
names(disp.array.data.frame) <- c("dispersal.prob", "x.dist", "y.dist")
j <- 0
for(i in iterate.by){
j <- j+1
#print(i,j, i:(i+ (one.dim.length-1)))
disp.array.data.frame$dispersal.prob[i:(i+ (one.dim.length-1))] <- disp.array[j,,1]
disp.array.data.frame$x.dist[i:(i+ (one.dim.length-1))] <- disp.array[j,,2]
disp.array.data.frame$y.dist[i:(i+ (one.dim.length-1))] <- disp.array[j,,3]
}
disp.array.data.frame <- disp.array.data.frame[disp.array.data.frame$dispersal.prob > 0 ,]
sorted.disp.frame <- disp.array.data.frame[order(-disp.array.data.frame$dispersal.prob), ]
array.sending.patch.coords <- sorted.disp.frame
ghost.cell <- total.cells+1
absorbing.cell <- ghost.cell+1
num.patches.sending <- length(disp.array.data.frame[,1])
conn.mat <- matrix(NA, nrow= total.cells, ncol= num.patches.sending) # make a matrix to store the connectivity matrix
# it's size is patch number by length of total cells possible to disperse into
# make an identifying number for all patches, go down each column before moving on to the next column
patch.number.ids <- matrix(0, nrow= cells.x, ncol= cells.y)
for(i in 1: (cells.x * cells.y)){
patch.number.ids[i] <- i
}
for(i in 1:total.cells){
focal.patch <- i
for(j in 1:num.patches.sending){
skip <- FALSE
if(j==1){
conn.mat[i,j] <- focal.patch
}else{
if(focal.patch%%cells.x == 0){focal.row <- 20}else{focal.row <- focal.patch%%cells.x}
patch.id.row <- (focal.row + sorted.disp.frame$y.dist[j])
patch.id.col <- (ceiling(focal.patch/cells.x) + sorted.disp.frame$x.dist[j])
if(patch.id.row <= 0 || patch.id.row > cells.x){
conn.mat[i,j] <- absorbing.cell
skip <- TRUE
} # if send to a patch outside the landscape, make it the absorbing patch
if(patch.id.col <= 0 || patch.id.col > cells.y){
conn.mat[i,j] <- absorbing.cell
skip <- TRUE
}
if(skip==FALSE) conn.mat[i,j] <- patch.number.ids[patch.id.row, patch.id.col]
}
}
}
# if making a breed window instead of a dispersal kernel, change the absorbing cell to the ghost.cell
if(breed.window == TRUE){
conn.mat[conn.mat == absorbing.cell] <- ghost.cell
}
kernel <- paste(c("{", paste(sorted.disp.frame$dispersal.prob, collapse=","), "}"), collapse=" ")
# add on the extra rows for the ghost and absorbing patches
conn.mat <- rbind(conn.mat, rep(ghost.cell, num.patches.sending), rep(absorbing.cell, num.patches.sending))
# make it into a data frame so it prints out properly
frame.conn.mat <- data.frame(conn.mat)
write.table(frame.conn.mat, file="ConnMatrix.txt", sep=",", col.names=FALSE, row.names=FALSE)
with.commas <- read.table("ConnMatrix.txt")
with.commas$col1 <- "{"
with.commas$col.last <- "}"
final.connectivity.matrix <- cbind(with.commas$col1, paste(with.commas$V1), with.commas$col.last)
if(breed.window == FALSE) write.table(final.connectivity.matrix, file=paste(c(getwd(), "/", "Dispersal_ConnMatrix.txt"), collapse=""), col.names=FALSE, row.names=FALSE, quote=FALSE)
if(breed.window == TRUE) write.table(final.connectivity.matrix, file=paste(c(getwd(), "/", "Breeding_ConnMatrix.txt"), collapse=""), col.names=FALSE, row.names=FALSE, quote=FALSE)
return(kernel)
}
#' @title Create dispersal or breeding window kernels and connectivity matrices that don't cut off at 4 sigma, but instead at 8, and creates the full matrix for the new version of nemo, so is patch number by patch number in size.
#'
#' @description Automatically create the dispersal and breeding window probability kernels and connectivity matrices of patch IDs based on the provided cell size, number of cells in the x and y directions on the landscape, and the mean and standard deviation of the dispersal kernel. Additionally, two distributions are able to be summed for creating the dispersal kernel.
#'
#' @param cell.size The size in unites distance of a single patch (or cell), which based on the parameters given below will influence how large the landscape is and how many cells are within one unit sigma.
#'
#' @param horizontal.land The size of the landscape in the horizontal direction. Units are the same as cell.size.
#'
#' @param vertical.land The size of the landscape in the vertical direction. Units are the same as cell.size.
#'
#' @param dist.mean The mean distance for the kernel's distribution. Default is zero (i.e. most dispersal occurs to the natal patch).
#'
#' @param dist.sd Sigma (one standard deviation) for the distribution of dispersal distances.
#'
#' @param two.kernels A boolean parameter with default FALSE. If two distributions are being summed to create the kernel, this should be TRUE.
#'
#' @param kernel.weighting The weighting of the first distribution for creating the summed kernels (the second distribution will be one minus this).
#'
#' @param second.dist.mean The mean of the second distribution being summed with the first distribution. The default is zero, as above, but should match the first distribution's mean if that is ever changed from zero.
#'
#' @param second.dist.sd Sigma (one standard deviation) for the distribution of dispersal distances of the second distribution.
#'
#' @return
#'
#' Returns the array of probabilities for the dispersal or breeding window kernels and prints the connectivity matrix to a file.
#'
#' @author Kimberly J Gilbert
#'
#' @import graphics
#'
#' @examples
#'
#' make.kernel.and.matrix(cell.size=50, horizontal.land=1000, vertical.land=2000, dist.mean=0,
#' dist.sd=25, two.kernels=FALSE, second.dist.mean=0, second.dist.sd=NULL)
#'
#'
#' @export disp.kern.new.nemo.sig8
disp.kern.new.nemo.sig8 <- function(cell.size, horizontal.land, vertical.land, dist.mean=0, dist.sd, two.kernels=FALSE, kernel.weighting=0.9, second.dist.mean=0, second.dist.sd=NULL){
cell <- cell.size
cells.x <- vertical.land/cell
cells.y <- horizontal.land/cell
total.cells <- cells.x * cells.y
# scale the landscape, and want to cut off at 4 sigma, so how many cells (in 1-D) are there within 4 sigma:
units <- dist.sd/cell # number of cells per one sigma
eight.sigma.units <- 8*units # number of cells per four sigma IN ONE DIRECTION
if(two.kernels==TRUE) sigma.units <- eight.sigma.units
center.cell <- eight.sigma.units + 1
cells.in.1D.kernel <- eight.sigma.units + eight.sigma.units + 1
# total cells going across the one-dimensional kernel are those one either side plus the central/natal one
# make the 1-D kernel
kernel.1d <- rep(NA, cells.in.1D.kernel)
k <- 1
for(i in -eight.sigma.units:eight.sigma.units){
left.boundary <- (i-0.5)*cell
right.boundary <- (i+0.5)*cell
kernel.1d[k] <- pnorm(q=right.boundary, sd=dist.sd) - pnorm(q=left.boundary, sd=dist.sd)
k <- k+1
}
# actually just take the first half and copy it to the second half, because the numbers slightly differ at the 12th decimal place otherwise.
# might be slightly inaccurate, but will ensure accuracy down the line and a perfect mirror image
kernel.1d <- c(kernel.1d[1:center.cell], kernel.1d[(center.cell-1):1])
# correct to have the halves because the center cell in a sense can be thought of as zero space since not migrating leaves you there
# still need to renormalize because only have the cumulative within 4 sigma
normalized.kernel.1d <- kernel.1d/sum(kernel.1d) # normalize the probabilities to sum to 1
plot(1:cells.in.1D.kernel, normalized.kernel.1d)
middle.of.kernel <- center.cell
# ceiling(length(disp.kernel[,1])/2)
# works because there are an odd number for the length/width
max.dist.include.natal <- middle.of.kernel
# the maximum number of cells an individual might migrate including 1 as staying in natal patch
max.dist.exclude.natal <- middle.of.kernel - 1
# multiply it by itself to create the 2-D
horizontal.to.multiply <- matrix(NA, nrow=length(normalized.kernel.1d), ncol=length(normalized.kernel.1d))
vertical.to.multiply <- matrix(NA, nrow=length(normalized.kernel.1d), ncol=length(normalized.kernel.1d))
for(j in 1:length(normalized.kernel.1d)){
horizontal.to.multiply[j,] <- normalized.kernel.1d
vertical.to.multiply[,j] <- normalized.kernel.1d
}
multiplied.kernels <- horizontal.to.multiply * vertical.to.multiply
# plot the multiplied matrix
#library(graphics) # can be removed because brought in by 'depends'
contour(multiplied.kernels, asp=1, nlevels= 2*eight.sigma.units, main="Contour plot of 2-D kernel from multiplying")
# find the cutoff value for distance travelled
# i.e. which contours don't make the full circle around because they travel farther than the central column/row?
lower.cutoff <- multiplied.kernels[1, center.cell]
multiplied.kernels[multiplied.kernels < lower.cutoff] <- 0
# replace values lower than the cutoff with zero
# plot the multiplied matrix that's been cut off to circular distances
contour(multiplied.kernels, asp=1, nlevels= 2*eight.sigma.units, main="Contour plot of 2-D kernel from multiplying after cutoff to 8 sigma")
########################################################################################################################
########################################################################################################################
#
# for summing 2 distributions to create kurtosis:
#
# do the above again for a second distribution, sum the 1-D kernels and normalize
#
# *** NOTE ***
# WHEN SUMMING THE KERNELS, MAKE SURE TO ADD AFTER CENTERING AROUND 0
#
# dispersal kernel from 1 patch to surrounding patches
# want it to be Gaussian and vary to having more LDD (long distance dispersal)
if(two.kernels==TRUE){
#second.dist.mean # mean should stay at zero as dispersal is centered around natal patch
#second.dist.sd # this is sigma, one standard deviation, in meters
# scale the landscape, and want to cut off at 4 sigma, so how many cells (in 1-D) are there within 4 sigma:
second.units <- second.dist.sd/cell # number of cells per one sigma
second.eight.sigma.units <- sigma.units # number of cells per four sigma IN ONE DIRECTION
second.center.cell <- second.eight.sigma.units + 1
second.cells.in.1D.kernel <- second.eight.sigma.units + second.eight.sigma.units + 1
# total cells going across the one-dimensional kernel are those one either side plus the central/natal one
# make the 1-D kernel
second.kernel.1d <- rep(NA, second.cells.in.1D.kernel)
k <- 1
for(i in -second.eight.sigma.units: second.eight.sigma.units){
left.boundary <- (i-0.5)*cell
right.boundary <- (i+0.5)*cell
second.kernel.1d[k] <- pnorm(q=right.boundary, sd=second.dist.sd) - pnorm(q=left.boundary, sd=second.dist.sd)
k <- k+1
}
# actually just take the first half and copy it to the second half
# because the numbers slightly differ at the 12th decimal place otherwise.
# might be slightly inaccurate, but will ensure accuracy down the line and a perfect mirror image
second.kernel.1d <- c(second.kernel.1d[1:second.center.cell], second.kernel.1d[(second.center.cell-1):1])
# correct to have the halves because the center cell in a sense can be thought of
# as zero space since not migrating leaves you there
# still need to renormalize because only have the cumulative within 4 sigma
second.normalized.kernel.1d <- second.kernel.1d/sum(second.kernel.1d) # normalize the probabilities to sum to 1
plot(second.normalized.kernel.1d, main="Second 1-D Dispersal Kernel, Normalized")
# DON'T SUM KERNELS UNTIL LATER, FIRST MAKE 2-D TO CORRECT FOR LEPTOKURTIC DIST
# prop.first.kernel <- kernel.weighting
# prop.second.kernel <- 1 - prop.first.kernel
# summed.1d.kernels <- (long.normalized.kernel.1d * prop.first.kernel) + (second.normalized.kernel.1d * prop.second.kernel)
# multiply it by itself to create the 2-D
horizontal.to.multiply <- matrix(NA, nrow=length(second.normalized.kernel.1d), ncol=length(second.normalized.kernel.1d))
vertical.to.multiply <- matrix(NA, nrow=length(second.normalized.kernel.1d), ncol=length(second.normalized.kernel.1d))
for(j in 1:length(second.normalized.kernel.1d)){
horizontal.to.multiply[j,] <- second.normalized.kernel.1d
vertical.to.multiply[,j] <- second.normalized.kernel.1d
}
second.multiplied.kernels <- horizontal.to.multiply * vertical.to.multiply
# plot the multiplied matrix
#library(graphics) # can be removed because brought in by 'depends'
contour(second.multiplied.kernels, asp=1, nlevels= 2*second.eight.sigma.units, main="Contour plot of 2-D kernel from second distribution")
center.cell <- second.eight.sigma.units + 1 ## DO NOT DELETE THIS LINE, NEEDED FOR THE SUMMING OF KERNELS TO CORRECTLY DRAW CUTOFF
# find the cutoff value for distance travelled
# i.e. which contours don't make the full circle around because they travel farther than the central column/row?
lower.cutoff <- second.multiplied.kernels[1, center.cell]
second.multiplied.kernels[second.multiplied.kernels < lower.cutoff] <- 0
# replace values lower than the cutoff with zero
# plot the multiplied matrix that's been cut off to circular distances
filled.contour(second.multiplied.kernels, asp=1, nlevels= 2*second.eight.sigma.units, main="Contour plot of 2-D kernel from second distribution after trimming small values", zlim=c(0,(max(second.multiplied.kernels)-max(second.multiplied.kernels)*.1)))
# prop.first.kernel <- kernel.weighting
# prop.second.kernel <- 1 - prop.first.kernel
# summed.1d.kernels <- (long.normalized.kernel.1d * prop.first.kernel) + (second.normalized.kernel.1d * prop.second.kernel)
# NOW SUM THE KERNELS AFTER WEIGHTING THEM
prop.first.kernel <- kernel.weighting
prop.second.kernel <- 1 - prop.first.kernel
first.kernel <- prop.first.kernel * multiplied.kernels
second.kernel <- prop.second.kernel * second.multiplied.kernels
multiplied.kernels <- first.kernel + second.kernel
}
# restandardize so all sums to 1
restandardized.multiplied.kernels <- multiplied.kernels/sum(multiplied.kernels)
contour(restandardized.multiplied.kernels, asp=1, nlevels= 2*eight.sigma.units, main="Contour plot of restandardized 2-D kernel")
disp.kernel <- restandardized.multiplied.kernels
middle.of.kernel <- center.cell
# ceiling(length(disp.kernel[,1])/2)
# works because there are an odd number for the length/width
max.dist.include.natal <- middle.of.kernel
# the maximum number of cells an individual might migrate including 1 as staying in natal patch
max.dist.exclude.natal <- middle.of.kernel - 1
# TRY AND MAKE A ROUNDED KERNEL THAT STILL SUMS TO 1:
for(i in 5:25){
#print(i)
if(sum(signif(disp.kernel, digits=i))==1){
disp.kernel <- signif(disp.kernel, digits=i)
print(i)
break # exit the loop
}
}
#############################################################################################################################
#
# NOW WE HAVE THE DISPERSAL KERNEL
#
# NEED TO LINEARLY LIST IT IN DECREASING ORDER AND MATCH PATCH IDS TO IT
#
#############################################################################################################################
one.dim.length <- max.dist.exclude.natal + max.dist.include.natal
#dim(disp.kernel)
xcoords <- (-max.dist.exclude.natal):max.dist.exclude.natal
ycoords <- max.dist.exclude.natal:(-max.dist.exclude.natal)
disp.kernel.xcoords <- matrix(rep(xcoords, one.dim.length), nrow= one.dim.length, byrow=TRUE)
disp.kernel.ycoords <- matrix(rep(ycoords, one.dim.length), ncol= one.dim.length, byrow=FALSE)
disp.array <- array(c(disp.kernel, disp.kernel.xcoords, disp.kernel.ycoords), dim=c(one.dim.length, one.dim.length,3))
iterate.by <- seq(1, (one.dim.length^2), by= one.dim.length)
disp.array.data.frame <- data.frame(rep(NA,length(disp.kernel)), rep(NA,length(disp.kernel)), rep(NA,length(disp.kernel)))
names(disp.array.data.frame) <- c("dispersal.prob", "x.dist", "y.dist")
j <- 0
for(i in iterate.by){
j <- j+1
#print(i,j, i:(i+ (one.dim.length-1)))
disp.array.data.frame$dispersal.prob[i:(i+ (one.dim.length-1))] <- disp.array[j,,1]
disp.array.data.frame$x.dist[i:(i+ (one.dim.length-1))] <- disp.array[j,,2]
disp.array.data.frame$y.dist[i:(i+ (one.dim.length-1))] <- disp.array[j,,3]
}
disp.array.data.frame <- disp.array.data.frame[disp.array.data.frame$dispersal.prob > 0 ,]
sorted.disp.frame <- disp.array.data.frame[order(-disp.array.data.frame$dispersal.prob), ]
array.sending.patch.coords <- sorted.disp.frame
ghost.cell <- total.cells+1
absorbing.cell <- ghost.cell+1
num.patches.sending <- length(disp.array.data.frame[,1])
conn.mat <- matrix(NA, nrow= total.cells, ncol= num.patches.sending) # make a matrix to store the connectivity matrix
# it's size is patch number by length of total cells possible to disperse into
# make an identifying number for all patches, go down each column before moving on to the next column
patch.number.ids <- matrix(0, nrow= cells.x, ncol= cells.y)
for(i in 1: (cells.x * cells.y)){
patch.number.ids[i] <- i
}
for(i in 1:total.cells){
focal.patch <- i
for(j in 1:num.patches.sending){
skip <- FALSE
if(j==1){
conn.mat[i,j] <- focal.patch
}else{
if(focal.patch%%cells.x == 0){focal.row <- 20}else{focal.row <- focal.patch%%cells.x}
patch.id.row <- (focal.row + sorted.disp.frame$y.dist[j])
patch.id.col <- (ceiling(focal.patch/cells.x) + sorted.disp.frame$x.dist[j])
if(patch.id.row <= 0 || patch.id.row > cells.x){
conn.mat[i,j] <- absorbing.cell
skip <- TRUE
} # if send to a patch outside the landscape, make it the absorbing patch
if(patch.id.col <= 0 || patch.id.col > cells.y){
conn.mat[i,j] <- absorbing.cell
skip <- TRUE
}
if(skip==FALSE) conn.mat[i,j] <- patch.number.ids[patch.id.row, patch.id.col]
}
}
}
kernel <- paste(c("{", paste(sorted.disp.frame$dispersal.prob, collapse=","), "}"), collapse=" ")
expanded.kernel <- paste(c("{", rep(kernel, times=total.cells+2), "}"), collapse="\n")
write.table(expanded.kernel, file="ExpandedDispKernel.txt", sep=",", col.names=FALSE, row.names=FALSE)
# add on the extra rows for the ghost and absorbing patches
conn.mat <- rbind(conn.mat, rep(ghost.cell, num.patches.sending), rep(absorbing.cell, num.patches.sending))
# make it into a data frame so it prints out properly
frame.conn.mat <- data.frame(conn.mat)
write.table(frame.conn.mat, file="ConnMatrix.txt", sep=",", col.names=FALSE, row.names=FALSE)
with.commas <- read.table("ConnMatrix.txt")
with.commas$col1 <- "{"
with.commas$col.last <- "}"
final.connectivity.matrix <- cbind(with.commas$col1, paste(with.commas$V1), with.commas$col.last)
write.table(final.connectivity.matrix, file=paste(c(getwd(), "/", "Dispersal_ConnMatrix.txt"), collapse=""), col.names=FALSE, row.names=FALSE, quote=FALSE)
return(kernel)
}
#' @title Create dispersal or breeding window kernels and connectivity matrices that have the full matrix for the new version of nemo, so is patch number by patch number in size.
#'
#' @description Automatically create the dispersal and breeding window probability kernels and connectivity matrices of patch IDs based on the provided cell size, number of cells in the x and y directions on the landscape, and the mean and standard deviation of the dispersal kernel. Additionally, two distributions are able to be summed for creating the dispersal kernel.
#'
#' @param cell.size The size in unites distance of a single patch (or cell), which based on the parameters given below will influence how large the landscape is and how many cells are within one unit sigma.
#'
#' @param horizontal.land The size of the landscape in the horizontal direction. Units are the same as cell.size.
#'
#' @param vertical.land The size of the landscape in the vertical direction. Units are the same as cell.size.
#'
#' @param dist.mean The mean distance for the kernel's distribution. Default is zero (i.e. most dispersal occurs to the natal patch).
#'
#' @param dist.sd Sigma (one standard deviation) for the distribution of dispersal distances.
#'
#' @param two.kernels A boolean parameter with default FALSE. If two distributions are being summed to create the kernel, this should be TRUE.
#'
#' @param kernel.weighting The weighting of the first distribution for creating the summed kernels (the second distribution will be one minus this).
#'
#' @param second.dist.mean The mean of the second distribution being summed with the first distribution. The default is zero, as above, but should match the first distribution's mean if that is ever changed from zero.
#'
#' @param second.dist.sd Sigma (one standard deviation) for the distribution of dispersal distances of the second distribution.
#'
#' @return
#'
#' Returns the array of probabilities for the dispersal or breeding window kernels and prints the connectivity matrix to a file.
#'
#' @author Kimberly J Gilbert
#'
#' @import graphics
#'
#' @examples
#'
#' make.kernel.and.matrix(cell.size=50, horizontal.land=1000, vertical.land=2000, dist.mean=0,
#' dist.sd=25, two.kernels=FALSE, second.dist.mean=0, second.dist.sd=NULL)
#'
#'
#' @export disp.kern.new.nemo.sig4
disp.kern.new.nemo.sig4 <- function(cell.size, horizontal.land, vertical.land, dist.mean=0, dist.sd, two.kernels=FALSE, kernel.weighting=0.9, second.dist.mean=0, second.dist.sd=NULL){
cell <- cell.size
cells.x <- vertical.land/cell
cells.y <- horizontal.land/cell
total.cells <- cells.x * cells.y
# scale the landscape, and want to cut off at 4 sigma, so how many cells (in 1-D) are there within 4 sigma:
units <- dist.sd/cell # number of cells per one sigma
eight.sigma.units <- 4*units # number of cells per four sigma IN ONE DIRECTION
if(two.kernels==TRUE) sigma.units <- eight.sigma.units
center.cell <- eight.sigma.units + 1
cells.in.1D.kernel <- eight.sigma.units + eight.sigma.units + 1
# total cells going across the one-dimensional kernel are those one either side plus the central/natal one
# make the 1-D kernel
kernel.1d <- rep(NA, cells.in.1D.kernel)
k <- 1
for(i in -eight.sigma.units:eight.sigma.units){
left.boundary <- (i-0.5)*cell
right.boundary <- (i+0.5)*cell
kernel.1d[k] <- pnorm(q=right.boundary, sd=dist.sd) - pnorm(q=left.boundary, sd=dist.sd)
k <- k+1
}
# actually just take the first half and copy it to the second half, because the numbers slightly differ at the 12th decimal place otherwise.
# might be slightly inaccurate, but will ensure accuracy down the line and a perfect mirror image
kernel.1d <- c(kernel.1d[1:center.cell], kernel.1d[(center.cell-1):1])
# correct to have the halves because the center cell in a sense can be thought of as zero space since not migrating leaves you there
# still need to renormalize because only have the cumulative within 4 sigma
normalized.kernel.1d <- kernel.1d/sum(kernel.1d) # normalize the probabilities to sum to 1
plot(1:cells.in.1D.kernel, normalized.kernel.1d)
middle.of.kernel <- center.cell
# ceiling(length(disp.kernel[,1])/2)
# works because there are an odd number for the length/width
max.dist.include.natal <- middle.of.kernel
# the maximum number of cells an individual might migrate including 1 as staying in natal patch
max.dist.exclude.natal <- middle.of.kernel - 1
# multiply it by itself to create the 2-D
horizontal.to.multiply <- matrix(NA, nrow=length(normalized.kernel.1d), ncol=length(normalized.kernel.1d))
vertical.to.multiply <- matrix(NA, nrow=length(normalized.kernel.1d), ncol=length(normalized.kernel.1d))
for(j in 1:length(normalized.kernel.1d)){
horizontal.to.multiply[j,] <- normalized.kernel.1d
vertical.to.multiply[,j] <- normalized.kernel.1d
}
multiplied.kernels <- horizontal.to.multiply * vertical.to.multiply
# plot the multiplied matrix
#library(graphics) # can be removed because brought in by 'depends'
contour(multiplied.kernels, asp=1, nlevels= 2*eight.sigma.units, main="Contour plot of 2-D kernel from multiplying")
# find the cutoff value for distance travelled
# i.e. which contours don't make the full circle around because they travel farther than the central column/row?
lower.cutoff <- multiplied.kernels[1, center.cell]
multiplied.kernels[multiplied.kernels < lower.cutoff] <- 0
# replace values lower than the cutoff with zero
# plot the multiplied matrix that's been cut off to circular distances
contour(multiplied.kernels, asp=1, nlevels= 2*eight.sigma.units, main="Contour plot of 2-D kernel from multiplying after cutoff to 4 sigma")
########################################################################################################################
########################################################################################################################
#
# for summing 2 distributions to create kurtosis:
#
# do the above again for a second distribution, sum the 1-D kernels and normalize
#
# *** NOTE ***
# WHEN SUMMING THE KERNELS, MAKE SURE TO ADD AFTER CENTERING AROUND 0
#
# dispersal kernel from 1 patch to surrounding patches
# want it to be Gaussian and vary to having more LDD (long distance dispersal)
if(two.kernels==TRUE){
#second.dist.mean # mean should stay at zero as dispersal is centered around natal patch
#second.dist.sd # this is sigma, one standard deviation, in meters
# scale the landscape, and want to cut off at 4 sigma, so how many cells (in 1-D) are there within 4 sigma:
second.units <- second.dist.sd/cell # number of cells per one sigma
second.eight.sigma.units <- sigma.units # number of cells per four sigma IN ONE DIRECTION
second.center.cell <- second.eight.sigma.units + 1
second.cells.in.1D.kernel <- second.eight.sigma.units + second.eight.sigma.units + 1
# total cells going across the one-dimensional kernel are those one either side plus the central/natal one
# make the 1-D kernel
second.kernel.1d <- rep(NA, second.cells.in.1D.kernel)
k <- 1
for(i in -second.eight.sigma.units: second.eight.sigma.units){
left.boundary <- (i-0.5)*cell
right.boundary <- (i+0.5)*cell
second.kernel.1d[k] <- pnorm(q=right.boundary, sd=second.dist.sd) - pnorm(q=left.boundary, sd=second.dist.sd)
k <- k+1
}
# actually just take the first half and copy it to the second half
# because the numbers slightly differ at the 12th decimal place otherwise.
# might be slightly inaccurate, but will ensure accuracy down the line and a perfect mirror image
second.kernel.1d <- c(second.kernel.1d[1:second.center.cell], second.kernel.1d[(second.center.cell-1):1])
# correct to have the halves because the center cell in a sense can be thought of
# as zero space since not migrating leaves you there
# still need to renormalize because only have the cumulative within 4 sigma
second.normalized.kernel.1d <- second.kernel.1d/sum(second.kernel.1d) # normalize the probabilities to sum to 1
plot(second.normalized.kernel.1d, main="Second 1-D Dispersal Kernel, Normalized")
# DON'T SUM KERNELS UNTIL LATER, FIRST MAKE 2-D TO CORRECT FOR LEPTOKURTIC DIST
# prop.first.kernel <- kernel.weighting
# prop.second.kernel <- 1 - prop.first.kernel
# summed.1d.kernels <- (long.normalized.kernel.1d * prop.first.kernel) + (second.normalized.kernel.1d * prop.second.kernel)
# multiply it by itself to create the 2-D
horizontal.to.multiply <- matrix(NA, nrow=length(second.normalized.kernel.1d), ncol=length(second.normalized.kernel.1d))
vertical.to.multiply <- matrix(NA, nrow=length(second.normalized.kernel.1d), ncol=length(second.normalized.kernel.1d))
for(j in 1:length(second.normalized.kernel.1d)){
horizontal.to.multiply[j,] <- second.normalized.kernel.1d
vertical.to.multiply[,j] <- second.normalized.kernel.1d
}
second.multiplied.kernels <- horizontal.to.multiply * vertical.to.multiply
# plot the multiplied matrix
#library(graphics) # can be removed because brought in by 'depends'
contour(second.multiplied.kernels, asp=1, nlevels= 2*second.eight.sigma.units, main="Contour plot of 2-D kernel from second distribution")
center.cell <- second.eight.sigma.units + 1 ## DO NOT DELETE THIS LINE, NEEDED FOR THE SUMMING OF KERNELS TO CORRECTLY DRAW CUTOFF
# find the cutoff value for distance travelled
# i.e. which contours don't make the full circle around because they travel farther than the central column/row?
lower.cutoff <- second.multiplied.kernels[1, center.cell]
second.multiplied.kernels[second.multiplied.kernels < lower.cutoff] <- 0
# replace values lower than the cutoff with zero
# plot the multiplied matrix that's been cut off to circular distances
filled.contour(second.multiplied.kernels, asp=1, nlevels= 2*second.eight.sigma.units, main="Contour plot of 2-D kernel from second distribution after trimming small values", zlim=c(0,(max(second.multiplied.kernels)-max(second.multiplied.kernels)*.1)))
# prop.first.kernel <- kernel.weighting
# prop.second.kernel <- 1 - prop.first.kernel
# summed.1d.kernels <- (long.normalized.kernel.1d * prop.first.kernel) + (second.normalized.kernel.1d * prop.second.kernel)
# NOW SUM THE KERNELS AFTER WEIGHTING THEM
prop.first.kernel <- kernel.weighting
prop.second.kernel <- 1 - prop.first.kernel
first.kernel <- prop.first.kernel * multiplied.kernels
second.kernel <- prop.second.kernel * second.multiplied.kernels
multiplied.kernels <- first.kernel + second.kernel
}
# restandardize so all sums to 1
restandardized.multiplied.kernels <- multiplied.kernels/sum(multiplied.kernels)
contour(restandardized.multiplied.kernels, asp=1, nlevels= 2*eight.sigma.units, main="Contour plot of restandardized 2-D kernel")
disp.kernel <- restandardized.multiplied.kernels
middle.of.kernel <- center.cell
# ceiling(length(disp.kernel[,1])/2)
# works because there are an odd number for the length/width
max.dist.include.natal <- middle.of.kernel
# the maximum number of cells an individual might migrate including 1 as staying in natal patch
max.dist.exclude.natal <- middle.of.kernel - 1
# TRY AND MAKE A ROUNDED KERNEL THAT STILL SUMS TO 1:
for(i in 5:25){
#print(i)
if(sum(signif(disp.kernel, digits=i))==1){
disp.kernel <- signif(disp.kernel, digits=i)
print(i)
break # exit the loop
}
}
#############################################################################################################################
#
# NOW WE HAVE THE DISPERSAL KERNEL
#
# NEED TO LINEARLY LIST IT IN DECREASING ORDER AND MATCH PATCH IDS TO IT
#
#############################################################################################################################
one.dim.length <- max.dist.exclude.natal + max.dist.include.natal
#dim(disp.kernel)
xcoords <- (-max.dist.exclude.natal):max.dist.exclude.natal
ycoords <- max.dist.exclude.natal:(-max.dist.exclude.natal)
disp.kernel.xcoords <- matrix(rep(xcoords, one.dim.length), nrow= one.dim.length, byrow=TRUE)
disp.kernel.ycoords <- matrix(rep(ycoords, one.dim.length), ncol= one.dim.length, byrow=FALSE)
disp.array <- array(c(disp.kernel, disp.kernel.xcoords, disp.kernel.ycoords), dim=c(one.dim.length, one.dim.length,3))
iterate.by <- seq(1, (one.dim.length^2), by= one.dim.length)
disp.array.data.frame <- data.frame(rep(NA,length(disp.kernel)), rep(NA,length(disp.kernel)), rep(NA,length(disp.kernel)))
names(disp.array.data.frame) <- c("dispersal.prob", "x.dist", "y.dist")
j <- 0
for(i in iterate.by){
j <- j+1
#print(i,j, i:(i+ (one.dim.length-1)))
disp.array.data.frame$dispersal.prob[i:(i+ (one.dim.length-1))] <- disp.array[j,,1]
disp.array.data.frame$x.dist[i:(i+ (one.dim.length-1))] <- disp.array[j,,2]
disp.array.data.frame$y.dist[i:(i+ (one.dim.length-1))] <- disp.array[j,,3]
}
disp.array.data.frame <- disp.array.data.frame[disp.array.data.frame$dispersal.prob > 0 ,]
sorted.disp.frame <- disp.array.data.frame[order(-disp.array.data.frame$dispersal.prob), ]
array.sending.patch.coords <- sorted.disp.frame
ghost.cell <- total.cells+1
absorbing.cell <- ghost.cell+1
num.patches.sending <- length(disp.array.data.frame[,1])
conn.mat <- matrix(NA, nrow= total.cells, ncol= num.patches.sending) # make a matrix to store the connectivity matrix
# it's size is patch number by length of total cells possible to disperse into
# make an identifying number for all patches, go down each column before moving on to the next column
patch.number.ids <- matrix(0, nrow= cells.x, ncol= cells.y)
for(i in 1: (cells.x * cells.y)){
patch.number.ids[i] <- i
}
for(i in 1:total.cells){
focal.patch <- i
for(j in 1:num.patches.sending){
skip <- FALSE
if(j==1){
conn.mat[i,j] <- focal.patch
}else{
if(focal.patch%%cells.x == 0){focal.row <- 20}else{focal.row <- focal.patch%%cells.x}
patch.id.row <- (focal.row + sorted.disp.frame$y.dist[j])
patch.id.col <- (ceiling(focal.patch/cells.x) + sorted.disp.frame$x.dist[j])
if(patch.id.row <= 0 || patch.id.row > cells.x){
conn.mat[i,j] <- absorbing.cell
skip <- TRUE
} # if send to a patch outside the landscape, make it the absorbing patch
if(patch.id.col <= 0 || patch.id.col > cells.y){
conn.mat[i,j] <- absorbing.cell
skip <- TRUE
}
if(skip==FALSE) conn.mat[i,j] <- patch.number.ids[patch.id.row, patch.id.col]
}
}
}
kernel <- paste(c("{", paste(sorted.disp.frame$dispersal.prob, collapse=","), "}"), collapse=" ")
expanded.kernel <- paste(c("{", rep(kernel, times=total.cells+2), "}"), collapse="\n")
write.table(expanded.kernel, file="ExpandedDispKernel.txt", sep=",", col.names=FALSE, row.names=FALSE)
# add on the extra rows for the ghost and absorbing patches
conn.mat <- rbind(conn.mat, rep(ghost.cell, num.patches.sending), rep(absorbing.cell, num.patches.sending))
# make it into a data frame so it prints out properly
frame.conn.mat <- data.frame(conn.mat)
write.table(frame.conn.mat, file="ConnMatrix.txt", sep=",", col.names=FALSE, row.names=FALSE)
with.commas <- read.table("ConnMatrix.txt")
with.commas$col1 <- "{"
with.commas$col.last <- "}"
final.connectivity.matrix <- cbind(with.commas$col1, paste(with.commas$V1), with.commas$col.last)
write.table(final.connectivity.matrix, file=paste(c(getwd(), "/", "Dispersal_ConnMatrix.txt"), collapse=""), col.names=FALSE, row.names=FALSE, quote=FALSE)
return(kernel)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.