#' @title Bland-Altman drawing function for R
#'
#' @description Bland-Altman drawing function. Depends on the blandr.statistics function in the package. Will generate a plot via the standard R plotting functions.
#'
#' @author Deepankar Datta <deepankardatta@nhs.net>
#'
#' @note Started 2015-11-14
#' @note Last update 2015-11-19
#' @note Originally designed for LAVAS and CVLA
#'
#' @param method1 A list of numbers.
#' @param method2 A list of numbers.
#' @inheritParams blandr.statistics
#' @inheritParams blandr.plot.limits
#' @inheritParams blandr.plot.ggplot
#'
#' @examples
#' # Generates two random measurements
#' measurement1 <- rnorm(100)
#' measurement2 <- rnorm(100)
#'
#' # Generates a plot, with no optional arguments
#' gg_bland_altman(measurement1, measurement2)
#' @export
gg_bland_altman <- function(method1,
                            method2,
                            method1name = "Method 1",
                            method2name = "Method 2",
                            plotTitle = "Bland-Altman plot for comparison of 2 methods",
                            sig.level = 0.95,
                            LoA.mode = 1,
                            ciDisplay = TRUE,
                            ciShading = TRUE,
                            ciFillColors = c("steelblue3", "gray85"),
                            normalLow = FALSE,
                            normalHigh = FALSE,
                            lowest_y_axis = FALSE,
                            highest_y_axis = FALSE,
                            point_size = 0.8,
                            overlapping = FALSE,
                            x.plot.mode = "means",
                            y.plot.mode = "difference",
                            plotProportionalBias = FALSE,
                            plotProportionalBias.se = TRUE,
                            assume.differences.are.normal = TRUE) {

  # Passes data to the blandr.statistics function to generate Bland-Altman statistics
  statistics.results <- blandr.statistics(method1, method2, sig.level, LoA.mode)

  # Passed data to the blandr.plot.limits function to generate plot limits
  # Only used for the basic R plots
  plot.limits <- blandr.plot.limits(statistics.results, lowest_y_axis, highest_y_axis)

  # Plots data

  # Pass data to the blandr.plot.ggplot function to use ggplot2 graphics system
  ba.plot <- blandr.plot.ggplot(
    statistics.results = statistics.results,
    method1name = method1name,
    method2name = method2name,
    plotTitle = plotTitle,
    ciDisplay = ciDisplay,
    ciShading = ciShading,
    ciFillColors = ciFillColors,
    normalLow = normalLow,
    normalHigh = normalHigh,
    overlapping = overlapping,
    x.plot.mode = x.plot.mode,
    y.plot.mode = y.plot.mode,
    point_size = point_size,
    plotProportionalBias = plotProportionalBias,
    plotProportionalBias.se = plotProportionalBias.se,
    assume.differences.are.normal = assume.differences.are.normal
  )
  return(ba.plot)
  # END OF FUNCTION
}

#' @title Data preparation for method comparison analysis
#'
#' @description Prepares the data and runs error checks before the calling function runs whatever method analysis mode is wants.
#'
#' @author Deepankar Datta <deepankardatta@nhs.net>
#'
#' @param method1 A list of numbers.
#' @param method2 A list of numbers.
#' @param sig.level Significance level. Is not optional in this function, as the calling package should have a default value to pass if needed
#'
#' @return method.comparison A data frame of paired values. These have been data checked, and empty rows omitted, from the originally supplied data.
#'
#' @examples
#' # Generates two random measurements
#' measurement1 <- rnorm(100)
#' measurement2 <- rnorm(100)
#'
#' # Calls the function - do note that this function was really
#' # meant to be called from other functions and not a stand-alone funtion
#' blandr.data.preparation(measurement1, measurement2, sig.level = 0.95)
#' @export
blandr.data.preparation <- function(method1, method2, sig.level) {

  # Put everything into a data frame for easier handling Stems from the error in some of
  # the sepsis data I had
  method.comparison <- data.frame(method1, method2)

  # Omit rows which have empty values
  method.comparison <- na.omit(method.comparison)

  # Data checks
  if (length(method.comparison$method1) != length(method.comparison$method2)) {
    stop("Method comparison analysis error: the 2 methods must have paired values.")
  }
  if (!is.numeric(method.comparison$method1)) {
    stop("Method comparison analysis error: the first method is not a number.")
  }
  if (!is.numeric(method.comparison$method2)) {
    stop("Method comparison analysis error: the second method is not a number.")
  }
  if (sig.level < 0) {
    stop("Method comparison analysis error: you can't have a significance level less than 0.")
  }
  if (sig.level < 0.8) {
    warning("Method comparison analysis warning: do you really want a significance level <0.8?")
  }
  if (sig.level > 1) {
    stop("Method comparison analysis error: you can't have a significance level greater than 1.")
  }
  if (sig.level == 1) {
    warning("Method comparison analysis warning: selecting a significance level of 1 suggest that probability testing might not be what you need.")
  }

  # Returns the data
  return(method.comparison)
}

#' @title Bland-Altman plotting function, using ggplot2
#'
#' @description Draws a Bland-Altman plot using data calculated using the other functions, using ggplot2
#'
#' @author Deepankar Datta <deepankardatta@nhs.net>
#'
#' @param statistics.results A list of statistics generated by the blandr.statistics function: see the function's return list to see what variables are passed to this function
#' @param method1name (Optional) Plotting name for 1st method, default "Method 1"
#' @param method2name (Optional) Plotting name for 2nd method, default "Method 2"
#' @param plotTitle (Optional) Title name, default "Bland-Altman plot for comparison of 2 methods"
#' @param point_size (Optional) Default = 0.8
#' @param ciDisplay (Optional) TRUE/FALSE switch to plot confidence intervals for bias and limits of agreement, default is TRUE
#' @param ciShading (Optional) TRUE/FALSE switch to plot confidence interval shading to plot, default is TRUE
#' @param ciFillColors (Optional) 2-vector of colors to use in the bias shading and confidence band shading
#' @param normalLow (Optional) If there is a normal range, entering a continuous variable will plot a vertical line on the plot to indicate its lower boundary
#' @param normalHigh (Optional) If there is a normal range, entering a continuous variable will plot a vertical line on the plot to indicate its higher boundary
#' @param overlapping (Optional) TRUE/FALSE switch to increase size of plotted point if multiple values using ggplot's geom_count, deafault=FALSE. Not currently recommend until I can tweak the graphics to make them better
#' @param x.plot.mode (Optional) Switch to change x-axis from being plotted by means (="means") or by either 1st method (="method1") or 2nd method (="method2"). Default is "means". Anything other than "means" will switch to default mode.
#' @param y.plot.mode (Optional) Switch to change y-axis from being plotted by difference (="difference") or by proportion magnitude of measurements (="proportion"). Default is "difference". Anything other than "proportional" will switch to default mode.
#' @param plotProportionalBias (Optional) TRUE/FALSE switch. Plots a proportional bias line. Default is FALSE.
#' @param plotProportionalBias.se (Optional) TRUE/FALSE switch. If proportional bias line is drawn, switch to plot standard errors. See stat_smooth for details. Default is TRUE.
#' @param assume.differences.are.normal (Optional, not operationally used currently) Assume the difference of means has a normal distribution. Will be used to build further analyses
#'
#' @return ba.plot Returns a ggplot data set that can then be plotted
#'
#' @import ggplot2
#'
#' @examples
#' # Generates two random measurements
#' measurement1 <- rnorm(100)
#' measurement2 <- rnorm(100)
#'
#' # Generates a ggplot
#' # Do note the ggplot function wasn't meant to be used on it's own
#' # and is generally called via the bland.altman.display.and.draw function
#'
#' # Passes data to the blandr.statistics function to generate Bland-Altman statistics
#' statistics.results <- blandr.statistics(measurement1, measurement2)
#'
#' # Generates a ggplot, with no optional arguments
#' blandr.plot.ggplot(statistics.results)
#'
#' # Generates a ggplot, with title changed
#' blandr.plot.ggplot(statistics.results, plotTitle = "Bland-Altman example plot")
#'
#' # Generates a ggplot, with title changed, and confidence intervals off
#' blandr.plot.ggplot(statistics.results,
#'   plotTitle = "Bland-Altman example plot",
#'   ciDisplay = FALSE, ciShading = FALSE
#' )
#' @export

blandr.plot.ggplot <- function(statistics.results,
                               method1name = "Method 1",
                               method2name = "Method 2",
                               plotTitle = "Bland-Altman plot for comparison of 2 methods",
                               point_size = 0.8,
                               ciDisplay = TRUE,
                               ciShading = TRUE,
                               ciFillColors = c("steelblue3", "gray85"),
                               normalLow = FALSE,
                               normalHigh = FALSE,
                               overlapping = FALSE,
                               x.plot.mode = "means",
                               y.plot.mode = "difference",
                               plotProportionalBias = FALSE,
                               plotProportionalBias.se = TRUE,
                               assume.differences.are.normal = TRUE) {

  # Does a check if ggplot2 is available
  # It should be as it is in the imports section but in CRAN checks some systems don't have it!
  if (!requireNamespace("ggplot2", quietly = TRUE)) {
    stop("Package \"ggplot2\" needed for this function to work. Please install it.",
      call. = FALSE
    )
  }

  # Selects if x-axis uses means (traditional) or selects one of the methods
  # as the gold standard (non-traditional BA)
  # See Krouwer JS (2008) Why Bland-Altman plots should use X, not (Y+X)/2 when X is a reference method. Statistics in Medicine 27:778-780
  # NOT ENABLED YET
  x.axis <- statistics.results$means

  # Selects if uses differences (traditional) or proportions (non-traditional BA)
  if (y.plot.mode == "proportion") {
    y.axis <- statistics.results$proportion
  } else {
    y.axis <- statistics.results$differences
  }

  # Constructs the plot.data dataframe
  plot.data <- data.frame(x.axis, y.axis)

  # Rename to allow plotting
  # This was a hangover from an older version so I'm not sure we need it anymore
  # But not really a priority to check and remove now
  colnames(plot.data)[1] <- "x.axis"
  colnames(plot.data)[2] <- "y.axis"

  # Plot using ggplot
  ba.plot <- ggplot(plot.data, aes(x = x.axis, y = y.axis))

  # Drawing confidence intervals (OPTIONAL) -- put this here so that it appears under the points
  if (ciDisplay == TRUE) {
    ba.plot <- ba.plot +
      geom_hline(yintercept = statistics.results$biasUpperCI, linetype = 3) + # Bias - upper confidence interval
      geom_hline(yintercept = statistics.results$biasLowerCI, linetype = 3) + # Bias - lower confidence interval
      geom_hline(yintercept = statistics.results$upperLOA_upperCI, linetype = 3) + # Upper limit of agreement - upper confidence interval
      geom_hline(yintercept = statistics.results$upperLOA_lowerCI, linetype = 3) + # Upper limit of agreement - lower confidence interval
      geom_hline(yintercept = statistics.results$lowerLOA_upperCI, linetype = 3) + # Lower limit of agreement - upper confidence interval
      geom_hline(yintercept = statistics.results$lowerLOA_lowerCI, linetype = 3) # Lower limit of agreement - lower confidence interval

    # Shading areas for 95% confidence intervals (OPTIONAL)
    # This needs to be nested into the ciDisplay check
    if (ciShading == TRUE) {
      ba.plot <- ba.plot +
        annotate("rect", xmin = -Inf, xmax = Inf, ymin = statistics.results$biasLowerCI, ymax = statistics.results$biasUpperCI, fill = ciFillColors[1], alpha = 0.3) + # Bias confidence interval shading
        annotate("rect", xmin = -Inf, xmax = Inf, ymin = statistics.results$upperLOA_lowerCI, ymax = statistics.results$upperLOA_upperCI, fill = ciFillColors[2], alpha = 0.3) + # Upper limits of agreement confidence interval shading
        annotate("rect", xmin = -Inf, xmax = Inf, ymin = statistics.results$lowerLOA_lowerCI, ymax = statistics.results$lowerLOA_upperCI, fill = ciFillColors[2], alpha = 0.3) # Lower limits of agreement confidence interval shading
    }
  }

  # continue plotting
  ba.plot <- ba.plot +
    geom_point(size = point_size) +
    theme(plot.title = element_text(hjust = 0.5)) +
    geom_hline(yintercept = 0, linetype = 1) + # "0" line
    geom_hline(yintercept = statistics.results$bias, linetype = 2) + # Bias
    geom_hline(yintercept = statistics.results$bias + (statistics.results$biasStdDev * statistics.results$sig.level.convert.to.z), linetype = 2) + # Upper limit of agreement
    geom_hline(yintercept = statistics.results$bias - (statistics.results$biasStdDev * statistics.results$sig.level.convert.to.z), linetype = 2) + # Lower limit of agreement
    ggtitle(plotTitle) +
    xlab("Means")

  # Re-titles the y-axis dependent on which plot option was used
  if (y.plot.mode == "proportion") {
    ba.plot <- ba.plot + ylab("Difference / Average %")
  } else {
    ba.plot <- ba.plot + ylab("Differences")
  }

  ### Function has finished drawing of confidence intervals at this line

  # If a normalLow value has been sent, plots this line
  if (normalLow != FALSE) {
    # Check validity of normalLow value to plot line
    if (is.numeric(normalLow) == TRUE) {
      ba.plot <- ba.plot + geom_vline(xintercept = normalLow, linetype = 4, col = 6)
    }
  }

  # If a normalHighvalue has been sent, plots this line
  if (normalHigh != FALSE) {
    # Check validity of normalHigh value to plot line
    if (is.numeric(normalHigh) == TRUE) {
      ba.plot <- ba.plot + geom_vline(xintercept = normalHigh, linetype = 4, col = 6)
    }
  }

  # If overlapping=TRUE uses geom_count
  # See the param description at the top
  if (overlapping == TRUE) {
    ba.plot <- ba.plot + geom_count()
  }

  # If plotProportionalBias switch is TRUE, plots a proportional bias line as well
  if (plotProportionalBias == TRUE) {

    # Check for validity of options passed to the plotProportionalBias.se switch
    # As if we throw an invalid option to ggplot it will just stop with an error
    if (plotProportionalBias.se != TRUE && plotProportionalBias.se != FALSE) {
      plotProportionalBias.se <- TRUE
    }

    # Plots line
    ba.plot <- ba.plot + ggplot2::geom_smooth(method = "lm", se = plotProportionalBias.se)
  } # End of drawing proportional bias line

  # Draws marginal histograms if option selected
  # Idea from http://labrtorian.com/tag/bland-altman/
  # REMOVED AS INTRODUCED SOME INCOMPATIBILITIES DEPENDENT ON USERS R VERSION
  # ALSO MASSIVELY INCREASED PACKAGE SIZE
  # if( marginalHistogram == TRUE ) { ba.plot <- ggMarginal( ba.plot , type="histogram" ) }

  # Return the ggplot2 output
  return(ba.plot)

  # END OF FUNCTION
}

