Skip to content

Commit

Permalink
Streamline functions
Browse files Browse the repository at this point in the history 
And add verbose argument
  • Loading branch information
@pjbouchet
pjbouchet committed Oct 14, 2020
1 parent 342b311 commit ba59141
Show file tree
Hide file tree
Showing 39 changed files with 487 additions and 1,349 deletions.
5 changes: 4 additions & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -39,6 +39,9 @@ Suggests:
knitr,
methods,
rmarkdown,
testthat
testthat,
GGally,
sf,
viridisLite
RoxygenNote: 7.1.0
VignetteBuilder: knitr
78 changes: 51 additions & 27 deletions R/compare_covariates.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,11 +5,12 @@
#' The extent and magnitude of extrapolation naturally vary with the type and number of covariates considered. It may be useful, therefore, to test different combinations of covariates to inform their selection \emph{a priori}, i.e. before model fitting, thereby supporting model parsimony.
#' @import ggplot2
#' @param extrapolation.type Character string. Type of extrapolation to be assessed. Can be one of \code{univariate}, \code{combinatorial}, or \code{both} (default).
#' @param extrapolation.object List object as returned by \link{compute_extrapolation}.
#' @param n.covariates Maximum number of covariates. The function will compare all combinations of 1 to \code{n.covariates} covariates.
#' @param create.plots Logical, defaults to \code{TRUE}. Whether to produce summary plots.
#' @param display.percent Logical. If \code{TRUE} (default), scales the y-axis of the summary plots as a percentage of the total number of grid cells in \code{prediction.grid}.
#'
#' @inheritParams compute_extrapolation
#' @param verbose Logical. Show or hide possible warnings and messages.
#' @param ... Additional parameters passed to \link{compute_extrapolation}. These are optional when \code{extrapolation.object} is specified, and compulsory otherwise.
#'
#' @return Prints a summary table in the R console. Also generates summary boxplots if \code{create.plots} is set to \code{TRUE}.
#'
Expand Down Expand Up @@ -47,39 +48,70 @@
#' coordinate.system = my_crs,
#' create.plots = TRUE,
#' display.percent = TRUE)
#'
#' # Can also run this function directly from the
#' # object returned by compute_extrapolation
#' spermw.extrapolation <- compute_extrapolation(samples = segs,
#' covariate.names = my_cov,
#' prediction.grid = predgrid,
#' coordinate.system = my_crs)
#'
#' compare_covariates(extrapolation.type = "both",
#' extrapolation.object = spermw.extrapolation)
#'
#' @author Phil J. Bouchet

compare_covariates <- function(extrapolation.type = "both",
samples,
covariate.names,
extrapolation.object = NULL,
n.covariates = NULL,
prediction.grid,
coordinate.system,
create.plots = TRUE,
display.percent = TRUE,
resolution = NULL){
verbose = TRUE,
...){

#---------------------------------------------
# Total number of prediction grid cells
# Check inputs
#---------------------------------------------

ntot <- nrow(prediction.grid)
if(is.null(extrapolation.object)){
extrapolation.object <- list(...)
required.args <- c("samples", "covariate.names", "prediction.grid", "coordinate.system")
if(!all(required.args %in% names(extrapolation.object))) {
missing.args <- required.args[which(!required.args %in% names(extrapolation.object))]
stop(paste0("Missing input arguments: ", paste0(missing.args, collapse = ", ")))}
}

samples <- extrapolation.object$samples
covariate.names <- extrapolation.object$covariate.names
prediction.grid <- extrapolation.object$prediction.grid
coordinate.system <- extrapolation.object$coordinate.system

#---------------------------------------------
# Perform function checks
# Additional function checks
#---------------------------------------------

if(!extrapolation.type%in%c("both", "univariate", "combinatorial"))
stop("Unknown extrapolation type")
stop("Unknown extrapolation type.")

if(!is.null(n.covariates)){
if(max(n.covariates) > length(covariate.names))
stop("n.covariates exceeds the number of covariates available")}
stop("n.covariates exceeds the number of covariates available.")}

#---------------------------------------------
# Check CRS
#---------------------------------------------

coordinate.system <- check_crs(coordinate.system = coordinate.system)

samples <- na.omit(samples)
prediction.grid <- na.omit(prediction.grid)

#---------------------------------------------
# Total number of prediction grid cells
#---------------------------------------------

ntot <- nrow(prediction.grid)

#---------------------------------------------
# Determine all possible combinations of covariates
#---------------------------------------------
Expand Down Expand Up @@ -108,7 +140,7 @@ compare_covariates <- function(extrapolation.type = "both",
purrr::flatten(.)
}

message("Preparing the data ...")
if(verbose) message("Preparing the data ...")

