R/sample_background.R

In juoe/sdmflow: Flexible Workflows for Species Distribution Modeling

#' Create sample of background points.
#'
#' @param x An sf object containing the modeling data.
#' @param method "mcp" or "bb"
#' @param n Number of background points created.
#' @param n_frac Fraction of background samples compared to presence samples.
#' @param n_abs Absolute number of background samples. Instead used of n_frac if this argument is not NULL.
#' @param percentile Percentile number used for the creation of the minimum convex polygon (MCP)
#' in which background points are sampled.
#' @param ind_col Default is NULL. Can be used to specify column name identifying groups / clusters
#' in the presence observations (e.g. individuals). Then, MCPs are calculated on a cluster-level
#' and background points are sampled separately for each cluster.
#' @param occ_col Name of the occurence (presence / absence) column. Will be created if not available yet.
#' @param ... Arguments passed on to the sample functions.
#'
#' @return An sf object with an additional n / nrow(x)*n_frac rows containing the background points.
#' The feature values for the background samples will be sampled randomly from the presence samples.
#' @export


sample_background <- function(x, method = "mcp", ...){

  if (method == "mcp") {
    out <- sample_background_mcp(x, ...)
  } else if (method == "bb") {
    out <- sample_background_bb(x, ...)
  } else if (method == "target") {
    out <- sample_background_target(x, ...)
  } else {
    stop("Unknown method name.")
  }

  return(out)

}

#' @rdname sample_background

sample_background_bb <- function(x, n = nrow(x), occ_col = "occ"){

  x[[occ_col]] <- 1

  bb <- st_as_sfc(st_bbox(x))
  s <- sf::st_sf(geometry=sf::st_sample(bb, ceiling(n*2))) %>% dplyr::sample_n(n)

  replace <- ifelse(n > nrow(x), TRUE, FALSE)
  dat <- x %>% st_set_geometry(NULL) %>% dplyr::sample_n(n, replace)

  sdat <- dplyr::bind_cols(s, dat)
  sdat[[occ_col]] <- 0
  combined <- rbind(x, sdat)
  combined[[occ_col]] <- as.factor(combined[[occ_col]])
  combined[[occ_col]] <- relevel(combined[[occ_col]], "0")
  return(combined)
}

#' @rdname sample_background

sample_background_mcp <- function(x, n_frac = 1, n_abs = NULL, percentile = 100, ind_col=NULL, occ_col = "occ"){

  process <- function(obj){

    obj[[occ_col]] <- 1

    mcp <- mcp(obj, percentile)

    if (st_geometry_type(mcp) != "POLYGON"){
      return (NULL)
    } else {
      if(is.null(n_abs)) {
        n <- ceiling(nrow(obj) * n_frac)
      } else {
        n <- n_abs
      }
      s <- sf::st_sf(geometry=sf::st_sample(mcp, n*2)) %>% dplyr::sample_n(n)

      replace <- ifelse(n > nrow(obj), TRUE, FALSE)
      dat <- obj %>% sf::st_set_geometry(NULL) %>% dplyr::sample_n(n, replace)

      sdat <- dplyr::bind_cols(s, dat)
      sdat[[occ_col]] <- 0
      combined <- rbind(obj, sdat)
      combined[[occ_col]] <- as.factor(combined[[occ_col]])
      combined[[occ_col]] <- relevel(combined[[occ_col]], "0")
      return(combined)
    }


  }

  if(!is.null(ind_col)){

    x_split <- split(x, dplyr::pull(x, ind_col))
    x_process <- purrr::map(x_split, process) %>% purrr::discard(purrr::is_null)
    do.call(rbind, x_process)

  } else {

    process(x)

  }
}


#' @rdname sample_background

sample_background_target <- function(x, y, n_frac = 1, n_abs = NULL, ind_col=NULL, occ_col = "occ"){

  if(st_crs(y) != st_crs(x)) {
    y <- st_transform(y, st_crs(x))
  }

  process <- function(obj){

    obj[[occ_col]] <- 1

    if(is.null(n_abs)) {
      n <- ceiling(nrow(obj) * n_frac)
    } else {
      n <- n_abs
    }
    s <- sf::st_sf(geometry=sf::st_sample(y, n*2)) %>% dplyr::sample_n(n)

    replace <- ifelse(n > nrow(obj), TRUE, FALSE)
    dat <- obj %>% sf::st_set_geometry(NULL) %>% dplyr::sample_n(n, replace)

    sdat <- dplyr::bind_cols(s, dat)
    sdat[[occ_col]] <- 0
    combined <- rbind(obj, sdat)
    combined[[occ_col]] <- as.factor(combined[[occ_col]])
    combined[[occ_col]] <- relevel(combined[[occ_col]], "0")
    return(combined)



  }

  if(!is.null(ind_col)){

    x_split <- split(x, dplyr::pull(x, ind_col))
    x_process <- purrr::map(x_split, process) %>% purrr::discard(purrr::is_null)
    do.call(rbind, x_process)

  } else {

    process(x)

  }
}