#' @title Bland-Altman plot limits for R
#'
#' @description Works out plot limits for the Bland-Altman plots. Depends on the blandr.statistics function in the package.
#'
#' @author Deepankar Datta <deepankardatta@nhs.net>
#'
#' @param statistics.results A list of statistics generated by the blandr.statistics function: see the function's return list to see what variables are passed to this function
#' @param lowest_y_axis (Optional) Defaults to NULL If given a continuous variable will use this as the lower boundary of the y axis. Useful if need multiple plots with equivalent y-axes.
#' @param highest_y_axis (Optional) Defaults to NULL If given a continuous variable will use this as the upper boundary of the y axis. Useful if need multiple plots with equivalent y-axes.
#' @return x_upper The upper limit of the X-axis
#' @return x_lower The lower limit of the X-axis
#' @return y_upper The upper limit of the Y-axis
#' @return y_lower The lower limit of the Y-axis
#'
#' @examples
#' # Generates two random measurements
#' measurement1 <- rnorm(100)
#' measurement2 <- rnorm(100)
#'
#' # Passes data to the blandr.statistics function to generate Bland-Altman statistics
#' statistics.results <- blandr.statistics(measurement1, measurement2)
#'
#' # Calls the function
#' blandr.plot.limits(statistics.results)
#' @export

blandr.plot.limits <- function(statistics.results, lowest_y_axis = FALSE, highest_y_axis = FALSE) {

  # Calculates a margin for error - therefore labelled bounds
  x_bounds <- (max(statistics.results$means) - min(statistics.results$means)) * 0.1 ### this is a margin of error for drawing the x axis
  y_bounds <- (max(statistics.results$differences) - min(statistics.results$differences)) *
    0.1 ### this is a margin of error for drawing the y axis

  # Sets limits for plot on the x-axis
  x_upper <- max(statistics.results$means) + x_bounds
  x_lower <- min(statistics.results$means) - x_bounds

  # Sets limits for plot on the y-axis
  y_upper <- max(statistics.results$differences) + y_bounds
  y_lower <- min(statistics.results$differences) - y_bounds

  # Ensures that y-axis includes the whole range of confidence intervals
  if (y_upper <= statistics.results$upperLOA_upperCI) {
    y_upper <- statistics.results$upperLOA_upperCI + y_bounds
  }
  if (y_lower >= statistics.results$lowerLOA_lowerCI) {
    y_lower <- statistics.results$lowerLOA_lowerCI - y_bounds
  }

  # If the user has requested specific limits to the y-axis the following 2 lines execute
  # this
  if (highest_y_axis != FALSE) {
    y_upper <- highest_y_axis
  }
  if (lowest_y_axis != FALSE) {
    y_lower <- lowest_y_axis
  }

  return(
    list(x_upper = x_upper, x_lower = x_lower, y_upper = y_upper, y_lower = y_lower) # CLOSE OF LIST
  ) # CLOSE OF RETURN

  # END OF FUNCTION
}

#' @title Bland-Altman statistics for R
#'
#' @description Bland-Altman analysis function for R. Package created as existing
#' functions don't suit my needs, and don't generate 95\% confidence intervals
#' for bias and limits of agreement. This base function calculates the basic
#' statistics, and generates return values which can be used in the related
#' \code{blandr.display} and \code{bland.altamn.plot} functions. However
#' the return results can be used to generate a custom chart if desired.
#'
#' @author Deepankar Datta <deepankardatta@nhs.net>
#'
#' @note The function will give similar answers when used on the original Bland-Altman PEFR data sets. They won't be exactly the same as (a) for 95\% limits of agreement I have used +/-1.96, rather than 2, and (b) the computerised calculation means that the rounding that is present in each step of the original examples does not occur. This will give a more accurate answer, although I can understand why in 1986 rounding would occur at each step for ease of calculation.
#' @note The function depends on paired values.
#' @note It currently only can currently work out fixed bias.
#' @note Improvements for the future: proportional bias charts will need further work
#'
#' @note Started 2015-11-14
#' @note Last update 2016-02-04
#' @note Originally designed for LAVAS and CVLA
#'
#' @references Based on: (1) Bland, J. M., & Altman, D. (1986). Statistical methods for assessing agreement between two methods of clinical measurement. The Lancet, 327(8476), 307-310. http://dx.doi.org/10.1016/S0140-6736(86)90837-8
#' @references Confidence interval work based on follow-up paper: (2) Altman, D. G., & Bland, J. M. (2002). Commentary on quantifying agreement between two methods of measurement. Clinical chemistry, 48(5), 801-802. http://www.clinchem.org/content/48/5/801.full.pdf
#'
#' @param x Either a formula, or a vector of numbers corresponding to the results from method 1.
#' @param y A vector of numbers corresponding to the results from method 2. Only needed if \code{X} is a vector.
#' @param sig.level (Optional) Two-tailed significance level. Expressed from 0 to 1. Defaults to 0.95.
#' @param LoA.mode (Optional) Switch to change how accurately the limits of agreement (LoA) are calculated from the bias and its standard deviation. The default is LoA.mode=1 which calculates LoA with the more accurate 1.96x multiplier. LoA.mode=2 uses the 2x multiplier which was used in the original papers. This should really be kept at default, except to double check calculations in older papers.
#'
#' @return An object of class 'blandr' is returned. This is a list with the following elements:
#' \item{means}{List of arithmetic mean of the two methods}
#' \item{differences}{List of differences of the two methods}
#' \item{method1}{Returns the 'method1' list in the data frame if further evaluation is needed}
#' \item{method2}{Returns the 'method2' list in the data frame if further evaluation is needed}
#' \item{sig.level}{Significance level supplied to the function}
#' \item{sig.level.convert.to.z}{Significance level convert to Z value}
#' \item{bias}{Bias of the two methods}
#' \item{biasUpperCI}{Upper confidence interval of the bias (based on significance level)}
#' \item{biasLowerCI}{Lower confidence interval of the bias (based on significance level)}
#' \item{biasStdDev}{Standard deviation for the bias}
#' \item{biasSEM}{Standard error for the bias}
#' \item{LOA_SEM}{Standard error for the limits of agreement}
#' \item{upperLOA}{Upper limit of agreement}
#' \item{upperLOA_upperCI}{Upper confidence interval of the upper limit of agreement}
#' \item{upperLOA_lowerCI}{Lower confidence interval of the upper limit of agreement}
#' \item{lowerLOA}{Lower limit of agreement}
#' \item{lowerLOA_upperCI}{Upper confidence interval of the lower limit of agreement}
#' \item{lowerLOA_lowerCI}{Lower confidence interval of the lower limit of agreement}
#' \item{proportion}{Differences/means*100}
#' \item{no.of.observations}{Number of observations}
#' \item{regression.equation}{A regression equation to help determine if there is any proportional bias}
#' \item{regression.fixed.slope}{The slope value of the regression equation}
#' \item{regression.fixed.intercept}{The intercept value of the regression equation}
#'
#' @importFrom stats coef cor lm na.omit qnorm qt sd t.test
#'
#' @examples
#'
#' # Generates two random measurements
#' measurement1 <- rnorm(100)
#' measurement2 <- rnorm(100)
#'
#' # Generates Bland-Altman statistics data of the two measurements
#' blandr.statistics(measurement1, measurement2)
#' @rdname blandr.statistics
#' @export
blandr.statistics <- function(x,
                              y,
                              sig.level = 0.95,
                              LoA.mode = 1) {

  # This sends to the preparation function, which does some sense checks on the data And
  # makes sure that the values are prepared
  method1 <- x
  method2 <- y
  ba.data <- blandr.data.preparation(method1, method2, sig.level)

  # method1 and method2 are the measurements
  means <- (ba.data$method1 + ba.data$method2) / 2
  differences <- ba.data$method1 - ba.data$method2
  bias <- mean(differences)
  biasStdDev <- sd(differences)

  # Convert confidence interval to a two-tailed z-value Don't really need this but kept as
  # a remnant of old version to possibly use in the future
  alpha <- 1 - sig.level
  sig.level.two.tailed <- 1 - (alpha / 2)
  sig.level.convert.to.z <- qnorm(sig.level.two.tailed)

  # Compute the 95% limits of agreement (based on 1st paper) Don't use the significance
  # level supplied to the function here!  (The significance level is for confidence
  # intervals, not for limits of agreement!)  We want to know in the sample what limits 95%
  # of the pop resides within The LoA.mode switch can change before the +/-1.96 multiplier
  # used in more recent papers Or the estimated +/-2 multiplier used in the original paper
  # The default is LoA.mode which gives a LoA.multiplier of 1.96. In future we could use an
  # even more precise multipler for limits of agreement.
  if (LoA.mode == 2) {
    LoA.multiplier <- 2
  } else {
    LoA.multiplier <- 1.96
  }
  upperLOA <- bias + (LoA.multiplier * biasStdDev)
  lowerLOA <- bias - (LoA.multiplier * biasStdDev)

  # Confidence intervals (based on 2nd paper) Based on significance level supplied
  # (defaults to 95% CI) CI for mean
  biasSEM <- sd(differences) / sqrt(length(differences))
  biasCI <- qt(sig.level.two.tailed, df = length(differences) - 1) * biasSEM
  biasUpperCI <- bias + biasCI
  biasLowerCI <- bias - biasCI

  # CI for limits of agreement LOAVariance from Carkeet
  LOAVariance <- ((1 / length(differences)) + ((sig.level.convert.to.z^2) / (2 * (length(differences) -
    1)))) * biasStdDev^2
  LOA_SEM <- sqrt(LOAVariance)
  LOA_CI <- qt(sig.level.two.tailed, df = length(differences) - 1) * LOA_SEM
  upperLOA_upperCI <- upperLOA + LOA_CI
  upperLOA_lowerCI <- upperLOA - LOA_CI
  lowerLOA_upperCI <- lowerLOA + LOA_CI
  lowerLOA_lowerCI <- lowerLOA - LOA_CI

  # Difference/mean proportion
  proportion <- differences / means * 100

  # Number of observations
  no.of.observations <- length(means)

  # Works out numbers for proportional bias
  # Couldn't figure this out myself So took example code from
  # http://rforpublichealth.blogspot.co.uk/2013/11/ggplot2-cheatsheet-for-scatterplots.html
  m <- lm(differences ~ means)
  a <- signif(coef(m)[1], digits = 2)
  b <- signif(coef(m)[2], digits = 2)
  regression.equation <- paste("y(differences) = ", b, " x(means) + ", a, sep = "")

  results <-
    list(
      means = means,
      differences = differences,
      method1 = method1,
      method2 = method2,
      sig.level = sig.level,
      sig.level.convert.to.z = sig.level.convert.to.z,
      bias = bias,
      biasUpperCI = biasUpperCI,
      biasLowerCI = biasLowerCI,
      biasStdDev = biasStdDev,
      biasSEM = biasSEM,
      LOA_SEM = LOA_SEM,
      upperLOA = upperLOA,
      upperLOA_upperCI = upperLOA_upperCI,
      upperLOA_lowerCI = upperLOA_lowerCI,
      lowerLOA = lowerLOA,
      lowerLOA_upperCI = lowerLOA_upperCI,
      lowerLOA_lowerCI = lowerLOA_lowerCI,
      proportion = proportion,
      no.of.observations = no.of.observations,
      regression.equation = regression.equation,
      regression.fixed.slope = b,
      regression.fixed.intercept = a
    ) # CLOSE OF LIST

  class(results) <- "blandr"
  return(results)

  # END OF FUNCTION
}