#---------------------------------------------
# Check if prediction grid is regular
Expand All @@ -128,43 +160,35 @@ compare_covariates <- function(extrapolation.type = "both",

if(is.null(resolution)) stop('Prediction grid cells are not regularly spaced.\nA target raster resolution must be specified.')

warning('Prediction grid cells are not regularly spaced.\nData will be rasterised and covariate values averaged.')
if(verbose) warning('Prediction grid cells are not regularly spaced.\nData will be rasterised and covariate values averaged.')

check.grid$z <- NULL
sp::coordinates(check.grid) <- ~x+y
sp::proj4string(check.grid) <- coordinate.system

# Create empty raster with desired resolution

ras <- raster::raster(raster::extent(check.grid), res = resolution)
raster::crs(ras) <- coordinate.system

# Create individual rasters for each covariate

ras.list <- purrr::map(.x = covariate.names,
.f = ~raster::rasterize(as.data.frame(check.grid), ras,
prediction.grid[,.x], fun = mean_ras)) %>%
purrr::set_names(., covariate.names)

# Combine all rasters

ras.list <- raster::stack(ras.list)

# Update prediction grid

prediction.grid <- raster::as.data.frame(ras.list, xy = TRUE, na.rm = TRUE)

# warning('New prediction grid (pred.grid) saved to global environment.')
# assign(x = 'pred.grid', prediction.grid, envir = .GlobalEnv)


} # End if class(grid.regular)

#---------------------------------------------
# Carry out extrapolation analysis for each combination of covariates
#---------------------------------------------

message("Computing ...")
if(verbose) message("Computing ...")

pb <- dplyr::progress_estimated(length(combs))

