R/echoIBM.setSchool.R
In arnejohannesholmin/echoIBM: Simulation of multibeam sonar data
Defines functions
echoIBM.setSchool
Documented in
echoIBM.setSchool
#*********************************************
#*********************************************
#' Returns a list of the following strings: (1) the path to the event, (2) the event name, (3) the event number, (4) the path to the cruise, and (5) the cruise name.
#'
#' @param event A list of the following elements: (1) 'path', giving the paths to the sub-events, (2) 'esnm', giving the names of the acoustic instruments in the events (same length as 'path'), and (3) 'name', giving the name of the event.
#' @param surveyRegion A data frame of two rows and the three columns x, y and z, defining the survey region.
#' @param target A code word defining the target. One of "herring", "mackerel" and "point".
#' @param schoolDistribution A code word defining the distribution of schools. One of "layer", "uniform" (equal probability of encountering a school in all directions but the z direction, corresponding to a homogenious Poisson point process in the x-y-plane), "flat" (random ordering of schools sequenced between the survey bounds).
#' @param schoolSize Definition of the school sizes, either given as a list of dimensions in the x, y and z direction (repeated to the number of schools), or a list of dimensions added a type of random generator for the sizes, such as type = "weibull", indicating correlated Weibull distributed sizes, where the shape and correlation are specified by 'shape' and 'cor'. Alternatively schoolSize can be a list to be used as input the a function schoolSize$type, which must be a function including the ... argument to avoid errors. For correlated Weibull distributed sizes use e.g. list(x = 100, y = 100, z = 20, type = "Weibull", shape = 5, cor = 0.4), where 0.4 is the maximum available correlation. For correlated uniform variables use e.g. list(x = c(30, 300), y = c(30, 300), z = c(30, 300) / 5, type = "Uniform", cor = 0.5), where 0.5 is the maximum available correlation. For schoolSize$type=="Uniform", if schoolSize$x is given as a single numeric, this is interpreted as uniform between 0 and 2 * x.
#' @param schoolDens The area reserved for each school.
#' @param schoolDist The mean distance between schools. Use rather schoolDens.
#' @param schoolCount The number of schools.
#' @param fillSurveyRegion Logical: If TRUE fill the survey region so that schools are generated also outside of the original survey region, elliminating edge effects in the spatial distribution of fish.
#' @param seed The seed of the school generation
#' @param depthRange The depth range of the schools. Should be given in the \code{surveyRegion}.
#' @param onlyFirstEvent Logical: If TRUE generate school files only for the first event (saving storage).
#' @param ... Data overriding the variables generated by the funciton.
#'
#' @return
#'
#' @examples
#' \dontrun{}
#'
#' @importFrom TSD write.TSD
#' @importFrom utils head tail
#' @importFrom stats runif
#' @importFrom fields rdist
#'
#' @export
#' @rdname echoIBM.setup
#'
# 1. school size distribution + school density + packing density + school position distribution
echoIBM.setSchool <- function(
event,
schoolName = "School",
surveyRegion = NULL,
expandSurveyRegion = NULL,
target = c("herring", "mackerel", "point"),
schoolDistribution = c("layer", "uniform", "flat"),
schoolSize = list(x = 100, y = 100, z = 20, type = "Weibull", shape = 5, cor = 0.4),
schoolDens = 1852^-2,
schoolDist = NULL,
schoolCount = NULL,
fillSurveyRegion = TRUE,
seed = 0,
depthRange = c(-100, 0),
onlyFirstEvent = FALSE,
...){
############### LOG: ###############
# Start: 2017-03-29 - Clean version.
# Save the input variables:
dotList <- list(...)
vessel <- echoIBM.readFile(event$path[1], ext="vessel", t="all")
beams <- lapply(event$path, echoIBM.readFile, ext="beams", t="all")
files <- NULL
############################################################
############### (1) Generate static school data: ###########
############################################################
# Function used for generating the schools sizes:
setSchoolSize <- function(schoolSize, schoolCount, seed=0){
# Set the sizes of the schools:
size0 <- repm(as.data.frame(schoolSize[c("x", "y", "z")]), schoolCount, byrow=TRUE)
if(strff("wei", schoolSize$type)){
# Old comment: w=c(1) implies no correlation between schools:
maxCorVec <- c(1, 0.6, 1, 0.6, 1)
maxCor <- 0.4
if(schoolSize$cor > maxCor){
warning(paste0("Weibull distributed size cannot be correlated by more than ", maxCor, " (the correlation set to this value)"))
schoolSize$cor <- maxCorVec
}
else{
thismaxcor <- maxCorVec
thismaxcor[2:4] <- thismaxcor[2:4] * schoolSize$cor / maxCor
schoolSize$cor <- thismaxcor
}
size <- rexp_MultSines(J=schoolCount, I=3, L=3, N=40, P=10, w=1, olpn=schoolSize$cor, shape=schoolSize$shape[1], mean=size0, seed=seed)
}
else if(strff("uni", schoolSize$type)){
maxCor <- 0.5
if(schoolSize$cor > maxCor){
warning(paste0("Uniformly distributed size cannot be correlated by more than ", maxCor, " (the correlation set to this value)"))
schoolSize$cor <- maxCor
}
cor1 <- (schoolSize$cor / maxCor)^2 * maxCor
# Set the weights in the sums below (here the multiplication with sqrt(2) is to normalize to the standard deviation of the sum of two ):
# Draw Gaussian variables, and map back to uniform using pnorm():
set.seed(seed)
n1 <- rnorm(schoolCount)
n2 <- rnorm(schoolCount)
n3 <- rnorm(schoolCount)
x <- cor1 * n1 + maxCor * n2
y <- cor1 * n2 + maxCor * n3
z <- cor1 * n3 + maxCor * n1
sd <- sqrt(cor1^2 + maxCor^2)
size <- cbind(pnorm(x, sd=sd), pnorm(y, sd=sd), pnorm(z, sd=sd))
# Add the sizes:
if(length(schoolSize$x)==0){
schoolSize$x <- c(0, 2 * schoolSize$x)
}
if(length(schoolSize$y)==0){
schoolSize$y <- c(0, 2 * schoolSize$y)
}
if(length(schoolSize$z)==0){
schoolSize$z <- c(0, 2 * schoolSize$z)
}
size[, 1] <- schoolSize$x[1] + diff(schoolSize$x) * size[, 1]
size[, 2] <- schoolSize$y[1] + diff(schoolSize$y) * size[, 2]
size[, 3] <- schoolSize$z[1] + diff(schoolSize$z) * size[, 3]
}
else if(is.function(schoolSize$type)){
size <- do.call(schoolSize$type, schoolSize)
}
else{
size <- size0
}
size
}
# Apply default settings specified by 'target':
# Herring:
if(tolower(head(target, 1)) == "herring"){
schoolStatic <- list(
pbpf = "prolatespheroid",
obln = 5,
tilt = 0,
# Define compression of the swim bladder in case the simulate targets have one (defaults taken from Ona 2003, with compression only radially in the swim bladder):
gamw = -0.23,
gaml = 0,
# Ratio of swim bladder versus total length (Gorska and Ona 2003, Modelling the effect of swimbladder compression on the acoustic backscattering from herring at normal or near-normal dorsal incidences).
zeta = 0.26,
# The backscattering coefficient of each individual target can be given directly through the sgbs variable:
sgbs = NULL,
# Otherwise use the link between fish size and sgbs:
epss = function(f){
10^(-6.54)*100^2 * (f/38000)^(-0.4)
}
)
schoolDynamic <- list(
MEsz = 0.32,
SDsz = 0.02,
PDsz = "rnorm"
)
}
else if(tolower(head(target, 1)) == "mackerel"){
schoolStatic <- list(
pbpf = "prolatespheroid",
obln = 5,
tilt = 0,
# Define compression of the swim bladder in case the simulate targets have one (defaults taken from Ona 2003, with compression only radially in the swim bladder):
gamw = 0,
gaml = 0,
# Ratio of swim bladder versus total length, set to 1 when no swimbladder:
zeta = 1,
# The backscattering coefficient of each individual target can be given directly through the sgbs variable:
sgbs = NULL,
# Otherwise use the link between fish size and sgbs:
epss = function(f){
NA
}
)
schoolDynamic <- list(
MEsz = 0.32,
SDsz = 0.02,
PDsz = "rnorm"
)
}
else if(tolower(head(target, 1)) == "point"){
schoolStatic <- list(
pbpf = "pointsource",
obln = 1,
tilt = 0,
# Define compression of the swim bladder in case the simulate targets have one (defaults taken from Ona 2003, with compression only radially in the swim bladder):
gamw = 0,
gaml = 0,
# Gorska and Ona 2003, Modelling the effect of swimbladder compression on the acoustic backscattering from herring at normal or near-normal dorsal incidences.
zeta = 1,
# The backscattering coefficient of each individual target can be given directly through the sgbs variable:
sgbs = NULL,
# Otherwise use the link between fish size and sgbs:
epss = function(f){
10^(-6.54)*100^2 * (f/38000)^(-0.4)
}
)
schoolDynamic <- list(
MEsz = 0.32,
SDsz = 0,
PDsz = "rnorm"
)
}
# If prolate spheroid is given for the parametric beam pattern of the targets, include the beam pattern file of the given aspect ratio:
if(schoolStatic$pbpf == "prolatespheroid"){
targetBeamPatternFiles <- list.files(system.file("extdata", "TargetBeamPattern", package="echoIBM"), full.names=TRUE)
# Split the basenames by "_":
targetBeamPatternbasenameSplitted <- strsplit(basename(targetBeamPatternFiles), "_")
obln <- as.numeric(sapply(targetBeamPatternbasenameSplitted, function(x) x[which(tolower(x)=="obln")[1] + 1]))
selected <- which.min(abs(obln - schoolStatic$obln))
if(obln[selected] != schoolStatic$obln){
warning(paste0("The target beam pattern file of the closest oblongness chosen (", targetBeamPatternFiles[selected], ")"))
}
beampatternfiles <- file.path(event$path, basename(targetBeamPatternFiles[selected]))
lapply(beampatternfiles, function(thispath) file.copy(targetBeamPatternFiles[selected], thispath))
# Add the file names to the output:
names(beampatternfiles) <- event$esnm
files <- c(files, beampatternfiles)
}
# Add data:
schoolStatic <- replaceKeepDim(schoolStatic, dotList, esnm="")
############################################################
############################################################
############################################################
############## (2) Generate dynamic school data: ###########
############################################################
# First set the packing density rhoS, which is used to define several other variables, i.e., noise on the individual fish positions SDxf, SDyf, SDzf, the number of fish nbfS, and the in schoolDistribution == "layer":
if(length(dotList$rhoS)){
rhoS <- dotList$rhoS
}
# Otherwise use the default:
else{
rhoS <- 1
}
spacing <- rhoS^(-1/3)
# Get total rectangular survey region:
if(length(surveyRegion$x)==0 || length(surveyRegion$y)==0){
tempsurveyRegion <- data.frame(x=range(vessel$psxv), y=range(vessel$psyv))
# Add the echosounder/sonar range:
getmxrb <- function(x){
if(length(x$rres)==0){
x$rres <- x$sint * x$asps / 2
}
# (changed on 2017-12-08 from simply the maximum range to the maximum HORIZONTAL range)
# (And then changed back again, since using the horizontal did not perform well for vertially oriented echosounders:
max(x$lenb * matrix(x$rres, ncol=NCOL(x$lenb), nrow=NROW(x$lenb)))
#max(x$lenb * matrix(x$rres, ncol=NCOL(x$lenb), nrow=NROW(x$lenb))) * max(sin(x$dire))
}
mxrb <- max(unlist(lapply(beams, getmxrb)))
# Add the maximum horizontal range:
tempsurveyRegion <- tempsurveyRegion + c(-1, 1) * mxrb
# Replace any given regian boundaries:
if(length(surveyRegion$x)){
tempsurveyRegion$x <- surveyRegion$x
}
if(length(surveyRegion$y)){
tempsurveyRegion$y <- surveyRegion$y
}
surveyRegion <- tempsurveyRegion
}
if(length(surveyRegion$z)==0){
surveyRegion$z <- range(depthRange)
}
# Add to the survey region:
if(length(expandSurveyRegion$x)){
surveyRegion$x <- surveyRegion$x + expandSurveyRegion$x
}
if(length(expandSurveyRegion$y)){
surveyRegion$y <- surveyRegion$y + expandSurveyRegion$y
}
if(length(expandSurveyRegion$z)){
surveyRegion$z <- surveyRegion$z + expandSurveyRegion$z
}
# Set the seed. This is a simple solution, fragile for changes in the code:
set.seed(seed)
# Special case if a layer of fish is requsted. In that case rectangular schools are defined and positioned on a grid, so that the entire observation region is filled:
if(tolower(schoolDistribution[1]) == "layer"){
# Adjust schoolSize so that it is a multiple of the inter fish spacing:
schoolSize$x[1] <- ceiling(schoolSize$x[1] / spacing) * spacing
schoolSize$y[1] <- ceiling(schoolSize$y[1] / spacing) * spacing
if(length(schoolSize$z)==0){
schoolSize$z <- diff(surveyRegion$z[1:2])
}
# Divide the survey region into rectangles with sizes given by 'schoolSize':
gridx <- seq(surveyRegion$x[1], surveyRegion$x[2], schoolSize$x[1])
if(tail(gridx, 1) < surveyRegion$x[2]){
gridx <- c(gridx, surveyRegion$x[2])
}
gridy <- seq(surveyRegion$y[1], surveyRegion$y[2], schoolSize$y[1])
if(tail(gridy, 1) < surveyRegion$y[2]){
gridy <- c(gridy, surveyRegion$y[2])
}
# Get mid points and sizes from the grid:
midgridx <- (gridx[-1] + gridx[-length(gridx)]) / 2
midgridy <- (gridy[-1] + gridy[-length(gridy)]) / 2
midgridz <- mean(surveyRegion$z[1:2])
midgrid <- expand.grid(midgridx, midgridy, midgridz)
schoolCount <- nrow(midgrid)
sizex <- diff(gridx)
sizey <- diff(gridy)
sizez <- diff(surveyRegion$z[1:2])
size <- expand.grid(sizex, sizey, sizez)
### (1) Position:
# Layer block positions:
psxS <- midgrid[,1]
psyS <- midgrid[,2]
pszS <- midgrid[,3]
### (2) Size:
# Layer block sizes:
szxS <- size[,1]
szyS <- size[,2]
szzS <- size[,3]
### (3) Shape:
# Use rectangular shaped "schools" for the layer:
shpS <- "r"
### (4) Direction:
# Random orientation of the school (including the fish):
#thtS <- runif(schoolCount, 0, 2*pi)
#phiS <- pi/2
hazS <- 0
helS <- pi/2
oazS <- runif(schoolCount, 0, 2*pi)
oelS <- pi/2
### (5) Rotation:
# Layer block rotations (no rotation):
rtxS <- 0
rtyS <- 0
rtzS <- 0
### (6) Speed:
# No speed:
aspS <- 0
### (7) Packing density:
#rhoS <- 1
### (8) Polarization:
# SD of mean 0-Gaussian distribution of individual fish positions:
#SDxf <- 1
#SDxf <- 1
#SDxf <- 1
# No polarization:
plHS <- Inf
### (9) Drift:
# No drift:
### (10) Volume:
# Add volS also as a global variable for use in nbfS. Volume 'volS' is only used to derive the approximate memory used:
volS <- szxS * szyS * szzS
vol0 <- volS
}
# Uniformly distributed schools:
else if(any(startsWith(tolower(schoolDistribution[1]), c("uniform", "flat")))){
#else if(tolower(schools[1]) %in% c("uniform", "flat")){
# If the school density is given, calculate the number of schols:
if(length(schoolCount)==0){
schoolCount <- round(diff(surveyRegion$x) * diff(surveyRegion$y) * if(length(schoolDist)) schoolDist^2 else schoolDens)
}
# Set the sizes of the schools:
size <- setSchoolSize(schoolSize, schoolCount=schoolCount, seed=seed)
maxSize <- apply(size, 2, max)
# Add half of the maximum school size on all sides of the surevy region:
if(fillSurveyRegion){
oldSurveyRegion <- surveyRegion
surveyRegion[1, ] <- surveyRegion[1, ] - maxSize/2
surveyRegion[2, ] <- surveyRegion[2, ] + maxSize/2
oldArea <- prod(apply(oldSurveyRegion[,1:2], 2, diff))
newArea <- prod(apply(surveyRegion[,1:2], 2, diff))
newSchoolCount <- round(schoolCount * newArea / oldArea)
if(newSchoolCount > schoolCount){
cat("Number of schools changed from ", schoolCount, " to ", newSchoolCount, "\n")
schoolCount <- newSchoolCount
}
}
### (1) Position:
# Generate the school positions:
if(identical(tolower(schoolDistribution[1]), "flat")){
schoolDistribution[1] <- "flatxyz"
}
# Set the positions of the schools as uniformly or regularly distributed in x, y and z dimension:
# Here, if both "flat" and "x", "y" or "z" is present in schoolDistribution[1], the regular distribution is used along that dimension. Otherwise uniform distribution.
drawPosSchoolOneDim <- function(dim="x", schoolDistribution, schoolCount, surveyRegion){
if(grepl(dim, schoolDistribution[1], ignore.case=TRUE) && grepl("flat", schoolDistribution[1], ignore.case=TRUE)){
out <- seq(surveyRegion[[dim]][1], surveyRegion[[dim]][2], length.out=schoolCount)
out <- sample(out)
}
else{
out <- runif(schoolCount, surveyRegion[[dim]][1], surveyRegion[[dim]][2])
}
out
}
psxS <- drawPosSchoolOneDim(dim="x", schoolDistribution=schoolDistribution, schoolCount=schoolCount, surveyRegion=surveyRegion)
psyS <- drawPosSchoolOneDim(dim="y", schoolDistribution=schoolDistribution, schoolCount=schoolCount, surveyRegion=surveyRegion)
pszS <- drawPosSchoolOneDim(dim="z", schoolDistribution=schoolDistribution, schoolCount=schoolCount, surveyRegion=surveyRegion)
ord <- order(psxS, psyS, pszS)
psxS <- psxS[ord]
psyS <- psyS[ord]
pszS <- pszS[ord]
### (2) Size:
# Reset school sizes:
size <- setSchoolSize(schoolSize, schoolCount=schoolCount, seed=seed)
szxS <- size[,1]
szyS <- size[,2]
szzS <- size[,3]
### (3) Shape:
# Use rectangular shaped "schools" for the layer:
shpS <- "e"
### (4) Direction:
# Random orientation of the school (including the fish):
#thtS <- runif(schoolCount, 0, 2*pi)
#phiS <- pi/2
hazS <- 0
helS <- pi/2
oazS <- runif(schoolCount, 0, 2*pi)
oelS <- pi/2
### (5) Rotation:
# School rotations (no rotation):
rtxS <- 0
rtyS <- 0
rtzS <- 0
### (6) Speed:
# No speed:
aspS <- 0
### (7) Packing density:
#rhoS <- 1
### (8) Polarization:
# SD of mean 0-Gaussian distribution of individual fish positions:
#SDxf <- 1,
#SDxf <- 1,
#SDxf <- 1,
# No polarization:
plHS <- Inf
### (9) Drift:
# No drift:
### (10) Volume:
###volS = volS <- 4/3*pi * schools$szxS/2 * schools$szyS/2 * schools$szzS/2
# Ellipsoidal schools (http://keisan.casio.com/has10/SpecExec.cgi?path=05000000.Mathematics%2F01000300.Volume%20and%20surface%20area%2F13000700.Volume%20of%20an%20ellipsoidal%20cap%2Fdefault.xml&charset=utf-8):
##axA <- schools$szxS/2
##axB <- schools$szyS/2
##axC <- schools$szzS/2
##below <- schools$pszS - axC
### Add volS also as a global variable for use in nbfS. Volume 'volS' is only used to derive the approximate memory used:
##volS = volS <- pi/3 * axA*axB * below^2/axC^2 * (3*axC - below)
##vol0 <- 4*pi/3 * axA * axB * axC
axA <- szxS/2
axB <- szyS/2
axC <- szzS/2
below <- axC - pszS
# For fully submerged schools the height below is set to the heigth of the school:
below[below > szzS] <- szzS[below > szzS]
below[below < 0] <- 0
volS <- pi/3 * axA * axB * below^2/axC^2 * (3*axC - below)
vol0 <- 4*pi/3 * axA * axB * axC
}
# Otherwise an error:
else{
stop(paste0("School distribution ", tolower(schoolDistribution[1]), " not implemented"))
}
# Add the survey region to the statis school file:
schoolStatic$surv <- surveyRegion
# Add the data into the schoolDynamic:
schoolDynamic <- c(
schoolDynamic,
list(
# (1) Position:
psxS = psxS,
psyS = psyS,
pszS = pszS,
# (2) Size:
szxS = szxS,
szyS = szyS,
szzS = szzS,
# (3) Shape:
shpS = shpS,
# (4) Direction:
#thtS = thtS,
#phiS = phiS,
hazS = hazS,
helS = helS,
oazS = oazS,
oelS = oelS,
# (5) Rotation:
rtxS = rtxS,
rtyS = rtyS,
rtzS = rtzS,
# (6) Speed:
aspS = aspS,
# (7) Packing density:
rhoS = rhoS,
spcS = spacing,
# (8) Polarization:
plHS = plHS,
# (9) Drift:
# (10) Volume:
volS = volS,
vol0 = vol0
)
)
schoolDynamic$scls <- 1
# Pick the start time of the simulation project as the time of all of the schools:
schoolDynamic$utmS <- rep(head(vessel$utim, 1), schoolCount)
schoolDynamic$ut9S <- rep(Inf, schoolCount)
# Repeat to apropriate length:
#allNumt <- unlist(lapply(schoolDynamic, NCOL))
#maxnumt <- max(allNumt)
#allSchoolCount <- unlist(lapply(schoolDynamic, NROW))
#schoolCount <- max(allSchoolCount)
# Discard empty elements:
#schoolDynamic <- schoolDynamic[sapply(schoolDynamic, length)>0]
#
#if(!all(allNumt==maxnumt)){
# schoolDynamic <- lapply(schoolDynamic, apply, 1, rep, length.out=maxnumt)
#}
#if(!all(allSchoolCount==schoolCount)){
# schoolDynamic <- lapply(schoolDynamic, apply, 2, rep, length.out=schoolCount)
#}
maxlength <- max(unlist(lapply(schoolDynamic, length)))
# schoolDynamic <- lapply(schoolDynamic, rep, length.out=maxlength)
# Add data:
schoolDynamic <- replaceKeepDim(schoolDynamic, dotList, esnm="")
add_SDxf <- function(x){
# Set the standard deviation of the fish positions with expected value at the gridded positions to be the distance expected distance between the fish (cubic root of the space reserved for each fish):
if(length(x$SDxf)==0){
x$SDxf <- x$spcS
}
if(length(x$SDyf)==0){
x$SDyf <- x$spcS
}
if(length(x$SDzf)==0){
x$SDzf <- x$spcS
}
x
}
schoolDynamic <- add_SDxf(schoolDynamic)
add_nbfS <- function(x){
x$nbfS <- x$rhoS * x$volS
x
}
schoolDynamic <- add_nbfS(schoolDynamic)
# Calculate the distances to the schools, and find the time steps which are closest, and the distance at those time steps:
getClosestTimeAndDist <- function(schoolind, vessel, schoolDynamic){
d <- fields::rdist(cbind(vessel$psxv, vessel$psyv, vessel$pszv), cbind(schoolDynamic$psxS[schoolind], schoolDynamic$psyS[schoolind], schoolDynamic$pszS[schoolind]))
cbind(
apply(d, 2, min),
apply(d, 2, which.min)
)
#apply(d, 2, which.min)
}
maxSize <- 1e6
stepZize <- ceiling(maxSize / length(vessel$psxv))
steps <- split(seq_along(schoolDynamic$psxS), ceiling(seq_along(schoolDynamic$psxS) / stepZize))
temp <- lapply(steps, getClosestTimeAndDist, vessel=vessel, schoolDynamic=schoolDynamic)
temp <- do.call(rbind, temp)
schoolDynamic$dstc <- temp[,1]
schoolDynamic$timc <- temp[,2]
#d <- fields::rdist(cbind(vessel$psxv, vessel$psyv, vessel$pszv), cbind(schoolDynamic$psxS, schoolDynamic$psyS, schoolDynamic$pszS))
#schoolDynamic$dstc <- apply(d, 2, min)
#schoolDynamic$timc <- apply(d, 2, which.min)
# Create the folder for the school:
schoolStaticFolder <- file.path(event$path, schoolName)
lapply(schoolStaticFolder, dir.create, showWarnings = FALSE)
schoolStaticFiles <- file.path(schoolStaticFolder, paste0(event$name, "_SchoolStatic", ".school"))
schoolDynamicFiles <- file.path(schoolStaticFolder, paste0(event$name, "_SchoolDynamic", ".school"))
# Update the sizes of the schools:
size <- setSchoolSize(schoolSize, schoolCount=schoolCount, seed=seed)
# Write the static school file to the events:
if(onlyFirstEvent){
schoolStaticFiles <- schoolStaticFiles[1]
}
lapply(schoolStaticFiles, function(thispath) write.TSD(schoolStatic, thispath, numt=1))
# Add the file names to the output:
names(schoolStaticFiles) <- event$esnm
files <- c(files, schoolStaticFiles)
#lapply(if(onlyFirstEvent) event$path[1] else event$path, function(thispath) write.TSD(schoolStatic, file.path(thispath, paste0(event$name, "_SchoolStatic", ".school")), numt=1))
# Write the static school file to the events:
#lapply(if(onlyFirstEvent) event$path[1] else event$path, function(thispath) write.TSD(schoolDynamic, file.path(thispath, paste0(event$name, "_SchoolDynamic", ".school")), numt=ncol(schoolDynamic$psxS)))
#schoolDynamicFiles <- file.path(event$path, schoolName, paste0(event$name, "_SchoolDynamic", ".school"))
if(onlyFirstEvent){
schoolDynamicFiles <- schoolDynamicFiles[1]
}
lapply(schoolDynamicFiles, function(thispath) write.TSD(schoolDynamic, thispath, numt=1))
# Add the file names to the output:
names(schoolDynamicFiles) <- event$esnm
files <- c(files, schoolDynamicFiles)
return(files)
}
arnejohannesholmin/echoIBM documentation built on April 14, 2024, 11:37 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 echoIBM.setSchool
Documented in echoIBM.setSchool
#*********************************************
#*********************************************
#' Returns a list of the following strings: (1) the path to the event, (2) the event name, (3) the event number, (4) the path to the cruise, and (5) the cruise name.
#'
#' @param event A list of the following elements: (1) 'path', giving the paths to the sub-events, (2) 'esnm', giving the names of the acoustic instruments in the events (same length as 'path'), and (3) 'name', giving the name of the event.
#' @param surveyRegion A data frame of two rows and the three columns x, y and z, defining the survey region.
#' @param target A code word defining the target. One of "herring", "mackerel" and "point".
#' @param schoolDistribution A code word defining the distribution of schools. One of "layer", "uniform" (equal probability of encountering a school in all directions but the z direction, corresponding to a homogenious Poisson point process in the x-y-plane), "flat" (random ordering of schools sequenced between the survey bounds).
#' @param schoolSize Definition of the school sizes, either given as a list of dimensions in the x, y and z direction (repeated to the number of schools), or a list of dimensions added a type of random generator for the sizes, such as type = "weibull", indicating correlated Weibull distributed sizes, where the shape and correlation are specified by 'shape' and 'cor'. Alternatively schoolSize can be a list to be used as input the a function schoolSize$type, which must be a function including the ... argument to avoid errors. For correlated Weibull distributed sizes use e.g. list(x = 100, y = 100, z = 20, type = "Weibull", shape = 5, cor = 0.4), where 0.4 is the maximum available correlation. For correlated uniform variables use e.g. list(x = c(30, 300), y = c(30, 300), z = c(30, 300) / 5, type = "Uniform", cor = 0.5), where 0.5 is the maximum available correlation. For schoolSize$type=="Uniform", if schoolSize$x is given as a single numeric, this is interpreted as uniform between 0 and 2 * x.
#' @param schoolDens The area reserved for each school.
#' @param schoolDist The mean distance between schools. Use rather schoolDens.
#' @param schoolCount The number of schools.
#' @param fillSurveyRegion Logical: If TRUE fill the survey region so that schools are generated also outside of the original survey region, elliminating edge effects in the spatial distribution of fish.
#' @param seed The seed of the school generation
#' @param depthRange The depth range of the schools. Should be given in the \code{surveyRegion}.
#' @param onlyFirstEvent Logical: If TRUE generate school files only for the first event (saving storage).
#' @param ... Data overriding the variables generated by the funciton.
#'
#' @return
#'
#' @examples
#' \dontrun{}
#'
#' @importFrom TSD write.TSD
#' @importFrom utils head tail
#' @importFrom stats runif
#' @importFrom fields rdist
#'
#' @export
#' @rdname echoIBM.setup
#'
# 1. school size distribution + school density + packing density + school position distribution
echoIBM.setSchool <- function(
event,
schoolName = "School",
surveyRegion = NULL,
expandSurveyRegion = NULL,
target = c("herring", "mackerel", "point"),
schoolDistribution = c("layer", "uniform", "flat"),
schoolSize = list(x = 100, y = 100, z = 20, type = "Weibull", shape = 5, cor = 0.4),
schoolDens = 1852^-2,
schoolDist = NULL,
schoolCount = NULL,
fillSurveyRegion = TRUE,
seed = 0,
depthRange = c(-100, 0),
onlyFirstEvent = FALSE,
...){
############### LOG: ###############
# Start: 2017-03-29 - Clean version.
# Save the input variables:
dotList <- list(...)
vessel <- echoIBM.readFile(event$path[1], ext="vessel", t="all")
beams <- lapply(event$path, echoIBM.readFile, ext="beams", t="all")
files <- NULL
############################################################
############### (1) Generate static school data: ###########
############################################################
# Function used for generating the schools sizes:
setSchoolSize <- function(schoolSize, schoolCount, seed=0){
# Set the sizes of the schools:
size0 <- repm(as.data.frame(schoolSize[c("x", "y", "z")]), schoolCount, byrow=TRUE)
if(strff("wei", schoolSize$type)){
# Old comment: w=c(1) implies no correlation between schools:
maxCorVec <- c(1, 0.6, 1, 0.6, 1)
maxCor <- 0.4
if(schoolSize$cor > maxCor){
warning(paste0("Weibull distributed size cannot be correlated by more than ", maxCor, " (the correlation set to this value)"))
schoolSize$cor <- maxCorVec
}
else{
thismaxcor <- maxCorVec
thismaxcor[2:4] <- thismaxcor[2:4] * schoolSize$cor / maxCor
schoolSize$cor <- thismaxcor
}
size <- rexp_MultSines(J=schoolCount, I=3, L=3, N=40, P=10, w=1, olpn=schoolSize$cor, shape=schoolSize$shape[1], mean=size0, seed=seed)
}
else if(strff("uni", schoolSize$type)){
maxCor <- 0.5
if(schoolSize$cor > maxCor){
warning(paste0("Uniformly distributed size cannot be correlated by more than ", maxCor, " (the correlation set to this value)"))
schoolSize$cor <- maxCor
}
cor1 <- (schoolSize$cor / maxCor)^2 * maxCor
# Set the weights in the sums below (here the multiplication with sqrt(2) is to normalize to the standard deviation of the sum of two ):
# Draw Gaussian variables, and map back to uniform using pnorm():
set.seed(seed)
n1 <- rnorm(schoolCount)
n2 <- rnorm(schoolCount)
n3 <- rnorm(schoolCount)
x <- cor1 * n1 + maxCor * n2
y <- cor1 * n2 + maxCor * n3
z <- cor1 * n3 + maxCor * n1
sd <- sqrt(cor1^2 + maxCor^2)
size <- cbind(pnorm(x, sd=sd), pnorm(y, sd=sd), pnorm(z, sd=sd))
# Add the sizes:
if(length(schoolSize$x)==0){
schoolSize$x <- c(0, 2 * schoolSize$x)
}
if(length(schoolSize$y)==0){
schoolSize$y <- c(0, 2 * schoolSize$y)
}
if(length(schoolSize$z)==0){
schoolSize$z <- c(0, 2 * schoolSize$z)
}
size[, 1] <- schoolSize$x[1] + diff(schoolSize$x) * size[, 1]
size[, 2] <- schoolSize$y[1] + diff(schoolSize$y) * size[, 2]
size[, 3] <- schoolSize$z[1] + diff(schoolSize$z) * size[, 3]
}
else if(is.function(schoolSize$type)){
size <- do.call(schoolSize$type, schoolSize)
}
else{
size <- size0
}
size
}
# Apply default settings specified by 'target':
# Herring:
if(tolower(head(target, 1)) == "herring"){
schoolStatic <- list(
pbpf = "prolatespheroid",
obln = 5,
tilt = 0,
# Define compression of the swim bladder in case the simulate targets have one (defaults taken from Ona 2003, with compression only radially in the swim bladder):
gamw = -0.23,
gaml = 0,
# Ratio of swim bladder versus total length (Gorska and Ona 2003, Modelling the effect of swimbladder compression on the acoustic backscattering from herring at normal or near-normal dorsal incidences).
zeta = 0.26,
# The backscattering coefficient of each individual target can be given directly through the sgbs variable:
sgbs = NULL,
# Otherwise use the link between fish size and sgbs:
epss = function(f){
10^(-6.54)*100^2 * (f/38000)^(-0.4)
}
)
schoolDynamic <- list(
MEsz = 0.32,
SDsz = 0.02,
PDsz = "rnorm"
)
}
else if(tolower(head(target, 1)) == "mackerel"){
schoolStatic <- list(
pbpf = "prolatespheroid",
obln = 5,
tilt = 0,
# Define compression of the swim bladder in case the simulate targets have one (defaults taken from Ona 2003, with compression only radially in the swim bladder):
gamw = 0,
gaml = 0,
# Ratio of swim bladder versus total length, set to 1 when no swimbladder:
zeta = 1,
# The backscattering coefficient of each individual target can be given directly through the sgbs variable:
sgbs = NULL,
# Otherwise use the link between fish size and sgbs:
epss = function(f){
NA
}
)
schoolDynamic <- list(
MEsz = 0.32,
SDsz = 0.02,
PDsz = "rnorm"
)
}
else if(tolower(head(target, 1)) == "point"){
schoolStatic <- list(
pbpf = "pointsource",
obln = 1,
tilt = 0,
# Define compression of the swim bladder in case the simulate targets have one (defaults taken from Ona 2003, with compression only radially in the swim bladder):
gamw = 0,
gaml = 0,
# Gorska and Ona 2003, Modelling the effect of swimbladder compression on the acoustic backscattering from herring at normal or near-normal dorsal incidences.
zeta = 1,
# The backscattering coefficient of each individual target can be given directly through the sgbs variable:
sgbs = NULL,
# Otherwise use the link between fish size and sgbs:
epss = function(f){
10^(-6.54)*100^2 * (f/38000)^(-0.4)
}
)
schoolDynamic <- list(
MEsz = 0.32,
SDsz = 0,
PDsz = "rnorm"
)
}
# If prolate spheroid is given for the parametric beam pattern of the targets, include the beam pattern file of the given aspect ratio:
if(schoolStatic$pbpf == "prolatespheroid"){
targetBeamPatternFiles <- list.files(system.file("extdata", "TargetBeamPattern", package="echoIBM"), full.names=TRUE)
# Split the basenames by "_":
targetBeamPatternbasenameSplitted <- strsplit(basename(targetBeamPatternFiles), "_")
obln <- as.numeric(sapply(targetBeamPatternbasenameSplitted, function(x) x[which(tolower(x)=="obln")[1] + 1]))
selected <- which.min(abs(obln - schoolStatic$obln))
if(obln[selected] != schoolStatic$obln){
warning(paste0("The target beam pattern file of the closest oblongness chosen (", targetBeamPatternFiles[selected], ")"))
}
beampatternfiles <- file.path(event$path, basename(targetBeamPatternFiles[selected]))
lapply(beampatternfiles, function(thispath) file.copy(targetBeamPatternFiles[selected], thispath))
# Add the file names to the output:
names(beampatternfiles) <- event$esnm
files <- c(files, beampatternfiles)
}
# Add data:
schoolStatic <- replaceKeepDim(schoolStatic, dotList, esnm="")
############################################################
############################################################
############################################################
############## (2) Generate dynamic school data: ###########
############################################################
# First set the packing density rhoS, which is used to define several other variables, i.e., noise on the individual fish positions SDxf, SDyf, SDzf, the number of fish nbfS, and the in schoolDistribution == "layer":
if(length(dotList$rhoS)){
rhoS <- dotList$rhoS
}
# Otherwise use the default:
else{
rhoS <- 1
}
spacing <- rhoS^(-1/3)
# Get total rectangular survey region:
if(length(surveyRegion$x)==0 || length(surveyRegion$y)==0){
tempsurveyRegion <- data.frame(x=range(vessel$psxv), y=range(vessel$psyv))
# Add the echosounder/sonar range:
getmxrb <- function(x){
if(length(x$rres)==0){
x$rres <- x$sint * x$asps / 2
}
# (changed on 2017-12-08 from simply the maximum range to the maximum HORIZONTAL range)
# (And then changed back again, since using the horizontal did not perform well for vertially oriented echosounders:
max(x$lenb * matrix(x$rres, ncol=NCOL(x$lenb), nrow=NROW(x$lenb)))
#max(x$lenb * matrix(x$rres, ncol=NCOL(x$lenb), nrow=NROW(x$lenb))) * max(sin(x$dire))
}
mxrb <- max(unlist(lapply(beams, getmxrb)))
# Add the maximum horizontal range:
tempsurveyRegion <- tempsurveyRegion + c(-1, 1) * mxrb
# Replace any given regian boundaries:
if(length(surveyRegion$x)){
tempsurveyRegion$x <- surveyRegion$x
}
if(length(surveyRegion$y)){
tempsurveyRegion$y <- surveyRegion$y
}
surveyRegion <- tempsurveyRegion
}
if(length(surveyRegion$z)==0){
surveyRegion$z <- range(depthRange)
}
# Add to the survey region:
if(length(expandSurveyRegion$x)){
surveyRegion$x <- surveyRegion$x + expandSurveyRegion$x
}
if(length(expandSurveyRegion$y)){
surveyRegion$y <- surveyRegion$y + expandSurveyRegion$y
}
if(length(expandSurveyRegion$z)){
surveyRegion$z <- surveyRegion$z + expandSurveyRegion$z
}
# Set the seed. This is a simple solution, fragile for changes in the code:
set.seed(seed)
# Special case if a layer of fish is requsted. In that case rectangular schools are defined and positioned on a grid, so that the entire observation region is filled:
if(tolower(schoolDistribution[1]) == "layer"){
# Adjust schoolSize so that it is a multiple of the inter fish spacing:
schoolSize$x[1] <- ceiling(schoolSize$x[1] / spacing) * spacing
schoolSize$y[1] <- ceiling(schoolSize$y[1] / spacing) * spacing
if(length(schoolSize$z)==0){
schoolSize$z <- diff(surveyRegion$z[1:2])
}
# Divide the survey region into rectangles with sizes given by 'schoolSize':
gridx <- seq(surveyRegion$x[1], surveyRegion$x[2], schoolSize$x[1])
if(tail(gridx, 1) < surveyRegion$x[2]){
gridx <- c(gridx, surveyRegion$x[2])
}
gridy <- seq(surveyRegion$y[1], surveyRegion$y[2], schoolSize$y[1])
if(tail(gridy, 1) < surveyRegion$y[2]){
gridy <- c(gridy, surveyRegion$y[2])
}
# Get mid points and sizes from the grid:
midgridx <- (gridx[-1] + gridx[-length(gridx)]) / 2
midgridy <- (gridy[-1] + gridy[-length(gridy)]) / 2
midgridz <- mean(surveyRegion$z[1:2])
midgrid <- expand.grid(midgridx, midgridy, midgridz)
schoolCount <- nrow(midgrid)
sizex <- diff(gridx)
sizey <- diff(gridy)
sizez <- diff(surveyRegion$z[1:2])
size <- expand.grid(sizex, sizey, sizez)
### (1) Position:
# Layer block positions:
psxS <- midgrid[,1]
psyS <- midgrid[,2]
pszS <- midgrid[,3]
### (2) Size:
# Layer block sizes:
szxS <- size[,1]
szyS <- size[,2]
szzS <- size[,3]
### (3) Shape:
# Use rectangular shaped "schools" for the layer:
shpS <- "r"
### (4) Direction:
# Random orientation of the school (including the fish):
#thtS <- runif(schoolCount, 0, 2*pi)
#phiS <- pi/2
hazS <- 0
helS <- pi/2
oazS <- runif(schoolCount, 0, 2*pi)
oelS <- pi/2
### (5) Rotation:
# Layer block rotations (no rotation):
rtxS <- 0
rtyS <- 0
rtzS <- 0
### (6) Speed:
# No speed:
aspS <- 0
### (7) Packing density:
#rhoS <- 1
### (8) Polarization:
# SD of mean 0-Gaussian distribution of individual fish positions:
#SDxf <- 1
#SDxf <- 1
#SDxf <- 1
# No polarization:
plHS <- Inf
### (9) Drift:
# No drift:
### (10) Volume:
# Add volS also as a global variable for use in nbfS. Volume 'volS' is only used to derive the approximate memory used:
volS <- szxS * szyS * szzS
vol0 <- volS
}
# Uniformly distributed schools:
else if(any(startsWith(tolower(schoolDistribution[1]), c("uniform", "flat")))){
#else if(tolower(schools[1]) %in% c("uniform", "flat")){
# If the school density is given, calculate the number of schols:
if(length(schoolCount)==0){
schoolCount <- round(diff(surveyRegion$x) * diff(surveyRegion$y) * if(length(schoolDist)) schoolDist^2 else schoolDens)
}
# Set the sizes of the schools:
size <- setSchoolSize(schoolSize, schoolCount=schoolCount, seed=seed)
maxSize <- apply(size, 2, max)
# Add half of the maximum school size on all sides of the surevy region:
if(fillSurveyRegion){
oldSurveyRegion <- surveyRegion
surveyRegion[1, ] <- surveyRegion[1, ] - maxSize/2
surveyRegion[2, ] <- surveyRegion[2, ] + maxSize/2
oldArea <- prod(apply(oldSurveyRegion[,1:2], 2, diff))
newArea <- prod(apply(surveyRegion[,1:2], 2, diff))
newSchoolCount <- round(schoolCount * newArea / oldArea)
if(newSchoolCount > schoolCount){
cat("Number of schools changed from ", schoolCount, " to ", newSchoolCount, "\n")
schoolCount <- newSchoolCount
}
}
### (1) Position:
# Generate the school positions:
if(identical(tolower(schoolDistribution[1]), "flat")){
schoolDistribution[1] <- "flatxyz"
}
# Set the positions of the schools as uniformly or regularly distributed in x, y and z dimension:
# Here, if both "flat" and "x", "y" or "z" is present in schoolDistribution[1], the regular distribution is used along that dimension. Otherwise uniform distribution.
drawPosSchoolOneDim <- function(dim="x", schoolDistribution, schoolCount, surveyRegion){
if(grepl(dim, schoolDistribution[1], ignore.case=TRUE) && grepl("flat", schoolDistribution[1], ignore.case=TRUE)){
out <- seq(surveyRegion[[dim]][1], surveyRegion[[dim]][2], length.out=schoolCount)
out <- sample(out)
}
else{
out <- runif(schoolCount, surveyRegion[[dim]][1], surveyRegion[[dim]][2])
}
out
}
psxS <- drawPosSchoolOneDim(dim="x", schoolDistribution=schoolDistribution, schoolCount=schoolCount, surveyRegion=surveyRegion)
psyS <- drawPosSchoolOneDim(dim="y", schoolDistribution=schoolDistribution, schoolCount=schoolCount, surveyRegion=surveyRegion)
pszS <- drawPosSchoolOneDim(dim="z", schoolDistribution=schoolDistribution, schoolCount=schoolCount, surveyRegion=surveyRegion)
ord <- order(psxS, psyS, pszS)
psxS <- psxS[ord]
psyS <- psyS[ord]
pszS <- pszS[ord]
### (2) Size:
# Reset school sizes:
size <- setSchoolSize(schoolSize, schoolCount=schoolCount, seed=seed)
szxS <- size[,1]
szyS <- size[,2]
szzS <- size[,3]
### (3) Shape:
# Use rectangular shaped "schools" for the layer:
shpS <- "e"
### (4) Direction:
# Random orientation of the school (including the fish):
#thtS <- runif(schoolCount, 0, 2*pi)
#phiS <- pi/2
hazS <- 0
helS <- pi/2
oazS <- runif(schoolCount, 0, 2*pi)
oelS <- pi/2
### (5) Rotation:
# School rotations (no rotation):
rtxS <- 0
rtyS <- 0
rtzS <- 0
### (6) Speed:
# No speed:
aspS <- 0
### (7) Packing density:
#rhoS <- 1
### (8) Polarization:
# SD of mean 0-Gaussian distribution of individual fish positions:
#SDxf <- 1,
#SDxf <- 1,
#SDxf <- 1,
# No polarization:
plHS <- Inf
### (9) Drift:
# No drift:
### (10) Volume:
###volS = volS <- 4/3*pi * schools$szxS/2 * schools$szyS/2 * schools$szzS/2
# Ellipsoidal schools (http://keisan.casio.com/has10/SpecExec.cgi?path=05000000.Mathematics%2F01000300.Volume%20and%20surface%20area%2F13000700.Volume%20of%20an%20ellipsoidal%20cap%2Fdefault.xml&charset=utf-8):
##axA <- schools$szxS/2
##axB <- schools$szyS/2
##axC <- schools$szzS/2
##below <- schools$pszS - axC
### Add volS also as a global variable for use in nbfS. Volume 'volS' is only used to derive the approximate memory used:
##volS = volS <- pi/3 * axA*axB * below^2/axC^2 * (3*axC - below)
##vol0 <- 4*pi/3 * axA * axB * axC
axA <- szxS/2
axB <- szyS/2
axC <- szzS/2
below <- axC - pszS
# For fully submerged schools the height below is set to the heigth of the school:
below[below > szzS] <- szzS[below > szzS]
below[below < 0] <- 0
volS <- pi/3 * axA * axB * below^2/axC^2 * (3*axC - below)
vol0 <- 4*pi/3 * axA * axB * axC
}
# Otherwise an error:
else{
stop(paste0("School distribution ", tolower(schoolDistribution[1]), " not implemented"))
}
# Add the survey region to the statis school file:
schoolStatic$surv <- surveyRegion
# Add the data into the schoolDynamic:
schoolDynamic <- c(
schoolDynamic,
list(
# (1) Position:
psxS = psxS,
psyS = psyS,
pszS = pszS,
# (2) Size:
szxS = szxS,
szyS = szyS,
szzS = szzS,
# (3) Shape:
shpS = shpS,
# (4) Direction:
#thtS = thtS,
#phiS = phiS,
hazS = hazS,
helS = helS,
oazS = oazS,
oelS = oelS,
# (5) Rotation:
rtxS = rtxS,
rtyS = rtyS,
rtzS = rtzS,
# (6) Speed:
aspS = aspS,
# (7) Packing density:
rhoS = rhoS,
spcS = spacing,
# (8) Polarization:
plHS = plHS,
# (9) Drift:
# (10) Volume:
volS = volS,
vol0 = vol0
)
)
schoolDynamic$scls <- 1
# Pick the start time of the simulation project as the time of all of the schools:
schoolDynamic$utmS <- rep(head(vessel$utim, 1), schoolCount)
schoolDynamic$ut9S <- rep(Inf, schoolCount)
# Repeat to apropriate length:
#allNumt <- unlist(lapply(schoolDynamic, NCOL))
#maxnumt <- max(allNumt)
#allSchoolCount <- unlist(lapply(schoolDynamic, NROW))
#schoolCount <- max(allSchoolCount)
# Discard empty elements:
#schoolDynamic <- schoolDynamic[sapply(schoolDynamic, length)>0]
#
#if(!all(allNumt==maxnumt)){
# schoolDynamic <- lapply(schoolDynamic, apply, 1, rep, length.out=maxnumt)
#}
#if(!all(allSchoolCount==schoolCount)){
# schoolDynamic <- lapply(schoolDynamic, apply, 2, rep, length.out=schoolCount)
#}
maxlength <- max(unlist(lapply(schoolDynamic, length)))
# schoolDynamic <- lapply(schoolDynamic, rep, length.out=maxlength)
# Add data:
schoolDynamic <- replaceKeepDim(schoolDynamic, dotList, esnm="")
add_SDxf <- function(x){
# Set the standard deviation of the fish positions with expected value at the gridded positions to be the distance expected distance between the fish (cubic root of the space reserved for each fish):
if(length(x$SDxf)==0){
x$SDxf <- x$spcS
}
if(length(x$SDyf)==0){
x$SDyf <- x$spcS
}
if(length(x$SDzf)==0){
x$SDzf <- x$spcS
}
x
}
schoolDynamic <- add_SDxf(schoolDynamic)
add_nbfS <- function(x){
x$nbfS <- x$rhoS * x$volS
x
}
schoolDynamic <- add_nbfS(schoolDynamic)
# Calculate the distances to the schools, and find the time steps which are closest, and the distance at those time steps:
getClosestTimeAndDist <- function(schoolind, vessel, schoolDynamic){
d <- fields::rdist(cbind(vessel$psxv, vessel$psyv, vessel$pszv), cbind(schoolDynamic$psxS[schoolind], schoolDynamic$psyS[schoolind], schoolDynamic$pszS[schoolind]))
cbind(
apply(d, 2, min),
apply(d, 2, which.min)
)
#apply(d, 2, which.min)
}
maxSize <- 1e6
stepZize <- ceiling(maxSize / length(vessel$psxv))
steps <- split(seq_along(schoolDynamic$psxS), ceiling(seq_along(schoolDynamic$psxS) / stepZize))
temp <- lapply(steps, getClosestTimeAndDist, vessel=vessel, schoolDynamic=schoolDynamic)
temp <- do.call(rbind, temp)
schoolDynamic$dstc <- temp[,1]
schoolDynamic$timc <- temp[,2]
#d <- fields::rdist(cbind(vessel$psxv, vessel$psyv, vessel$pszv), cbind(schoolDynamic$psxS, schoolDynamic$psyS, schoolDynamic$pszS))
#schoolDynamic$dstc <- apply(d, 2, min)
#schoolDynamic$timc <- apply(d, 2, which.min)
# Create the folder for the school:
schoolStaticFolder <- file.path(event$path, schoolName)
lapply(schoolStaticFolder, dir.create, showWarnings = FALSE)
schoolStaticFiles <- file.path(schoolStaticFolder, paste0(event$name, "_SchoolStatic", ".school"))
schoolDynamicFiles <- file.path(schoolStaticFolder, paste0(event$name, "_SchoolDynamic", ".school"))
# Update the sizes of the schools:
size <- setSchoolSize(schoolSize, schoolCount=schoolCount, seed=seed)
# Write the static school file to the events:
if(onlyFirstEvent){
schoolStaticFiles <- schoolStaticFiles[1]
}
lapply(schoolStaticFiles, function(thispath) write.TSD(schoolStatic, thispath, numt=1))
# Add the file names to the output:
names(schoolStaticFiles) <- event$esnm
files <- c(files, schoolStaticFiles)
#lapply(if(onlyFirstEvent) event$path[1] else event$path, function(thispath) write.TSD(schoolStatic, file.path(thispath, paste0(event$name, "_SchoolStatic", ".school")), numt=1))
# Write the static school file to the events:
#lapply(if(onlyFirstEvent) event$path[1] else event$path, function(thispath) write.TSD(schoolDynamic, file.path(thispath, paste0(event$name, "_SchoolDynamic", ".school")), numt=ncol(schoolDynamic$psxS)))
#schoolDynamicFiles <- file.path(event$path, schoolName, paste0(event$name, "_SchoolDynamic", ".school"))
if(onlyFirstEvent){
schoolDynamicFiles <- schoolDynamicFiles[1]
}
lapply(schoolDynamicFiles, function(thispath) write.TSD(schoolDynamic, thispath, numt=1))
# Add the file names to the output:
names(schoolDynamicFiles) <- event$esnm
files <- c(files, schoolDynamicFiles)
return(files)
}
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.