##
## Replicating the analyses in Koster & Leckie (2014) - "Food sharing networks in lowland Nicaragua: An application of the social relations model to count data"
## using the R interface to WinBUGS
##
## Author: Matthew Gwynfryn Thomas (@matthewgthomas)
## URL: http://matthewgthomas.co.uk
## Date: 16 April 2015
##
## Before running the code, do these:
## 1. install WinBUGS from: http://www.mrc-bsu.cam.ac.uk/software/bugs/the-bugs-project-winbugs/
##    - install patch for version 1.4.3
##    - load the license key
##
## 2. install the R packages R2WinBUGS and memisc
##
## 3. download the supplementary data files from http://dx.doi.org/10.1016/j.socnet.2014.02.002
##    and unzip them into your R working directory
##
## Note: This code uses a modified version of Koster & Leckie's "model1.txt" model specification.
##   The only difference is that in "model1_mgt.txt" the intercept 'beta' is no longer an array.
##   (The diff in this GitHub project shows the exact change made.)
##
##
## Copyright (c) 2015 Matthew Gwynfryn Thomas
##
## Permission is hereby granted, free of charge, to any person obtaining a copy
## of this software and associated documentation files (the "Software"), to deal
## in the Software without restriction, including without limitation the rights
## to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
## copies of the Software, and to permit persons to whom the Software is
## furnished to do so, subject to the following conditions:
##
## The above copyright notice and this permission notice shall be included in all
## copies or substantial portions of the Software.
##
## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
## IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
## FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
## AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
## LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
## OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
## SOFTWARE.
## ----------------------------------------------------------------------------

#install.packages("R2WinBUGS", "memisc")
library(R2WinBUGS)
library(memisc)  # for the mtables() model summariser function

# this file contains a summariser function for BUGS social relations models
# see: https://gist.github.com/matthewgthomas/beef5ee7a434d3da934d
source("https://gist.githubusercontent.com/matthewgthomas/beef5ee7a434d3da934d/raw/06fbdc38003b7648b503f7dc0464549e053c84ad/getSummary.bugs.r")

winbugs_dir = "C:/Program Files/WinBUGS14/"  # change this to your WinBUGS directory

###############################################################
## Load and prepare data
##
dyads = read.csv("dyads.csv")
hh = read.csv("households.csv")

# remove "did" (dyad ID) and "hid" (household ID)
dyads$did = NULL
hh$hid = NULL

# convert the dyads and households column names into one list
data = c(as.list(colnames(dyads)), as.list(colnames(hh)))

# add "R_gr" (scale matrix associated with the Wishart prior for the giver-receiver covariance matrix)
data = c(data, "R_gr")

# make R_gr scale matrix
R_gr = matrix(c(1,0,0,1), nrow=2, ncol=2)

# create separate lists in the workspace for each column in the dyads and hh dataframes
## code from: http://stackoverflow.com/questions/16052239/split-a-data-frame-by-columns-and-storing-each-column-as-an-object-with-the-colu
invisible(lapply(names(dyads), function(x) assign(x, dyads[, x], envir = .GlobalEnv)))
invisible(lapply(names(hh), function(x) assign(x, hh[, x], envir = .GlobalEnv)))

# what do we want out of the model?
parameters <- c("beta", "COV_gr", "COV_dd", "gr", "dd", "rho_dd", "sigma_dd", "sigma2_d")

###############################################################
## Model 1
##
data_m1 = data[c(1:5, length(data))]  # keep only hidA, hidB, giftsAB, giftsBA, offset and R_gr

# specify initial values for the model parameters
inits_m1 = function() {
  list (beta = 0,  # only intercept in this model
        TAU_gr = matrix(c(2,0,0,2), nrow=2, ncol=2),  # giver-receiver precision matrix
        tau_d = 1.333,  # relationship precision == relationship variance of 0.75 (1 / tau_d)
        rho_dd = 0.500  # dyadid reciprocity
  )
}

# run the model
model1 = bugs(data_m1, inits_m1, parameters, "model1_mgt.txt",
              n.chains=1, n.burnin=50000, n.iter=100000, n.thin=100,
              debug=F, bugs.directory=winbugs_dir)

###############################################################
## Model 2
##
# specify initial values for the model parameters
inits_m2 = function() {
  list (beta = rep(0, 17),  # 17 coefficients = 0
        TAU_gr = matrix(c(2,0,0,2), nrow=2, ncol=2),  # giver-receiver precision matrix
        tau_d = 1.333,  # relationship precision == relationship variance of 0.75 (1 / tau_d)
        rho_dd = 0.500  # dyadid reciprocity
  )
}

# run the model
model2 = bugs(data, inits_m2, parameters, "model2.txt",
              n.chains=1, n.burnin=50000, n.iter=100000, n.thin=100,
              debug=F, bugs.directory=winbugs_dir)

###############################################################
## Show output of models (Table 2 in Koster & Leckie 2014)
##
plot(model1)
plot(model2)

bugs.summary = mtable("Model 1"=model1, "Model 2"=model2,
                      coef.style="ci.se.horizontal", digits=2)
relabel(bugs.summary,
        "beta[1]"  = "Intercept",
        "beta[2]"  = "Giver – Game",
        "beta[3]"  = "Giver – Fish",
        "beta[4]"  = "Giver – Pigs",
        "beta[5]"  = "Giver – Wealth",
        "beta[6]"  = "Receiver – Game",
        "beta[7]"  = "Receiver – Fish",
        "beta[8]"  = "Receiver – Pigs",
        "beta[9]"  = "Receiver – Wealth",
        "beta[10]" = "Receiver – Pastors",
        "beta[11]" = "Relationship – Relatedness 1",
        "beta[12]" = "Relationship – Relatedness 2",
        "beta[13]" = "Relationship – Relatedness 3",
        "beta[14]" = "Relationship – Relatedness 4",
        "beta[15]" = "Relationship – Distance (log transformed)",
        "beta[16]" = "Relationship – Association index",
        "beta[17]" = "Relationship – Giver 1 & Receiver 25"
        )


#!/usr/bin/env Rscript
options(warn=-1)

# CLI args
library("optparse")

# Set opts
opt.list = list(
make_option(c("-i", "--input"), type="character", default=NULL,
            help="input dataset file name", metavar="character"),
make_option(c("-o", "--output"), type="character", default="output",
            help="output file set base name [default = %default]", metavar="character"),
make_option(c("-a", "--algorithm"), type="character", default="bf",
            help="search algorithm to be used [fw | bf | spfa]", metavar="character"),
make_option(c("-b", "--benchmark"), type="logical", action="store_true", default=FALSE,
            help="benchmark all algorithms and show metrics (makes -a irrelevant)")
)

# Parse opts
opt.parser = OptionParser(option_list=opt.list)
opt = parse_args(opt.parser)

# Treat errors
if (is.null(opt$input)) {
    print_help(opt.parser)
    stop("Input dataset file must be specified\n", call.=F)
}

# Source scripts
source("fw-arbitrate.r")
source("bf-arbitrate.r")

# Read input data
input.edges = as.matrix(read.table(opt$input))
input.nodes = unique(matrix(input.edges[,1:2], ncol=1))

# Adapt edge weights
weights.new = -log(as.numeric(as.character(input.edges[,3])))
weights.new[which(weights.new==-Inf)] = 0 # cleaning -logs
input.edges.new = cbind(input.edges[,1:2], weights.new)

ret = NULL

# IF BENCHMARKING, measure all algorithms
if (opt$benchmark) {
    cat("\nRunning benchmark for all algorithms...\n")
    lines = c()
    nruns = 15

    # Message
    line = "Benchmarking Floyd-Warshall\n"
    lines = c(lines, line)
    cat("\n ", line)

    # Run FW
    times.fw = c()
    for (i in 1:nruns) {
        start = Sys.time()
        ret = fw.find(input.edges.new, input.edges, debug=F)
        time = Sys.time() - start

        # Record
        times.fw = c(times.fw, time)
        line = paste0("    Execution ", as.character(i), ": ", as.character(time), " seconds\n")
        lines = c(lines, line)
        cat(line)
    }

    ## Include the dummy node every possible
    ## negative cycle is made reachable from
    ## it (For the Bellman-Ford based algorithms)
    voids = cbind(rep("VOIDCURRENCY", NROW(input.nodes)),
                  input.nodes, rep(0, NROW(input.nodes)))
    input.edges = rbind(voids, as.matrix(input.edges))
    input.edges.new = rbind(voids, input.edges.new)

    # Message
    line = "Benchmarking Bellman-Ford\n"
    lines = c(lines, line)
    cat("\n ", line)

    # Run BF
    times.bf = c()
    for (i in 1:nruns) {
        start = Sys.time()
        ret = bf.find(input.edges.new, input.edges, debug=F)
        time = Sys.time() - start

        # Record
        times.bf = c(times.bf, time)
        line = paste0("    Execution ", as.character(i), ": ", as.character(time), " seconds\n")
        lines = c(lines, line)
        cat(line)
    }

    # Message
    line = "Benchmarking SPFA\n"
    lines = c(lines, line)
    cat("\n ", line)

    # Run SPFA
    times.spfa = c()
    for (i in 1:nruns) {
        start = Sys.time()
        ret = bf.spfa(input.edges.new, input.edges, debug=F)
        time = Sys.time() - start

        # Record
        times.spfa = c(times.spfa, time)
        line = paste0("    Execution ", as.character(i), ": ", as.character(time), " seconds\n")
        lines = c(lines, line)
        cat(line)
    }

    times.fw = as.numeric(times.fw)
    times.bf = as.numeric(times.bf)
    times.spfa = as.numeric(times.spfa)
    means = as.numeric(c(mean(times.fw), mean(times.bf), mean(times.spfa)))
    sdevs = as.numeric(c(sd(times.fw), sd(times.bf), sd(times.spfa)))

    # Prepare output
    out.summary = paste0(opt$output, ".summary")
    out.plot = paste0(opt$output, ".plot.png")

    # Output summary
    lines = c(lines, "\nAverage times and standard deviations:\n")
    timedata = as.matrix(cbind(means, sdevs))
    colnames(timedata) = c("Mean", "SD")
    rownames(timedata) = c("Floyd-Warshall", "Bellman-Ford", "SPFA")
    write(lines, out.summary)
    capture.output(print(timedata), file=out.summary, append=T)

    # Prepare plot
    png(out.plot)
    xaxis = 1:NROW(means)
    plot(xaxis, means, xlim=range(c(0, NROW(means) + 1)),
         ylim=range(c(means-sdevs, means+sdevs)), pch=20,
         xlab="Measures for FW, BF and SPFA respectively",
         ylab="Mean of 15 runs +/- SD in seconds",
         main="Algorithm performance measures")

    # Hachy arrows
    arrows(xaxis, means-sdevs, xaxis, means+sdevs, length=0.05, angle=90, code=3)
    text(x=xaxis, y=means, labels=c("Floyd-Warshall", "Bellman-Ford", "SPFA"), pos=4)
    dev.off()

    # OTHERWISE, run method specified via --algorithm
    cat("\n-> Execution summmary written to", out.summary, "\n")
    cat("-> Plot image written to", out.plot, "\n\n")
    browseURL(out.plot)
} else {

    if (opt$algorithm == "fw") {

        # Just run
        ret = fw.find(input.edges.new, input.edges)

    } else if (opt$algorithm == "bf") {

        ## Include the dummy node every possible
        ## negative cycle is made reachable from it
        voids = cbind(rep("VOIDCURRENCY", NROW(input.nodes)),
                      input.nodes, rep(0, NROW(input.nodes)))
        input.edges = rbind(voids, as.matrix(input.edges))
        input.edges.new = rbind(voids, input.edges.new)

        # Run
        ret = bf.find(input.edges.new, input.edges)

    } else if (opt$algorithm == "spfa") {

        ## Include the dummy node every possible
        ## negative cycle is made reachable from it
        voids = cbind(rep("VOIDCURRENCY", NROW(input.nodes)),
                      input.nodes, rep(0, NROW(input.nodes)))
        input.edges = rbind(voids, as.matrix(input.edges))
        input.edges.new = rbind(voids, input.edges.new)

        # Run
        ret = bf.spfa(input.edges.new, input.edges)

    } else {
        stop("No such algorithm implemented\n", call.=F)
    }

    # Ready output file names
    out.nodes = paste0(opt$output, ".nodes")
    out.cycle = paste0(opt$output, ".cycle")
    out.summary = paste0(opt$output, ".summary")

    # Write out everything
    cycle = cbind(ret$cycle[1:(NROW(ret$cycle)-1)], ret$cycle[2:NROW(ret$cycle)])
    write.table(ret$nodes, out.nodes, row.names=F, col.names=F, sep="\t", quote=F)
    write.table(cycle, out.cycle, row.names=F, col.names=F, sep="\t", quote=F)

    # This is ugly, sorry
    write(paste0("Starting from 1 unit of ", cycle[1,1], ", performing these transactions\n(or, in stock terms, SELLING or BIDDING these PAIRS) can\npossibly grant you back", ret$profit, " ", cycle[1,1], ":\n"), out.summary)
    write.table(cycle, out.summary, row.names=F, col.names=F, sep="/", quote=F, append=T)

    # Final messages
    cat("\n-> Graph nodes written to", out.nodes, "\n")
    cat("-> Negative cycle edges written to", out.cycle, "\n")
    cat("-> Execution summmary written to", out.summary, "\n\n")
}