Expand Down Expand Up @@ -221,8 +245,9 @@ compare_covariates <- function(extrapolation.type = "both",
# Build text string of variables
#---------------------------------------------

message("\n")
message("Creating summaries ...")
if(verbose){
message("\n")
message("Creating summaries ...")}

if(extrapolation.type=="both"){

Expand Down Expand Up @@ -549,8 +574,7 @@ compare_covariates <- function(extrapolation.type = "both",
print(p3)
}

message("Done!")

if(verbose) message("Done!")
print(knitr::kable(restxt, format = "pandoc"))

}
85 changes: 28 additions & 57 deletions R/compute_extrapolation.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -36,8 +36,9 @@
# @param print.precision Integer. Number of significant figures to be used when printing the summary. Default value of 2.
# @param save.summary Logical, defaults to \code{FALSE}. Adds summary statistics to the output list.
#' @param resolution Resolution of the output raster (in units relevant to \code{coordinate.system}). Only required if \code{prediction.grid} is irregular, and thus needs to be rasterised. Defaults to \code{NULL}.
#' @param verbose Logical. Show or hide possible warnings and messages.
#'
#' @return A list object containing extrapolation values in both \code{data.frame} and \code{\link[raster]{raster}} format.
#' @return A list object containing extrapolation values in both \code{data.frame} and \code{\link[raster]{raster}} format. Also included are a summary object of class \code{extrapolation_results_summary} and a copy of function inputs (i.e, \code{coordinate.system}, \code{covariate.names}, and \code{prediction.grid}).
#'
#' @author Phil J. Bouchet
#'
Expand Down Expand Up @@ -107,19 +108,15 @@
#' coordinate.system = sp::proj4string(r))
#'
#' # Make a map
#' map_extrapolation(map.type = "extrapolation",
#' extrapolation.values = bioclim.ex,
#' covariate.names = bioclim.variables,
#' coordinate.system = sp::proj4string(r),
#' prediction.grid = target)

#' map_extrapolation(map.type = "extrapolation", extrapolation.object = bioclim.ex)

compute_extrapolation <- function(samples,
segments,
covariate.names,
prediction.grid,
coordinate.system,
resolution = NULL){
resolution = NULL,
verbose = TRUE){

#---------------------------------------------
# Perform function checks
Expand All @@ -128,7 +125,7 @@ compute_extrapolation <- function(samples,
calls <- names(sapply(match.call(), deparse))[-1]

if(any("segments" %in% calls)) {
warning("The 'segments' argument is deprecated, please use 'samples' instead.")
if(verbose) warning("The 'segments' argument is deprecated, please use 'samples' instead.")
samples <- segments
}

Expand Down Expand Up @@ -163,7 +160,7 @@ compute_extrapolation <- function(samples,

if(is.null(resolution)) stop('Prediction grid cells are not regularly spaced.\nA target raster resolution must be specified. See package documentation for details.')

warning('Prediction grid cells are not regularly spaced.\nData will be rasterised and covariate values averaged. See package documentation for details.')
if(verbose) warning('Prediction grid cells are not regularly spaced.\nData will be rasterised and covariate values averaged. See package documentation for details.')

check.grid$z <- NULL
sp::coordinates(check.grid) <- ~x+y
Expand All @@ -189,13 +186,10 @@ compute_extrapolation <- function(samples,

prediction.grid <- raster::as.data.frame(ras.list, xy = TRUE, na.rm = TRUE)

# warning('New prediction grid (pred.grid) saved to global environment.')
# assign(x = 'pred.grid', prediction.grid, envir = .GlobalEnv)


} # End if class(grid.regular)

message("Computing ...")
if(verbose) message("Computing ...")

#---------------------------------------------
# Define reference and target systems
Expand Down Expand Up @@ -310,54 +304,31 @@ compute_extrapolation <- function(samples,
for(r in 1:length(reslist$rasters$mic)){
if(!is.null(reslist$rasters$mic[[r]]))raster::projection(reslist$rasters$mic[[r]]) <- coordinate.system}

message("Done!")

# #---------------------------------------------
# # Print/save summary
# #---------------------------------------------
#
# if(print.summary){
#
# if(save.summary){
#
sumres <- summarise_extrapolation(extrapolation.object = reslist,
covariate.names = covariate.names,
extrapolation = TRUE,
mic = TRUE)

class(sumres) <- c("extrapolation_results_summary", class(sumres))
reslist <- append(x = reslist, values = list(summary = sumres))
#
# }else{
#
# summarise_extrapolation(extrapolation.object = reslist,
# covariate.names = covariate.names,
# extrapolation = TRUE,
# mic = TRUE,
# print.precision = print.precision)
# }
#
# }else{
#
# if(save.summary){
#
# sink("/dev/null")
# sumres <- summarise_extrapolation(extrapolation.object = reslist,
# covariate.names = covariate.names,
# extrapolation = TRUE,
# mic = TRUE,
# print.precision = print.precision)
# sink()
# reslist <- append(x = reslist, values = list(summary = sumres))
#
# }else{
#
# }
# }

# keep it classy

sumres <- summarise_extrapolation(extrapolation.object = reslist,
covariate.names = covariate.names,
extrapolation = TRUE,
mic = TRUE)

class(sumres) <- c("extrapolation_results_summary", class(sumres))
reslist <- append(x = reslist, values = list(summary = sumres))

# Add function inputs to obviate need to specify them in map()
reslist <- append(x = reslist, values = list(
covariate.names = covariate.names,
samples = samples,
prediction.grid = prediction.grid,
coordinate.system = coordinate.system))

reslist <- append(list(type = c("extrapolation", "mic")), reslist)

# Keep it classy
class(reslist) <- c("extrapolation_results", class(reslist))

if(verbose) message("Done!")
return(reslist)

}
23 changes: 18 additions & 5 deletions R/compute_nearby.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,7 @@
#' @param max.size Minimum size threshold for partitioning computations. Calculated as \code{\link[base]{prod}(\link[base]{nrow}(samples),\link[base]{nrow}(prediction.grid))}. Has a default value of \code{1e7}. See the 'Details' section.
#' @param no.partitions Integer. Number of desired partitions of the data (default of 10). See the 'Details' section.
#' @param resolution Resolution of the output raster (in units relevant to \code{coordinate.system}). Only required if \code{prediction.grid} is irregular, and thus needs to be rasterised. Defaults to NULL.
#' @param verbose Logical. Show or hide possible warnings and messages.
#' @return A raster object mapping the proportion of reference data nearby each point in \code{prediction.grid}.
#' @author Phil J. Bouchet, Laura Mannocci.
#' @references Bouchet PJ, Miller DL, Roberts JJ, Mannocci L, Harris CM and Thomas L (2019). From here and now to there and then: Practical recommendations for extrapolating cetacean density surface models to novel conditions. CREEM Technical Report 2019-01, 59 p. \href{https://research-repository.st-andrews.ac.uk/handle/10023/18509}{https://research-repository.st-andrews.ac.uk/handle/10023/18509}
Expand Down Expand Up @@ -67,7 +68,8 @@ compute_nearby <- function (samples,
nearby,
max.size = 1e7,
no.partitions = 10,
resolution = NULL) {
resolution = NULL,
verbose = TRUE) {

#---------------------------------------------
# Perform function checks
Expand Down Expand Up @@ -151,7 +153,8 @@ compute_nearby <- function (samples,
test_data = prediction.grid,
covariate.names),
nearby = nearby,
no.partitions = no.partitions)
no.partitions = no.partitions,
verbose = verbose)

}else{

Expand All @@ -163,7 +166,8 @@ compute_nearby <- function (samples,
test_data = prediction.grid,
covariate.names),
nearby = nearby,
choice = "distance")
choice = "distance",
verbose = verbose)

}

Expand All @@ -178,6 +182,15 @@ compute_nearby <- function (samples,
rgow <- raster::rasterFromXYZ(xyz = rgow,
crs = coordinate.system)

message('Done!')
return(rgow)

reslist <- list(type = "nearby",
raster = rgow,
covariate.names = covariate.names,
samples = samples,
prediction.grid = prediction.grid,
coordinate.system = coordinate.system)


if(verbose) message('Done!')
return(reslist)
}
Loading

0 comments on commit ba59141

Please sign in to comment.