# Reset warnings
options(warn=-1)


#=================================================================================================#
# utilities.r
# Generic utility methods
# Adam Erickson, PhD, Washington State University
# Contact: adam.michael.erickson@gmail.com
# March 14, 2019
# License: Apache 2.0
#
# Copyright 2019 Washington State University
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#=================================================================================================#

#' Estimate empirical PDF and sample from CDF; bw = SD of density kernel; value range = 0:1.
#' @param x Numeric vector of empirical values.
#' @param n Numeric number of samples to draw.
#' @param from Numeric minimum sample value.
#' @param to Numeric maximum sample value.
#' @param bw Numeric smoothing bandwidth or standard deviation for Gaussian kernel.
#' @return Numeric vector.
sample_empirical_cdf = function(x, n, from=0, to=1, bw=0.1, ...) {
  x = x[!is.na(x) & is.finite(x)]
  if (length(x) < 1) { return(NA) }
  x_pdf = stats::density(x=x, kernel="gaussian", from=from, to=to, bw=bw, n=512)
  return(stats::approx(cumsum(x_pdf$y)/sum(x_pdf$y), x_pdf$x, stats::runif(n=n))$y)
}

#' Helper function to calculate mean from arbitrary inputs.
#' @param ... Numeric vector or multiple numeric arguments.
#' @return Numeric value.
mean0 = function(...) {
  x = as.numeric(unlist(list(...)))
  return(sum(x, na.rm=TRUE) / length(x))
}

#' Coefficient of determination (R2) helper method.
#' @note Different methods of calculating R2 produce slightly different results.
#' @note Similar to Nash-Sutcliffe efficiency coefficient in the general case.
#' @param x Numeric observation values.
#' @param y Numeric prediction values.
#' @return Numeric value.
r_squared = function(x, y) {
  if (length(x) != length(y)) { stop("Lengths of y and y_hat differ") }
  #return(1 - sum((x-y)^2) / sum((x-mean(x))^2))
  #return(cov(x, y, method="pearson") / (sd(x) * sd(y)))
  return(cor(x, y, method="pearson")^2)
}

#' Nash-Sutcliffe efficiency coefficient (NSE) helper method.
#' @note Implementation based on R2 in Nash and Sutcliffe (1970) River flow forecasting through conceptual models.
#' @note This metric is "analogous to the coefficent of determination."
#' @param x Numeric observation values.
#' @param y Numeric prediction values.
#' @return Numeric value.
nse = function(x, y) {
  if (length(x) != length(y)) { stop("Lengths of y and y_hat differ") }
  return((sum((x-mean(x))^2) - sum((x-y)^2)) / sum((x-mean(x))^2))
}

#' Root mean squared error (RMSE) helper method.
#' @param x Numeric observation values.
#' @param y Numeric prediction values.
#' @return Numeric value.
rmse = function(x, y) {
  if (length(x) != length(y)) { stop("Lengths of y and y_hat differ") }
  return(sqrt(sum((y-x)^2) / length(x)))
}

#' Mean absolute error (MAE) helper method.
#' @param x Numeric observation values.
#' @param y Numeric prediction values.
#' @return Numeric value.
mae = function(x, y) {
  if (length(x) != length(y)) { stop("Lengths of y and y_hat differ") }
  return(mean(abs(y-x)))
}

#' Mean error (ME) helper method.
#' @note Equivalent to bias.
#' @param x Numeric observation values.
#' @param y Numeric prediction values.
#' @return Numeric value.
me = function(x, y) {
  if (length(x) != length(y)) { stop("Lengths of y and y_hat differ") }
  return(mean(y-x))
}

#' Helper method for listing files.
#' @note List files in folder with extension matching pattern
#' @param folder Character folder path containing files.
#' @param filnames Character vector of filenames to search.
#' @param extension Character file extension to search.
#' @return Character vector of files matching pattern.
get_files = function(path, filenames, extension, ...) {
  pattern = paste0("^(", paste(filenames, collapse="|"), ").*?", ".", extension, "$")
  return(list.files(path=path, pattern=pattern, full.names=TRUE))
}

#' Helper method for moving multiple files.
#' @param files Character vector of file paths
#' @param to Character directory target
#' @param recursive Boolean recursive switch
#' @param overwrite Boolean overwrite switch
#' @return 0
files_move = function(files, to, recursive=TRUE, overwrite=TRUE) {
  if (!dir.exists(file.path(to))) { dir.create(path=file.path(to), recursive=recursive) }
  file.copy(from=files, to=file.path(to), recursive=recursive, overwrite=overwrite, copy.mode=TRUE)
  file.remove(files)
  return(invisible(0))
}

#' Helper method for moving directories.
#' @param from Character directory origin
#' @param to Character directory target
#' @param recursive Boolean recursive switch
#' @param overwrite Boolean overwrite switch
#' @return 0
dir_move = function(from, to, recursive=TRUE, overwrite=TRUE) {
  if (!dir.exists(paths=file.path(to))) { dir.create(path=file.path(to), recursive=recursive) }
  files = list.files(from, full.names=TRUE, recursive=FALSE)
  file.copy(from=files, to=file.path(to), recursive=recursive, overwrite=overwrite, copy.mode=TRUE)
  unlink(file.path(from), recursive=recursive)
  return(invisible(0))
}

#' Helper method for downloading files
#' @note Download observation data and add to list
#' @param url Character url to a file.
#' @param destination Character path to save downloaded file.
download_file = function(url, destination) {
  curl::curl_download(url=url, destfile=destination, quiet=FALSE, mode="w")
  message(paste("Download successful:", destination))
  return(invisible(0))
}

#' Helper method to interpolate points to raster
#' @param x Numeric x,y coordinates or n-dimensional vector of predictor variables.
#' @param y Numeric 1-d vector for target variable.
#' @param xi Numeric x,y coordinates or n-dimensional data.frame() for imputing values.
#' @param method Character method selection.
#' @param fun Function for caret trainControl or RandomFields model.
#' @param multicore Boolean flag for multicore computation using OpenMP.
#' @param spatial Boolean flag for whether xi contains x,y coordinates.
#' @param proj4string Character Proj4 projection string for raster image.
#' @param plot Boolean flag for plotting results.
#' @examples
#' Classification
#' data(iris)
#' intrain = caret::createDataPartition(iris$Species, p=0.7, list=FALSE)
#' train   = iris[ intrain,]
#' test    = iris[-intrain,]
#' x       = train[,1:4]
#' y       = train[,5]
#' xi      = test[,1:4]
#' yi      = test[,5]
#' p = interpolate_points(x=x, y=y, xi=xi, method="knn", multicore=FALSE, spatial=FALSE, plot=TRUE)
#' sum(p == yi) / length(p)
#' p = interpolate_points(x=x, y=y, xi=xi, method="xgbTree", multicore=TRUE, spatial=FALSE, plot=TRUE)
#' sum(p == yi) / length(p)
#' Spatial regression
#' x  = cbind(x=runif(100, 1, 100), y=runif(100, 1, 100))
#' y  = rowSums(xy)
#' xi = expand.grid(x=seq(1, 100, length.out=100), y=seq(1, 100, length.out=100))
#' p = interpolate_points(x=x, y=y, xi=xi, method="knn", fun=NA, multicore=FALSE, spatial=TRUE,
#'                        proj4string="+proj=longlat +ellps=WGS84 +datum=WGS84", plot=TRUE)
#' or
#' p = interpolate_points(x=x, y=y, xi=xi, method="rf", fun=NA, multicore=TRUE, spatial=TRUE,
#'                        proj4string="+proj=longlat +ellps=WGS84 +datum=WGS84", plot=TRUE)
#' Kriging
#' xi  = data.frame(x=seq(1, 100, length.out=100), y=seq(1, 100, length.out=100))
#' fun = RandomFields::RMexp() + RandomFields::RMtrend(mean=NA)
#' fun = ~1 + RandomFields::RMwhittle(scale=NA, var=NA, nu=NA) + RandomFields::RMnugget(var=NA)
#' p = interpolate_points(x=x, y=y, xi=xi, method="kriging", fun=fun, multicore=FALSE, spatial=TRUE,
#'                        proj4string="+proj=longlat +ellps=WGS84 +datum=WGS84", plot=TRUE)
interpolate_points = function(x, y, xi=NA, method="knn", fun=NA, multicore=FALSE, spatial=TRUE,
                              proj4string="+proj=longlat +ellps=WGS84 +datum=WGS84", plot=FALSE, ...) {
  if (method != "kriging") {
    if (multicore == TRUE) { doMC::registerDoMC(cores=parallel::detectCores()-1) }
    if (!is.na(fun)) {
      ctl = fun
    } else {
      ctl  = caret::trainControl(method="repeatedcv", number=3, repeats=3, search="grid")
    }
    mod  = caret::train(x, y, method=method, trControl=ctl, preProcess=c("center","scale"), tuneLength=10)
    yhat = predict(mod, newdata=xi)
    if (spatial == TRUE) {
      coords = colnames(x) %in% c("x","y","lat","lon","latitude","longitude")
      proj4crs = sp::CRS(proj4string)
      yhat = sp::SpatialPixelsDataFrame(points=sp::SpatialPoints(xi[,coords]), data=data.frame(y=yhat),
                                        proj4string=proj4crs)
    }
  } else if (method == "kriging" & spatial == TRUE) {
    if (length(unique(round(diff(xi[,1]),6))) > 2 | length(unique(round(diff(xi[,2]),6))) > 2) {
      stop("Please enter an evenly spaced grid for xi parameter")
    }
    if (any(duplicated(xi[,1]) | duplicated(xi[,2]))) {
      warning("Parameter xi appears to be a grid, creating list of unique coordinates", immediate.=TRUE)
      xi = data.frame(x=min(xi[,1]):max(xi[,1]), y=min(xi[,2]):max(xi[,2]))
    }
    proj4crs = sp::CRS(proj4string)
    coords = colnames(x) %in% c("x","y","lat","lon","latitude","longitude")
    spdf = sp::SpatialPointsDataFrame(coords=x[,coords], data=data.frame(y=y), proj4string=proj4crs)
    fit  = RandomFields::RFfit(fun, data=spdf)
    yhat = RandomFields::RFinterpolate(fit, x=xi[,coords], grid=TRUE, data=spdf)
  } else {
    stop("Parameters incorrectly specified")
  }
  if (spatial == TRUE) {
    yhat = raster::raster(yhat)
    if (plot == TRUE) { raster::plot(yhat, col=viridis::magma(256)) }
  }
  return(yhat)
}

#' Helper method to generate raster image
#' @note Used to generate random maps, point value maps, or matrix maps.
#' @note A RandomFields model can also be passed to generator.
#' @param values Numeric matrix, single value, "random", or "scrf" for spatially correlated random fields.
#' @param path Character file path for saving the result.
#' @param format Character raster file format.
#' @param params Optional numeric vector of parameters to pass to distribution function.
#' @param generator Optional statistical generator for drawing random values. Default is runif().
#' @param size Optional numeric vector of length 2 for the n*n size of the map.
#' @param extent Optional numeric vector of length 4 for the image bounds.
#' @param crs Optional character vector proj4-compatible coordinate reference system.
#' @examples
#' f  = "/Users/julia/rasters"
#' g = RandomFields::RMexp(var=3, scale=5) + RandomFields::RMnugget(var=3)
#' r = generate_raster("randomfield", size=c(100,100), generator=g, filename=f)
generate_raster = function(values="random", size=c(10,10), bounds=c(-1,1,-1,1), generator=runif,
                           params=c(prod(size)), filename=NA, format="GTiff",
                           proj4string="+proj=longlat +ellps=WGS84 +datum=WGS84", plot=TRUE, ...) {
  if (values != "random" & class(values) == "numeric" & class(values) != "matrix") {
    if (length(values) != prod(size)) { stop("Number of values must equal the product of size") }
    values = matrix(values, nrow=size[1], ncol=size[2])
  } else if (values == "random" & class(generator) == "function") {
    values = do.call(generator, as.list(params))
    values = matrix(values, nrow=size[1], ncol=size[2])
  } else if (values == "randomfields" & class(generator)[1] == "RMmodel") {
    x = 1:size[1]
    y = 1:size[2]
    values = RandomFields::RFsimulate(generator, x, y, grid=TRUE)
  } else {
    stop("Parameters incorrectly specified")
  }
  ri = raster::raster(values)
  raster::extent(ri) = bounds
  raster::projection(ri) = raster::crs(proj4string)
  if (!is.na(filename) == TRUE) { raster::writeRaster(ri, filename=filename, format=format) }
  if (plot == TRUE) { raster::plot(ri, col=viridis::magma(256)) }
  return(ri)
}


###########################################################
## An intro to time series forecasting with ARIMA        ##
## R Ladies London 24 October 2019 workshop              ##
## Sample code by julia.shen1@lshtm.ac.uk                ##
###########################################################

### 0.  Load required packages + data and set filepath  ###

# install.packages(c('tidyverse', 'forecast', 'here'))

library(tidyverse)
library(forecast)
library(here)

# set_here() # sets filepath to folder currently containing this script

data_orig <- read.csv(here::here('ARIMA-intro.csv')) # load example data

### 1. Clean up date formats for an analysis file   ###

str(data_orig) # examine data structure
levels(data_orig$�..month) # note "�..month" imported as an icky factor var

# specify a new date variable with day-month-year to replace the disaggregated factor vars
# nb NHS sitrep data from last Thursday of each month, so pick arbitrary consistent date 24
# nb Green et al (2017) analysis is based on 2010/08 to 2015/03, as reflected in plots etc

data_use <- data_orig %>%
  mutate(�..month=as.character(�..month)) %>%  # change factor var to a string
  mutate(date=paste0('24', �..month, year, sep = "", collapse = NULL)) %>% #combine strings
  mutate(date=as.Date(date, "%d%B%Y")) # convert string to date

# str(data_use) # check this worked and some cleanup below

data_use <- data_use %>%
  select(-�..month, -year)

rm(data_orig)

### 2. Create some analysis variables and look at summary descriptives   ###

data_use <- data_use %>%
  mutate(annual_mort = out_deaths_total * 1000 / ONS_pop_est,
         dtoc_days_rate = exp_days_dtoc * 1000 / ONS_pop_est,
         dtoc_pts_rate = exp_patients_dtoc * 100000 / ONS_pop_est,
         dtoc_days_percapita = exp_days_dtoc / exp_patients_dtoc,
         prop_acute_days = exp_days_acute / exp_days_dtoc,
         prop_acute_patients = exp_patients_acute / exp_patients_dtoc)

summary(data_use) # note data descriptives, and also the NAs. What data are missing?

# data_use <- data_use %>%
#   filter(!is.na(ONS_pop_est)) # if you want to drop 8 missing obs in 2019

### 3. Explore descriptive plots  ###

# Examine trends in absolute COUNTS over time for the exposures and outcome of interest
# for DAYS of delayed transfers of care vs. deaths
ggplot(data=data_use, aes(x=date)) +
  ggtitle("Trends in English mortality and NHS DAYS delayed") +
    geom_line(aes(y=out_deaths_total), color="darkred") +
  geom_line(aes(y=exp_days_dtoc), color="black") +
  geom_line(aes(y=exp_days_acute), color="black", linetype="longdash") +
  geom_line(aes(y=exp_days_nonacute), color="black", linetype="dotted") +
  xlab("Time") + ylab("Total counts of deaths and dtoc days") +
  geom_vline(aes(xintercept = as.numeric(as.Date("2015/03/24"))), color="darkgreen")

# for PATIENTS with dtocs vs. deaths
ggplot(data=data_use, aes(x=date)) +
  ggtitle("Trends in English mortality and NHS PATIENTS delayed") +
  geom_line(aes(y=out_deaths_total), color="darkred") + # nb could rescale deaths here for viz
  geom_line(aes(y=exp_patients_dtoc), color="blue") +
  geom_line(aes(y=exp_patients_acute), color="blue", linetype="longdash") +
  geom_line(aes(y=exp_patients_nonacute), color="blue", linetype="dotted") +
  xlab("Time") + ylab("Total counts of deaths and dtoc patients") +
  geom_vline(aes(xintercept = as.numeric(as.Date("2015/03/24"))), color="darkgreen")

# Examine seasonal "trends" in per capita days hospitalised (days of delay per patient delayed)
ggplot(data=data_use, aes(x=date)) +
  geom_line(aes(y=dtoc_days_percapita), color="darkblue", linetype="dotdash") +
  xlab("Time") + ylab("Mean days of delay per hospitalised patient") +
  scale_x_date(minor_breaks=seq(as.Date("2010/08/24"), as.Date("2019/08/24"), by="months"),
               breaks=seq(as.Date("2010/08/24"), as.Date("2019/08/24"), by="quarter")) +
  geom_vline(aes(xintercept = as.numeric(as.Date("2015/03/24"))), color="darkgreen") +
  theme(axis.text.x = element_blank())
#... After inspecting this as well as the table, perhaps find that values are suspiciously round
#... Note nevertheless global dips during end-of-year (holidays)

# Examine the created analysis vars to assess summary change in RISK over time
# The below is constant for population growth and thus (crudely) factors in demographics
ggplot(data=data_use, aes(x=date, y=c(annual_mort, dtoc_days_rate, dtoc_pts_rate))) +
  ggtitle("Trend in English risk RATES") +
  geom_line(aes(y=annual_mort), color="darkred", linetype="dotdash") +
  geom_line(aes(y=dtoc_days_rate), color="black", linetype="dotdash") +
    xlab("Time") + ylab("Mortality (red) and DTOC days (black) per 1000 pop.") +
  geom_vline(aes(xintercept = as.numeric(as.Date("2015/03/24"))), color="darkgreen")

ggplot(data=data_use, aes(x=date, y=c(annual_mort, dtoc_days_rate, dtoc_pts_rate))) +
  ggtitle("Trend in English RISK RATES") +
  geom_line(aes(y=annual_mort*10), color="darkred", linetype="dotdash") + #nb scale factor for viz
  geom_line(aes(y=dtoc_pts_rate), color="blue", linetype="dotdash") +
  xlab("Time") + ylab("Mortality (red) per 10000 pop. and DTOC patients (blue) per 100000 pop.") +
  geom_vline(aes(xintercept = as.numeric(as.Date("2015/03/24"))), color="darkgreen")

### 4. Create time series objects and examine potential seasonality in plots  ###

# Cut a version of the dataset from Green et al paper, to test replication
data_green <- data_use %>%
  filter(date<"2016-04-24")

# Create some time series objects
#... Specify a monthly time series for DTOC days and deaths, starting from August 2010
ts_dtocdays_all <- ts(data_use$exp_days_dtoc, frequency=12, start=c(2010, 8))
ts_deaths_all <- ts(data_use$out_deaths_total, frequency=12, start=c(2010, 8))
#... Do the same for the retrospective Green 'training' data
ts_dtocdays_green <- ts(data_green$exp_days_dtoc, frequency=12, start=c(2010, 8))
ts_deaths_green <- ts(data_green$out_deaths_total, frequency=12, start=c(2010, 8))

# In principle, one can use tsclean() to identify & smooth outliers but this doesn't apply here
# tsclean(ts_dtocdays_all)

# Generate MOVING AVERAGES for any time series and see how this smooths trends
#... for deaths as outcome of interest
data_use$deaths_ma_q = ma(data_use$out_deaths_total, order=4)
data_use$deaths_ma_y = ma(data_use$out_deaths_total, order=12)

ggplot(data=data_use, aes(x=date)) +
  ggtitle("Deaths in England, monthly snapshot vs quarterly and annual moving average") +
  geom_line(aes(y=out_deaths_total), color="darkred") +
  geom_line(aes(y=deaths_ma_q), color="darkred", linetype="longdash") +
  geom_line(aes(y=deaths_ma_y), color="darkred", linetype="twodash") +
  xlab("Time") + ylab("Deaths") +
  geom_vline(aes(xintercept = as.numeric(as.Date("2015/03/24"))), color="darkgreen")

#... for DTOC days as exposure
data_use$dtoc_days_ma_q = ma(data_use$exp_days_dtoc, order=4)
data_use$dtoc_days_ma_y = ma(data_use$exp_days_dtoc, order=12)

ggplot(data=data_use, aes(x=date)) +
  ggtitle("NHS DAYS delayed, monthly snapshot vs quarterly and annual moving average") +
  geom_line(aes(y=exp_days_dtoc), color="black") +
  geom_line(aes(y=dtoc_days_ma_q), color="black", linetype="longdash") +
  geom_line(aes(y=dtoc_days_ma_y), color="black", linetype="twodash") +
  xlab("Time") + ylab("DTOC days") +
  geom_vline(aes(xintercept = as.numeric(as.Date("2015/03/24"))), color="darkgreen")

# Seasonal plots also help to assess trend
ggseasonplot(ts_deaths_all, year.labels=TRUE, year.labels.left=TRUE) +
  ylab("Count of deaths") + ggtitle("Seasonal plot: deaths in England")

ggseasonplot(ts_dtocdays_all, year.labels=TRUE, year.labels.left=TRUE) +
  ylab("Count of days delayed in transfers of care") + ggtitle("Seasonal plot: days of DTOCs in England")

# A nice alternative view of the above data
ggseasonplot(ts_deaths_all, polar=TRUE) +
  ylab("Count of deaths") + ggtitle("Polar seasonal plot: deaths in England")

ggseasonplot(ts_dtocdays_all, polar=TRUE) +
  ylab("Count of days delayed in transfers of care") + ggtitle("Polar seasonal plot: days of DTOCs in England")

# optionally, explore...
# ts_dtoc_days_acute <- ts(data_use$exp_days_acute, frequency=12, start=c(2010, 8))
# ts_dtoc_patients <- ts(data_use$exp_patients_dtoc, frequency=12, start=c(2010, 8))
# ts_dtoc_patients_acute <- ts(data_use$exp_patients_acute, frequency=12, start=c(2010, 8))

### 5. Decompose the exposure and outcome time series of interest  ###

# Decompose the death outcome of interest
#... Method 1a using decompose with additive model
decomp_deaths_add <-
  decompose(ts_deaths_all, type="additive")
plot(decomp_deaths_add)

#... Method 1b using decompose with multiplicative model
decomp_deaths_mult <-
  decompose(ts_deaths_all, type="multiplicative")
plot(decomp_deaths_mult)

#... Alternative method 2 using stl()
stl_deaths <-
  stl(ts_deaths_all, s.window="periodic")
autoplot(stl_deaths)

# Decompose the days of DTOC exposure
decomp_dtocdays_all <-
  decompose(ts_dtocdays_all, type="additive")
plot(decomp_dtocdays_all)

### 6. Evaluate stationarity of the time series  ###

# Looking at the raw data (0 differences), the ACF/PACF plots and stats test show clear problems
Acf(ts_deaths_all, lag.max = NULL, type = c("correlation", "covariance",
                                "partial"), plot = TRUE, na.action = na.contiguous, demean = TRUE)
Pacf(ts_deaths_all, lag.max = NULL, plot = TRUE, na.action = na.contiguous, demean = TRUE)
ts_deaths_all %>% ggtsdisplay() # summary view across data, Acf, and Pacf
Box.test(diff(ts_deaths_all), lag=12, type="Ljung-Box")

# For NONSEASONAL data, ndiffs() can be used to evaluate usefulness of differencing
# ndiffs(ts_deaths_all, alpha = 0.05, test = c("kpss", "adf", "pp"),
#        type = c("level", "trend"), max.d = 2)

# Here, let's take a seasonal (monthly) difference to try to get to more stationary data
ts_deaths_all %>% diff(lag=12) %>% ggtsdisplay() # set a lag of 12 to reflect monthly seasonality
ts_deaths_all %>% diff(lag=12) %>% diff() %>% ggtsdisplay() # differencing=2 doesn't seem to change much

### 7. Fit ARIMA models using auto.arima including some forward forecasts  ###

# Univariate time series models from machine-automated selection
fit_deaths_all <- ts_deaths_all %>%
  auto.arima()
fit_deaths_all

fit_deaths_all %>% forecast(h=12) %>%  autoplot()

fit_deaths_green <- ts_deaths_green %>%
  auto.arima()
fit_deaths_green

fit_deaths_green %>% forecast(h=12) %>%  autoplot()

### 8. Check fit and predictiveness, refining as needed  ###

# What about residuals of the univariate ARIMA models?
checkresiduals(fit_deaths_all)
checkresiduals(fit_deaths_green)

refit_deaths_all <- ts_deaths_all %>%
  auto.arima(approximation=FALSE)
refit_deaths_all # we see that approximation in the algo isn't the root issue

refit_deaths_green <- ts_deaths_green %>%
  auto.arima(approximation=FALSE)
refit_deaths_green # ditto for Green et al's analysis

autoplot(refit_deaths_all)
autoplot(refit_deaths_green)
# Maybe we decide to live with the fit as-is, unless we have other data on cause of difference?

### 9. Extend to regression between different time-series  ###

# Specify the acute days time-series, as found by Green et al
ts_acutedays_all <- ts(data_use$exp_days_acute, frequency=12, start=c(2010, 8))
ts_acutedays_green <- ts(data_green$exp_days_acute, frequency=12, start=c(2010, 8))

# Regress the two time-series
regress_green_auto <- auto.arima(ts_deaths_green, xreg=ts_acutedays_green, allowdrift=TRUE)
regress_green_auto

# Alternatively one could manually specify as below based on the best-fit UNIVARIATE model
regress_green_manual <- Arima(ts_deaths_green, xreg=ts_acutedays_green,
                       order=c(0,0,0), seasonal=c(1,1,0),
                       include.drift=TRUE)
regress_green_manual # these estimates still differ from the JECH article

# What happens when we include 41 more months of data?
regress_all_auto <- auto.arima(ts_deaths_all, xreg=ts_acutedays_all, allowdrift=TRUE)
regress_all_auto

# Check that the automatic ARIMA regression residuals look like white noise/random walk (2nd plot)
cbind("Regression Errors" = residuals(regress_all_auto, type="regression"),
      "ARIMA errors" = residuals(regress_all_auto, type="innovation")) %>%
  autoplot(facets=TRUE)

# What do forecasts look like if DTOCs are unchanged in future?
regress_all_auto %>% forecast(xreg = ts_acutedays_all, h=12) %>%  autoplot()


  bathymetry_db = function( p=NULL, DS=NULL, varnames=NULL, redo=FALSE, ... ) {

    #\\ Note inverted convention: depths are positive valued
    #\\ i.e., negative valued for above sea level and positive valued for below sea level
    if ( is.null(p))  {
      p_add = list(...)
      if (length(p_add) > 0 ) {
        p = bathymetry_parameters(...)
      } else {
        p = bathymetry_parameters()
      }
    }

    if ( DS=="gebco") {
      #library(RNetCDF)
      # request at: https://www.bodc.ac.uk/data/online_delivery/gebco/ [ jae.choi@dfo ] ... / gate.gate
      # extent: (WSEN) = -+72,36,-45.,53
      # and saved as: bio.data/bathymetry/data/gebco.{xyz,nc}  # still waiting
      # and xz compressed
      fn = file.path( p$datadir, "bathymetry.gebco.rdata" )
      if (file.exists (fn) ) {
        load(fn)
        return(gebco)
      }

      fn_local = file.path( p$datadir, "gebco.xyz.xz") # xz compressed file
      nc = open.nc(bathy_fname)
      read.nc(nc)
      array(tmp$z, dim=tmp$dim)
      gebco = read.table( xzfile( fn_local ) )
      names(gebco) = c("lon", "lat", "z")
      gebco$z = - gebco$z
      # levelplot( log(z+ min(gebco$z) ))~lon+lat, gebco, aspect="iso")
      save( gebco, file=fn, compress=TRUE )
    }

    # --------------

    if ( DS=="etopo1") {
      # etopo1_bedrock.xyz ---> 1 min resolution
      # extent: (WSEN) = -72,36,-45.,53
      # download manually from:  http://maps.ngdc.noaa.gov/viewers/wcs-client/
      # and saved as: bio.data/bathymetry/data/etopo1_bedrock.xyz
      # and xz compressed
      fn = file.path( p$datadir, "bathymetry.etopo1.rdata" )
      if (file.exists (fn) ) {
        load(fn)
        return(etopo1)
      }
      fn_local = file.path( p$datadir, "etopo1_bedrock.xyz.xz") # xz compressed file
      etopo1 = read.table( xzfile( fn_local ) )
      names(etopo1) = c("lon", "lat", "z")
      etopo1$z = - etopo1$z
      # levelplot( log(z+ min(etopo1$z) ))~lon+lat, etopo1, aspect="iso")
      save( etopo1, file=fn, compress=TRUE )
    }

    # --------------

    if ( DS =="Greenlaw_DEM") {
      # DEM created 2014
      # GCS_WGS_1984, UTM_Zone_20N; spheroid:: 6378137.0, 298.257223563
      # 322624071 "grid points
      # 50 m  horizontal resolution
      # depth range: -5053.6 to 71.48 m
      fn = file.path( p$datadir, "bathymetry.greenlaw.rdata" )
      if (file.exists (fn) ) {
        load(fn)
        return(gdem)
      }

      require(rgdal)
      demfile.adf = file.path( p$datadir, "greenlaw_DEM", "mdem_50", "w001001.adf" )  # in ArcInfo adf format
      dem = new( "GDALReadOnlyDataset", demfile.adf )
      # gdem = asSGDF_GROD( dem, output.dim=dim(dem) ) # regrid to another dim
      # gdem = getRasterData(dem) # in matrix format
      gdem = getRasterTable(dem) # as a data frame
      names(gdem) = c("plon", "plat", "z")
      gdem = gdem[ is.finite( gdem$z ) , ]
      gdem$plon = gdem$plon / 1000
      gdem$plat = gdem$plat / 1000
      gdem = planar2lonlat( gdem, "utm20" )  # plon,plat in meters but crs for utm20 in km
      gdem = gdem[, c("lon", "lat", "z") ]
      save( gdem, file=file.path( p$datadir, "bathymetry.greenlaw.rdata"), compress=TRUE )
    }

    # --------------

    if (  DS %in% c("z.lonlat.rawdata.redo", "z.lonlat.rawdata") ) {
			# raw data minimally modified all concatenated, dups removed
      fn = file.path( p$datadir, "bathymetry.canada.east.lonlat.rawdata.rdata" )

      if (DS =="z.lonlat.rawdata" ) {
        load( fn )
        return( bathy )
      }

      print( "This is going to take a lot of RAM!")

			# this data was obtained from CHS via David Greenberg in 2004; range = -5467.020, 383.153; n=28,142,338
      fn_nwa = file.path( p$datadir, "nwa.chs15sec.xyz.xz") # xz compressed file
      chs15 = read.table( xzfile( fn_nwa ) )
      names(chs15) = c("lon", "lat", "z")
      # chs15 = chs15[ which( chs15$z < 1000 ) , ]
      chs15$z = - chs15$z

      # temporary break up of data to make it functional in smaller RAM systems
      chs1000_5000 = chs15[ which( chs15$z > 1000 ), ]
      u =  which(duplicated( chs1000_5000))
      if (length(u)>0) chs1000_5000 = chs1000_5000[-u,]

      chs0_1000 = chs15[ which( chs15$z <= 1000 ), ]
      u =  which(duplicated( chs0_1000 ))
      if (length(u)>0) chs0_1000 = chs0_1000[-u,]

      rm ( chs15); gc()

      fn0 = file.path( p$datadir, "bathymetry.canada.east.lonlat.rawdata.temporary_0_1000.rdata" )
      fn1 = file.path( p$datadir, "bathymetry.canada.east.lonlat.rawdata.temporary_1000_5000.rdata" )

      save ( chs0_1000, file=fn0 )
      save ( chs1000_5000, file=fn1 )

      rm ( chs0_1000, chs1000_5000 )
      gc()

      # pei = which( chs15$lon < -60.5 & chs15$lon > -64.5 & chs15$lat>45.5 & chs15$lat<48.5 )
      # levelplot( z~lon+lat, data=chs15[pei,] )

      # Michelle Greenlaw's DEM from 2014
      # range -3000 to 71.5 m; n=155,241,029 .. but mostly interpolated
      gdem = bathymetry_db( DS="Greenlaw_DEM" )
      gdem$z = - gdem$z

      # pei = which( gdem$lon < -60.5 & gdem$lon > -65 & gdem$lat>45.5 & gdem$lat<49 )
      # levelplot( z~I(round(lon,3))+I(round(lat,3)), data=gdem[pei,] )

      # bad boundaries in Greenlaw's gdem:
      # southern Gulf of St lawrence has edge effects
      bd1 = rbind( c( -62, 46.5 ),
                   c( -61, 47.5 ),
                   c( -65, 47.5 ),
                   c( -65, 46.2 ),
                   c( -64, 46.2 ),
                   c( -62, 46.5 ) )

      a = which( point.in.polygon( gdem$lon, gdem$lat, bd1[,1], bd1[,2] ) != 0 )
      gdem = gdem[- a,]

      # remove also the northern and eastern margins for edge effects
      gdem = gdem[ which( gdem$lat <  47.1) ,]
      gdem = gdem[ which( gdem$lon < -56.5) ,]

      fn0g = file.path( p$datadir, "bathymetry.canada.east.lonlat.rawdata.temporary_0_1000_gdem.rdata" )
      fn1g = file.path( p$datadir, "bathymetry.canada.east.lonlat.rawdata.temporary_1000_5000_gdem.rdata" )

      # temporary break up of data to make it functional in smaller RAM systems
      gdem1000_5000 = gdem[ which( gdem$z > 1000 ), ]
      # u =  which(duplicated( gdem1000_5000))
      # if (length(u)>0) gdem1000_5000 = gdem1000_5000[-u,]
      save ( gdem1000_5000, file=fn1g )
      rm( gdem1000_5000 ); gc()

      gdem0_1000 = gdem[ which( gdem$z <= 1000 ), ]
      # u =  which(duplicated( gdem0_1000 ))
      # if (length(u)>0) gdem0_1000 = gdem0_1000[-u,]
      save ( gdem0_1000, file=fn0g )
      rm( gdem0_1000 )
      rm( gdem)
      gc()

      # chs and others above use chs depth convention: "-" is below sea level,
			# in snowcrab and groundfish convention "-" is above sea level
			# retain postive values at this stage to help contouring near coastlines

      bathy = bathymetry_db( DS="etopo1" )

      additional.data=c("snowcrab", "groundfish", "lobster")

			if ( "snowcrab" %in% additional.data ) {
        # range from 23.8 to 408 m below sea level ... these have dropped the "-" for below sea level; n=5925 (in 2014)
        # project.library( "bio.snowcrab")
        sc = bio.snowcrab::snowcrab.db( DS="set.clean")[,c("lon", "lat", "z") ]
				sc = sc [ which (is.finite( rowSums( sc ) ) ) ,]
				j = which(duplicated(sc))
        if (length (j) > 0 ) sc = sc[-j,]
        bathy = rbind( bathy, sc )
			  # p = p0
        rm (sc); gc()

        #sc$lon = round(sc$lon,1)
        #sc$lat = round(sc$lat,1)
        # contourplot( z~lon+lat, sc, cuts=10, labels=F )
      }

      if ( "groundfish" %in% additional.data ) {
        # n=13031; range = 0 to 1054

        warning( "Should use bottom contact estimates as a priority ?" )
				gf = groundfish_survey_db( DS="set.base" )[, c("lon","lat", "sdepth") ]
				gf = gf[ which( is.finite(rowSums(gf) ) ) ,]
        names(gf) = c("lon", "lat", "z")
				j = which(duplicated(gf))
        if (length (j) > 0 ) gf = gf[-j,]
 				bathy = rbind( bathy, gf )
        rm (gf); gc()

        #gf$lon = round(gf$lon,1)
        #gf$lat = round(gf$lat,1)
        #contourplot( z~lon+lat, gf, cuts=10, labels=F )

			}

      if ( "lobster" %in% additional.data ) {
        current.year = lubridate::year(lubridate::now())
        p0temp = aegis.temperature::temperature_parameters( yrs=1900:current.year )
        lob = temperature_db( p=p0temp, DS="lobster", yr=1900:current.year ) # FSRS data ...  new additions have to be made at the rawdata level manually; yr must be passed to retrieve data ..
        lob = lob[, c("lon","lat", "z") ]
        lob = lob[ which( is.finite(rowSums(lob) ) ) ,]
        j = which(duplicated(lob))
        if (length (j) > 0 ) lob = lob[-j,]
        bathy = rbind( bathy, lob )
        rm (lob); gc()

        #lob$lon = round(lob$lon,1)
        #lob$lat = round(lob$lat,1)
        #contourplot( z~lon+lat, lob, cuts=10, labels=F )

      }

      u =  which(duplicated( bathy ))
      if (length(u)>0) bathy = bathy[ -u, ]
      rm (u)

      bathy0 = bathy[ which(bathy$z <= 1000), ]
      bathy1 = bathy[ which(bathy$z  > 1000), ]
      rm(bathy)

      gc()

      load( fn0)
      bathy0 = rbind( bathy0, chs0_1000 )
      rm(chs0_1000) ;gc()

      load( fn0g )
      bathy0 = rbind( bathy0, gdem0_1000 )
      rm ( gdem0_1000 ) ;gc()

      u =  which(duplicated( bathy0 ))
      if (length(u)>0) bathy0 = bathy0[ -u, ]

      fn0b = file.path( p$datadir, "bathymetry.canada.east.lonlat.rawdata.temporary_0_1000_bathy.rdata" )
      save ( bathy0, file=fn0b )
      rm (bathy0); gc()

    # ---

      load( fn1 )
      bathy1 = rbind( bathy1, chs1000_5000 )
      rm (  chs1000_5000 ) ; gc()

      load( fn1g )
      bathy1 = rbind( bathy1, gdem1000_5000 )
      rm ( gdem1000_5000 ) ; gc()

      u =  which(duplicated( bathy1 ))
      if (length(u)>0) bathy1 = bathy1[ -u, ]
      rm (u)

      load( fn0b )

      bathy = rbind( bathy0, bathy1 )
      rm( bathy1, bathy0 ) ; gc()

      bid = paste( bathy$lon, bathy$lat, round(bathy$z, 1) ) # crude way to find dups
      bathy = bathy[!duplicated(bid),]
      save( bathy, file=fn, compress=T )

      # save ascii in case someone needs it ...
      fn.bathymetry.xyz = file.path( p$datadir, "bathymetry.canada.east.xyz" )
      fn.xz = xzfile( paste( fn.bathymetry.xyz, ".xz", sep="" ) )
      write.table( bathy, file=fn.xz, col.names=F, quote=F, row.names=F)
      system( paste( "xz",  fn.bathymetry.xyz ))  # compress for space

      if (file.exists (fn.bathymetry.xyz) ) file.remove(fn.bathymetry.xyz)
      if (file.exists (fn0) ) file.remove( fn0 )
      if (file.exists (fn1) ) file.remove( fn1 )
      if (file.exists (fn0g) ) file.remove( fn0g )
      if (file.exists (fn1g) ) file.remove( fn1g )
      if (file.exists (fn0b) ) file.remove( fn0b )

      return ( fn )
    }

    # ------------------------------

    if ( DS=="aggregated_data") {

      if (!exists("inputdata_spatial_discretization_planar_km", p) )  p$inputdata_spatial_discretization_planar_km = 1

      fn = file.path( p$datadir, paste( "bathymetry", "aggregated_data", p$spatial_domain,  round(p$inputdata_spatial_discretization_planar_km, 6) , "rdata", sep=".") )
      M = NULL
      if (!redo)  {
        if (file.exists(fn)) {
          message("Using: ", fn)
          load( fn)
          return( M )
        }
      }
      message("Making: ", fn)

      M = bathymetry_db ( p=p, DS="z.lonlat.rawdata" )  # 16 GB in RAM just to store!

      setDT(M)
      M = M[ which( M$lon > p$corners$lon[1] & M$lon < p$corners$lon[2]  & M$lat > p$corners$lat[1] & M$lat < p$corners$lat[2] ), ]
      M = lonlat2planar( M, proj.type=p$aegis_proj4string_planar_km)  # first ensure correct projection

      M$lon = NULL
      M$lat = NULL
      M$z = M[[p$variabletomodel]]

        # thin data a bit ... remove potential duplicates and robustify

      M$plon = aegis_floor(M$plon / p$inputdata_spatial_discretization_planar_km + 1 ) * p$inputdata_spatial_discretization_planar_km
      M$plat = aegis_floor(M$plat / p$inputdata_spatial_discretization_planar_km + 1 ) * p$inputdata_spatial_discretization_planar_km

      gc()

      M = M[ geo_subset( spatial_domain=p$spatial_domain, Z=M ) , ] # need to Pbe careful with extrapolation ...  filter depths

      if (exists("quantile_bounds", p)) {
        TR = quantile(M[[p$variabletomodel]], probs=p$quantile_bounds, na.rm=TRUE )
        keep = which( M[[p$variabletomodel]] >=  TR[1] & M[[p$variabletomodel]] <=  TR[2] )
        if (length(keep) > 0 ) M = M[ keep, ]
        keep = NULL
        gc()
      }

      setDT(M)
      M = M[, .( mean=mean(z, na.rm=TRUE), sd=sd(z, na.rm=TRUE), n=length(which(is.finite(z))) ), by=list(plon, plat) ]

      colnames(M) = c( "plon", "plat", paste( p$variabletomodel, c("mean", "sd", "n"), sep=".") )
      M = planar2lonlat( M, p$aegis_proj4string_planar_km )

      attr( M, "proj4string_planar" ) =  p$aegis_proj4string_planar_km
      attr( M, "proj4string_lonlat" ) =  projection_proj4string("lonlat_wgs84")
      setDF(M)
      save(M, file=fn, compress=TRUE)

      return( M )
    }

    # ------------------------------

    if ( DS=="areal_units_input" ) {

      fn = file.path( p$datadir,  "areal_units_input.rdata" )
      if ( !file.exists(p$datadir)) dir.create( p$datadir, recursive=TRUE, showWarnings=FALSE )

      xydata = NULL
      if (!redo)  {
        if (file.exists(fn)) {
          load( fn)
          return( xydata )
        }
      }
      xydata = bathymetry_db( p=p, DS="aggregated_data"   )  #
      names(xydata)[which(names(xydata)=="z.mean" )] = "z"
      xydata = xydata[ , c("lon", "lat"  )]

      save(xydata, file=fn, compress=TRUE )
      return( xydata )
    }

    # -----------------------

    if ( DS=="carstm_inputs") {

      # prediction surface
      #\\ Note inverted convention: depths are positive valued
      #\\ i.e., negative valued for above sea level and positive valued for below sea level
      crs_lonlat = st_crs(projection_proj4string("lonlat_wgs84"))
      sppoly = areal_units( p=p )  # will redo if not found
      sppoly = st_transform(sppoly, crs=crs_lonlat )
      areal_units_fn = attributes(sppoly)[["areal_units_fn"]]

      fn = carstm_filenames( p=p, returntype="carstm_inputs", areal_units_fn=areal_units_fn )
      if (p$carstm_inputs_prefilter =="rawdata") {
        fn = carstm_filenames( p=p, returntype="carstm_inputs_rawdata", areal_units_fn=areal_units_fn )
      }
      if (p$carstm_inputs_prefilter =="sampled") {
        fn = carstm_filenames( p=p, returntype=paste("carstm_inputs_sampled", p$carstm_inputs_prefilter_n, sep="_"), areal_units_fn=areal_units_fn )
      }

      # inputs are shared across various secneario using the same polys
      #.. store at the modeldir level as default
      outputdir = dirname( fn )
      if ( !file.exists(outputdir)) dir.create( outputdir, recursive=TRUE, showWarnings=FALSE )

      if (!redo)  {
        if (file.exists(fn)) {
          load( fn)
          return( M )
        }
      }

      # reduce size
      if (p$carstm_inputs_prefilter =="aggregated") {
        M = bathymetry_db ( p=p, DS="aggregated_data"   )  # 16 GB in RAM just to store!
        names(M)[which(names(M)==paste(p$variabletomodel, "mean", sep=".") )] = p$variabletomodel

      } else if (p$carstm_inputs_prefilter =="sampled") {
        M = bathymetry_db ( p=p, DS="z.lonlat.rawdata"  )  # 16 GB in RAM just to store!

        require(data.table)
        setDT(M)
        names(M)[which(names(M)=="z") ] = p$variabletomodel

        M = M[ which( !duplicated(M)), ]
        M = M[ which( M$lon > p$corners$lon[1] & M$lon < p$corners$lon[2]  & M$lat > p$corners$lat[1] & M$lat < p$corners$lat[2] ), ]
      # levelplot( eval(paste(p$variabletomodel, "mean", sep="."))~plon+plat, data=M, aspect="iso")

    # thin data a bit ... remove potential duplicates and robustify
        M = lonlat2planar( M, proj.type=p$aegis_proj4string_planar_km )  # first ensure correct projection
        setDT(M)

        M$plon = aegis_floor(M$plon / p$inputdata_spatial_discretization_planar_km + 1 ) * p$inputdata_spatial_discretization_planar_km
        M$plat = aegis_floor(M$plat / p$inputdata_spatial_discretization_planar_km + 1 ) * p$inputdata_spatial_discretization_planar_km

        M = M[,.SD[sample(.N, min(.N, p$carstm_inputs_prefilter_n))], by =list(plon, plat) ]  # compact, might be slightly slower
        # M = M[ M[, sample(.N, min(.N, p$carstm_inputs_prefilter_n) ), by=list(plon, plat)], .SD[i.V1], on=list(plon, plat), by=.EACHI]  # faster .. just a bit
        setDF(M)

      } else {

        M = bathymetry_db ( p=p, DS="z.lonlat.rawdata"  )  # 16 GB in RAM just to store!
        names(M)[which(names(M)=="z") ] = p$variabletomodel
        M = M[ which( !duplicated(M)), ]
        M = M[ which( M$lon > p$corners$lon[1] & M$lon < p$corners$lon[2]  & M$lat > p$corners$lat[1] & M$lat < p$corners$lat[2] ), ]
        # levelplot( eval(paste(p$variabletomodel, "mean", sep="."))~plon+plat, data=M, aspect="iso")

      }

      if (p$carstm_inputs_prefilter != "aggregated") {
        if (exists("quantile_bounds", p)) {
          TR = quantile(M[[p$variabletomodel]], probs=p$quantile_bounds, na.rm=TRUE )
          keep = which( M[[p$variabletomodel]] >=  TR[1] & M[[p$variabletomodel]] <=  TR[2] )
          if (length(keep) > 0 ) M = M[ keep, ]
          keep = NULL
          gc()
        }
      }

        # if (exists("quantile_bounds", p)) {
        #   TR = quantile(M[,p$variabletomodel], probs=p$quantile_bounds, na.rm=TRUE )
        #   keep = which( M[,p$variabletomodel] >=  TR[1] & M[,p$variabletomodel] <=  TR[2] )
        #   if (length(keep) > 0 ) M = M[ keep, ]
        # }

      attr( M, "proj4string_planar" ) =  p$aegis_proj4string_planar_km
      attr( M, "proj4string_lonlat" ) =  projection_proj4string("lonlat_wgs84")
          # p$quantile_bounds = c(0.0005, 0.9995)

      M$AUID = st_points_in_polygons(
        pts = st_as_sf( M, coords=c("lon","lat"), crs=crs_lonlat ),
        polys = sppoly[, "AUID"],
        varname="AUID"
      )
      M = M[ which(!is.na(M$AUID)),]
      M$AUID = as.character( M$AUID )  # match each datum to an area

      eps = .Machine$double.eps
      M$z = M$z + runif( nrow(M), min=-eps, max=eps )

      M$lon = NULL
      M$lat = NULL

      M$tag = "observations"

      region.id = slot( slot(sppoly, "nb"), "region.id" )
      APS = st_drop_geometry(sppoly)
      sppoly = NULL
      gc()

      APS[, p$variabletomodel] = NA
      APS$AUID = as.character( APS$AUID )
      APS$tag ="predictions"

      vn = c("z", "tag", "AUID" )

      M = rbind( M[, vn], APS[, vn] )
      APS = NULL

      #required for carstm formulae
      M$space = as.character( M$AUID)

      save( M, file=fn, compress=TRUE )
      return( M )
    }

    # ------------------------------

    if ( DS %in% c("bathymetry", "stmv_inputs", "stmv_inputs_redo" )) {

      fn = file.path( p$modeldir, paste( "bathymetry", "stmv_inputs", "rdata", sep=".") )
      if (DS %in% c("bathymetry", "stmv_inputs") ) {
        load( fn)
        return( hm )
      }

      B = bathymetry_db ( p=p, DS="aggregated_data", redo=TRUE )  # 16 GB in RAM just to store!
      B$lon = NULL
      B$lat = NULL
      names(B)[which(names(B) == paste(p$variabletomodel, "mean", sep="."))] = p$variabletomodel

      print( "Warning: this needs a lot of RAM .. ~60GB depending upon resolution of discretization .. a few hours " )

      hm = list( input=B, output=list( LOCS = spatial_grid(p) ) )
      B = NULL; gc()
      save( hm, file=fn, compress=FALSE)
      hm = NULL
      gc()
      return(fn)

    }

    # ------------------------------

    if ( DS %in% c("stmv_inputs_highres", "stmv_inputs_highres_redo" )) {

      fn = file.path( p$modeldir, paste( "bathymetry", "stmv_inputs_highres", "rdata", sep=".") )
      if (DS %in% c("stmv_inputs_highres") ) {
        load( fn)
        return( hm )
      }

      B = bathymetry_db ( p=p, DS="z.lonlat.rawdata" )  # 16 GB in RAM just to store!

      # p$quantile_bounds = c(0.0005, 0.9995)
      if (exists("quantile_bounds", p)) {
        TR = quantile(B[,p$variabletomodel], probs=p$quantile_bounds, na.rm=TRUE )
        keep = which( B[,p$variabletomodel] >=  TR[1] & B[,p$variabletomodel] <=  TR[2] )
        if (length(keep) > 0 ) B = B[ keep, ]
      }

      # thin data a bit ... remove potential duplicates and robustify
      B = lonlat2planar( B, proj.type=p$aegis_proj4string_planar_km )  # first ensure correct projection

      B$lon = NULL
      B$lat = NULL

      attr( B, "proj4string_planar" ) =  p$aegis_proj4string_planar_km

      hm = list( input=B, output=list( LOCS = spatial_grid(p) ) )
      B = NULL; gc()
      save( hm, file=fn, compress=FALSE)
      hm = NULL
      gc()
      return(fn)

    }

    # ----------------

    if ( DS == "landmasks.create" ) {

      ## NOTE::: This does not get used

      # on resolution of predictions
      V = SpatialPoints( planar2lonlat( spatial_grid(p), proj.type=p$aegis_proj4string_planar_km )[, c("lon", "lat" )], CRS("+proj=longlat +datum=WGS84") )
      landmask( lonlat=V, db="worldHires", regions=c("Canada", "US"), ylim=c(36,53), xlim=c(-72,-45), tag="predictions", crs=p$aegis_proj4string_planar_km)

      # on resolution of statistics
      sbox = list(
        plats = seq( p$corners$plat[1], p$corners$plat[2], by=p$stmv_distance_statsgrid ),
        plons = seq( p$corners$plon[1], p$corners$plon[2], by=p$stmv_distance_statsgrid ) )
      V = as.matrix( expand.grid( sbox$plons, sbox$plats ))
      names(V) = c("plon", "plat")
      V = SpatialPoints( planar2lonlat( V, proj.type=p$aegis_proj4string_planar_km )[, c("lon", "lat" )], CRS("+proj=longlat +datum=WGS84") )
      landmask( lonlat=V, db="worldHires",regions=c("Canada", "US"), ylim=c(36,53), xlim=c(-72,-45), tag="statistics", crs=p$aegis_proj4string_planar_km)
    }

    #-------------------------

    if ( DS %in% c("complete", "complete.redo" )) {
      #// merge all stmv results and compute stats and warp to different grids
      outdir = file.path( p$modeldir, p$stmv_model_label, p$project_class, paste(  p$stmv_global_modelengine, p$stmv_local_modelengine, sep="_") )

      fn = file.path( outdir, paste( "bathymetry", "complete", p$spatial_domain, "rdata", sep=".") )

      if ( DS %in% c( "complete") ) {
        Z = NULL
        if ( file.exists ( fn) ) load( fn)
        return( Z )
      }

      nr = p$nplons
      nc = p$nplats

      # data prediction grid
      B = spatial_grid( p)
      Bmean = stmv_db( p=p, DS="stmv.prediction", ret="mean" )
      Blb = stmv_db( p=p, DS="stmv.prediction", ret="lb" )
      Bub = stmv_db( p=p, DS="stmv.prediction", ret="ub" )
      Z = data.frame( cbind(B, Bmean, Blb, Bub) )
      names(Z) = c( "plon", "plat", "z", "z.lb", "z.ub") # really Z.mean but for historical compatibility "z"
      B = Bmean = Blb = Bub = NULL

      # # remove land
      # oc = landmask( db="worldHires", regions=c("Canada", "US"), return.value="land", tag="predictions" )
      # Z$z[oc] = NA
      # Z$z.sd[oc] = NA

      Zmn = matrix( Z[,p$variabletomodel], nrow=nr, ncol=nc )  # means

      # first order central differences but the central term drops out:
      # diffr = ( ( Zmn[ 1:(nr-2), ] - Zmn[ 2:(nr-1), ] ) + ( Zmn[ 2:(nr-1), ] - Zmn[ 3:nr, ] ) ) / 2
      # diffc = ( ( Zmn[ ,1:(nc-2) ] - Zmn[ ,2:(nc-1) ] ) + ( Zmn[ ,2:(nc-1) ] - Zmn[ ,3:nc ] ) ) / 2
      diffr =  Zmn[ 1:(nr-2), ] - Zmn[ 3:nr, ]
      diffc =  Zmn[ ,1:(nc-2) ] - Zmn[ ,3:nc ]
      rm (Zmn); gc()

      dZ = ( diffr[ ,2:(nc-1) ] + diffc[ 2:(nr-1), ] ) / 2
      dZ = rbind( dZ[1,], dZ, dZ[nrow(dZ)] )  # top and last rows are copies .. dummy value to keep dim correct
      dZ = cbind( dZ[,1], dZ, dZ[,ncol(dZ)] )

      Z$dZ =  abs(c(dZ))

      # gradients
      ddiffr =  dZ[ 1:(nr-2), ] - dZ[ 3:nr, ]
      ddiffc =  dZ[ ,1:(nc-2) ] - dZ[ ,3:nc ]
      dZ = diffc = diffr = NULL

      ddZ = ( ddiffr[ ,2:(nc-1) ] + ddiffc[ 2:(nr-1), ] ) / 2
      ddZ = rbind( ddZ[1,], ddZ, ddZ[nrow(ddZ)] )  # top and last rows are copies .. dummy value to keep dim correct
      ddZ = cbind( ddZ[,1], ddZ, ddZ[,ncol(ddZ)] )
      Z$ddZ = abs(c(ddZ))

      # merge into statistics
      BS = stmv_db( p=p, DS="stmv.stats" )
      colnames(BS) = paste("b", colnames(BS), sep=".")
      Z = cbind( Z, BS )

      save( Z, file=fn, compress=TRUE)

      BS = ddZ = ddiffc = ddiffr = NULL
      gc()

      # now warp to the other grids
      p0 = p  # the originating parameters

      Z0 = Z  # rename as 'Z' will be overwritten below
      L0 = Z0[, c("plon", "plat")]
      L0i = array_map( "xy->2", L0, gridparams=p0$gridparams )

      voi_bathy = setdiff( names(Z0), c("plon", "plat", "lon", "lat") )
      grids = setdiff( unique( p0$spatial_domain_subareas ), p0$spatial_domain )

      for (gr in grids ) {
        print(gr)
        p1 = spatial_parameters( spatial_domain=gr ) #target projection
        # warping
          L1 = spatial_grid( p=p1 )
          L1i = array_map( "xy->2", L1[, c("plon", "plat")], gridparams=p1$gridparams )
          L1 = planar2lonlat( L1, proj.type=p1$aegis_proj4string_planar_km )
          Z = L1
          L1$plon_1 = L1$plon # store original coords
          L1$plat_1 = L1$plat
          L1 = lonlat2planar( L1, proj.type=p0$aegis_proj4string_planar_km )

          p1$wght = fields::setup.image.smooth(
            nrow=p1$nplons, ncol=p1$nplats, dx=p1$pres, dy=p1$pres,
            theta=p1$pres/3, xwidth=4*p1$pres, ywidth=4*p1$pres )
        # theta=p1$pres/3 assume at pres most of variance is accounted ... correct if dense pre-intepolated matrices .. if not can be noisy

          for (vn in voi_bathy) {
            Z[,vn] = spatial_warp( Z0[,vn], L0, L1, p0, p1, "fast", L0i, L1i )
          }
        Z = Z[ , names(Z0) ]

        fn = file.path( outdir, paste( "bathymetry", "complete", p1$spatial_domain, "rdata", sep=".") )
        save (Z, file=fn, compress=TRUE)
      }

      return(fn)

      if (0) {
        aoi = which( Z$z > 10 & Z$z < 500 )
        datarange = log( quantile( Z[aoi,"z"], probs=c(0.001, 0.999), na.rm=TRUE ))
        dr = seq( datarange[1], datarange[2], length.out=100)

        levelplot( log(z) ~ plon + plat, Z[ aoi,], aspect="iso", labels=FALSE, pretty=TRUE, xlab=NULL,ylab=NULL,scales=list(draw=FALSE), at=dr, col.regions=rev(color.code( "seis", dr)) )
        levelplot( log(phi) ~ plon + plat, Z[ aoi,], aspect="iso", labels=FALSE, pretty=TRUE, xlab=NULL,ylab=NULL,scales=list(draw=FALSE) )
        levelplot( log(range) ~ plon + plat, Z[aoi,], aspect="iso", labels=FALSE, pretty=TRUE, xlab=NULL,ylab=NULL,scales=list(draw=FALSE) )

      }
    }

    # ------------

    if (DS %in% c("baseline", "baseline.redo") ) {
      # form prediction surface in planar coords over the ocean

      outdir = file.path( p$modeldir, p$stmv_model_label, p$project_class, paste(  p$stmv_global_modelengine, p$stmv_local_modelengine, sep="_") )

      if ( DS=="baseline" ) {
        #  used to obtain coordinates
        fn = paste( "bathymetry", "baseline", p$spatial_domain, "rdata" , sep=".")
        outfile =  file.path( outdir, fn )
        Z = NULL
        load( outfile )
        Znames = names(Z)
        if (is.null(varnames)) varnames =c("plon", "plat")  # default is to send locs only .. different reative to all other data streams
        varnames = intersect( Znames, varnames )  # send anything that results in no match causes everything to be sent
        if (length(varnames) == 0) varnames=Znames  # no match .. send all
        Z = Z[ , varnames]
        return (Z)
      }

      for (domain in unique( c(p$spatial_domain_subareas, p$spatial_domain ) ) ) {
        pn = spatial_parameters( p=p, spatial_domain=domain )
        # if ( pn$spatial_domain == "snowcrab" ) {
        #   # NOTE::: snowcrab baseline == SSE baseline, except it is a subset so begin with the SSE conditions
        #   pn = spatial_parameters( p=pn, spatial_domain="SSE" )
        # }
        Z = bathymetry_db( p=pn, DS="complete" )
        Z = Z[ geo_subset( spatial_domain=domain, Z=Z ), ]

        # range checks
        ii = which( Z$dZ < exp(-6))
        if (length(ii) > 0) Z$dZ[ii] = exp(-6)

        ii = which( Z$dZ > 50 )
        if (length(ii) > 0) Z$dZ[ii] = 50

        ii = which( Z$ddZ < exp(-6))
        if (length(ii) > 0) Z$ddZ[ii] = exp(-6)

        ii = which( Z$ddZ > 20 )
        if (length(ii) > 0) Z$ddZ[ii] = 20

        fn = paste( "bathymetry", "baseline", domain, "rdata" , sep="." )
        outfile =  file.path( outdir, fn )

        save (Z, file=outfile, compress=T )
        print( outfile )
      }
      # require (lattice); levelplot( z~plon+plat, data=Z, aspect="iso")
      return( "completed" )
    }

    # ------------

    if (DS %in% c("baseline_prediction_locations", "baseline_prediction_locations.redo") ) {
      # form prediction surface in planar coords over the ocean

      outdir = p$modeldir

      if ( DS=="baseline_prediction_locations" ) {
        #  used to obtain coordinates
        fn = paste( "bathymetry", "baseline_prediction_locations", p$spatial_domain, "rdata" , sep=".")
        outfile =  file.path( outdir, fn )
        Z = NULL
        if (file.exists(fn)) {
          load( outfile )
          Znames = names(Z)
          if (is.null(varnames)) varnames =c("plon", "plat")  # default is to send locs only .. different reative to all other data streams
          varnames = intersect( Znames, varnames )  # send anything that results in no match causes everything to be sent
          if (length(varnames) == 0) varnames=Znames  # no match .. send all
          Z = Z[ , varnames]
          return (Z)
        }
      }

      pn = spatial_parameters( p=p, spatial_domain=p$spatial_domain )
      Z = spatial_grid(p)
      Z = planar2lonlat( Z,  proj.type=p$aegis_proj4string_planar_km   )
      Z$z = aegis_lookup( paramaters="bathymetry", LOCS=Z[, c("lon", "lat")], project_class="core", output_format="points" , DS="aggregated_data", variable.name="z.mean" )  # core == unmodelled
      Z = Z[ geo_subset( spatial_domain=p$spatial_domain, Z=Z ), ]

      fn = paste( "bathymetry", "baseline_prediction_locations", p$spatial_domain, "rdata" , sep=".")
      outfile =  file.path( outdir, fn )

      save (Z, file=outfile, compress=TRUE )
      print( outfile )

      # require (lattice); levelplot( z~plon+plat, data=Z, aspect="iso")
      return( Z )
    }

    # ------------

  }  # end bathymetry_db


model_evapotranspiration <- function (isWindVpDefined = 1,
         evapoTranspirationPriestlyTaylor = 449.367,
         evapoTranspirationPenman = 830.958){
    #'- Name: EvapoTranspiration -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Evapotranspiration Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA Montpellier
    #'            * ExtendedDescription: According to the availability of wind and/or vapor pressure daily data, the
    #'            SiriusQuality2 model calculates the evapotranspiration rate using the Penman (if wind
    #'            and vapor pressure data are available) (Penman 1948) or the Priestly-Taylor
    #'            (Priestley and Taylor 1972) method
    #'            * ShortDescription: It uses to choose evapotranspiration of Penmann or Priestly-Taylor
    #'- inputs:
    #'            * name: isWindVpDefined
    #'                          ** description : if wind and vapour pressure are defined
    #'                          ** parametercategory : constant
    #'                          ** datatype : INT
    #'                          ** default : 1
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: evapoTranspirationPriestlyTaylor
    #'                          ** description : evapoTranspiration of Priestly Taylor
    #'                          ** variablecategory : rate
    #'                          ** default : 449.367
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : mm
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: evapoTranspirationPenman
    #'                          ** description : evapoTranspiration of Penman
    #'                          ** datatype : DOUBLE
    #'                          ** variablecategory : rate
    #'                          ** default : 830.958
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : mm
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: evapoTranspiration
    #'                          ** description : evapoTranspiration
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : mm
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    if (isWindVpDefined == 1)
    {
        evapoTranspiration <- evapoTranspirationPenman
    }
    else
    {
        evapoTranspiration <- evapoTranspirationPriestlyTaylor
    }
    return (list('evapoTranspiration' = evapoTranspiration))
}