R/distanceWeighting.R

In pMEM: Predictive Moran's Eigenvector Maps

## **************************************************************************
##
##    (c) 2023-2024 Guillaume Guénard
##        Department de sciences biologiques,
##        Université de Montréal
##        Montreal, QC, Canada
##
##    **Distance Weighting Function**
##
##    This file is part of pMEM
##
##    pMEM is free software: you can redistribute it and/or modify
##    it under the terms of the GNU General Public License as published by
##    the Free Software Foundation, either version 3 of the License, or
##    (at your option) any later version.
##
##    pMEM is distributed in the hope that it will be useful,
##    but WITHOUT ANY WARRANTY; without even the implied warranty of
##    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##    GNU General Public License for more details.
##
##    You should have received a copy of the GNU General Public License
##    along with pMEM. If not, see <https://www.gnu.org/licenses/>.
##
##    R source code file
##
## **************************************************************************
##
#' Distance Weighting Function Generator
#' 
#' Function \code{genDWF} generates a distance weighting function on the basis
#' of given arguments.
#' 
#' @param fun The function describing the kind of distance weighting: one of
#' 'linear', 'power', 'hyperbolic', 'spherical', 'exponential',
#' 'Gaussian', 'hole_effect', or an unambiguous abbreviation of one of them.
#' @param range A single numeric value giving the range of the distance
#' weighting function (see details).
#' @param shape A single (numeric) shape parameter used by functions
#' 'power' or 'hyperbolic' (ignored by the other functions).
#' 
#' @returns A single-argument function (\code{d}) transforming the distances
#' into weights. This function returns a matrix when the distances are provided
#' as a matrix and a numeric vector when the distances are provided as a numeric
#' vector.
#' 
#' @details All distance weighting function return the value 1 (or 1+0i) for a
#' distance or 0 (or 0+0i). For functions 'linear', 'power', 'hyperbolic', and
#' 'spherical', argument \code{range} corresponds to the distance above which
#' weights have a constant value of 0 (or 0+0i). Functions 'exponential',
#' 'Gaussian', and 'hole_effect' have no definite value beyond \code{d > range},
#' but collapse asymptotically toward 0 either monotonically ('exponential' and
#' 'Gaussian'), or following dampened oscillations about the value 0
#' ('hole_effect').
#' 
#' @author \packageAuthor{pMEM}
#' 
#' @examples  ## Show examples of distance weighting functions (real-valued)
#' 
#' ## Custom display function for this example (real-values):
#' plotDWF <- function(d, w, label, ylim = c(0,1)) {
#'   plot(x = d, y = w[,1L], type = "l", ylim = ylim, las = 1L,
#'        xlab = "Distance", ylab = "", cex.axis = 2, cex.lab=2, lwd = 2)
#'   lines(x = d, y = w[,2L], col = "red", lwd = 2)
#'   lines(x = d, y = w[,3L], col = "blue", lwd = 2)
#'   text(x = 2.5, y = 0.8, label = label, adj = 0, cex = 2)
#' }
#' 
#' ## A set of distances from which to show the corresponding weights:
#' d <- seq(0,5,0.001)
#' 
#' ## Graphical parameters for all the figures:
#' tmp <- par(no.readonly = TRUE)
#' par(mar=c(5.1,5.1,0.6,0.6))
#' 
#' ## Shapes of the seven distance weighting functions implemented in this
#' ## package for real-valued distances.
#' 
#' ## The linear function:
#' 
#' cbind(
#'   genDWF(fun = "linear", range = 1)(d),
#'   genDWF(fun = "linear", range = 0.5)(d),
#'   genDWF(fun = "linear", range = 2)(d)
#' ) -> w
#' 
#' plotDWF(d, w, label="Linear")
#' 
#' ## The power function:
#' 
#' cbind(
#'   genDWF(fun = "power", range = 1, shape = 1)(d),
#'   genDWF(fun = "power", range = 2, shape = 0.5)(d),
#'   genDWF(fun = "power", range = 3, shape = 0.5)(d)
#' ) -> w
#' 
#' plotDWF(d, w, label="Power")
#' 
#' ## The hyperbolic function:
#' 
#' cbind(
#'   genDWF(fun = "hyperbolic", range = 1, shape = 1)(d),
#'   genDWF(fun = "hyperbolic", range = 2, shape = 0.5)(d),
#'   genDWF(fun = "hyperbolic", range = 0.5, shape = 2)(d)
#' ) -> w
#' 
#' plotDWF(d, w, label="Hyperbolic")
#' 
#' ## The spherical function:
#' 
#' cbind(
#'   genDWF(fun = "spherical", range = 1)(d),
#'   genDWF(fun = "spherical", range = 0.5)(d),
#'   genDWF(fun = "spherical", range = 2)(d)
#' ) -> w
#' 
#' plotDWF(d, w, label="Spherical")
#' 
#' ## The exponential function:
#' 
#' cbind(
#'   genDWF(fun = "exponential", range = 1)(d),
#'   genDWF(fun = "exponential", range = 0.5)(d),
#'   genDWF(fun = "exponential", range = 2)(d)
#' ) -> w
#' 
#' plotDWF(d, w, label="Exponential")
#' 
#' ## The Gaussian function:
#' 
#' cbind(
#'   genDWF(fun = "Gaussian", range = 1)(d),
#'   genDWF(fun = "Gaussian", range = 0.5)(d),
#'   genDWF(fun = "Gaussian", range = 2)(d)
#' ) -> w
#' 
#' plotDWF(d, w, label="Gaussian")
#' 
#' ## The "hole effect" (cardinal sine) function:
#' 
#' cbind(
#'   genDWF(fun = "hole_effect", range = 1)(d),
#'   genDWF(fun = "hole_effect", range = 0.5)(d),
#'   genDWF(fun = "hole_effect", range = 2)(d)
#' ) -> w
#' 
#' plotDWF(d, w, label="Hole effect", ylim=c(-0.2,1))
#' 
#' 
#' ## Custom display function for this example (complex-values):
#' plotDWFcplx <- function(d, w, label, ylim) {
#'   plot(x = Mod(d), y = Re(w[,1L]), type = "l", ylim = ylim, las = 1L,
#'   xlab = "Distance", ylab = "", cex.axis = 2, cex.lab=2, lwd = 2, lty = 2L)
#'   lines(x = Mod(d), y = Im(w[,1L]), lwd = 2, lty=3L)
#'   lines(x = Mod(d), y = Re(w[,2L]), col = "red", lwd = 2, lty = 2L)
#'   lines(x = Mod(d), y = Im(w[,2L]), col = "red", lwd = 2, lty = 3L)
#'   lines(x = Mod(d), y = Re(w[,3L]), col = "blue", lwd = 2, lty = 2L)
#'   lines(x = Mod(d), y = Im(w[,3L]), col = "blue", lwd = 2, lty = 3L)
#'   text(x = 2.5, y = 0.8, label = label, adj = 0, cex = 2)
#'   invisible(NULL)
#' }
#' 
#' ## Generated the asymmetric distance metrics for a one-dimensional transect
#' ## and a delta of pi/8 (0.39...):
#' dd <- complex(modulus=seq(0,5,0.001), argument = pi/8)
#' 
#' ## Shapes of the seven distance weighting functions implemented in this
#' ## package for complex-valued distances.
#' 
#' ## The linear function:
#' 
#' cbind(
#'   genDWF(fun = "linear", range = 1)(dd),
#'   genDWF(fun = "linear", range = 0.5)(dd),
#'   genDWF(fun = "linear", range = 2)(dd)
#' ) -> ww
#' 
#' plotDWFcplx(dd, ww, label="Linear", ylim=c(-0.4,1))
#' 
#' ## The power function:
#' 
#' cbind(
#'   genDWF(fun = "power", range = 1, shape = 1)(dd),
#'   genDWF(fun = "power", range = 2, shape = 0.5)(dd),
#'   genDWF(fun = "power", range = 3, shape = 0.5)(dd)
#' ) -> ww
#' 
#' plotDWFcplx(dd, ww, label="Power", ylim=c(-0.4,1))
#' 
#' ## The hyperbolic down function:
#' 
#' cbind(
#'   genDWF(fun = "hyperbolic", range = 1, shape = 1)(dd),
#'   genDWF(fun = "hyperbolic", range = 2, shape = 0.5)(dd),
#'   genDWF(fun = "hyperbolic", range = 0.5, shape = 2)(dd)
#' ) -> ww
#' 
#' plotDWFcplx(dd, ww, label="Hyperbolic", ylim=c(-0.4,1))
#' 
#' ## The spherical function:
#' 
#' cbind(
#'   genDWF(fun = "spherical", range = 1)(dd),
#'   genDWF(fun = "spherical", range = 0.5)(dd),
#'   genDWF(fun = "spherical", range = 2)(dd)
#' ) -> ww
#' 
#' plotDWFcplx(dd, ww, label="Spherical", ylim=c(-0.4,1))
#' 
#' ## The exponential function:
#' 
#' cbind(
#'   genDWF(fun = "exponential", range = 1)(dd),
#'   genDWF(fun = "exponential", range = 0.5)(dd),
#'   genDWF(fun = "exponential", range = 2)(dd)
#' ) -> ww
#' 
#' plotDWFcplx(dd, ww, label="Exponential", ylim=c(-0.4,1))
#' 
#' ## The Gaussian function:
#' 
#' cbind(
#'   genDWF(fun = "Gaussian", range = 1)(dd),
#'   genDWF(fun = "Gaussian", range = 0.5)(dd),
#'   genDWF(fun = "Gaussian", range = 2)(dd)
#' ) -> ww
#' 
#' plotDWFcplx(dd, ww, label="Gaussian", ylim=c(-0.4,1))
#' 
#' ## The "hole effect" (cardinal sine) function:
#' 
#' cbind(
#'   genDWF(fun = "hole_effect", range = 1)(dd),
#'   genDWF(fun = "hole_effect", range = 0.5)(dd),
#'   genDWF(fun = "hole_effect", range = 2)(dd)
#' ) -> ww
#' 
#' plotDWFcplx(dd, ww, label="Hole effect", ylim=c(-0.3,1.1))
#' 
#' ## Restore previous graphical parameters:
#' par(tmp)
#' 
#' 
#' @importFrom Rcpp evalCpp
#' 
#' @useDynLib pMEM, .registration = TRUE
#' 
#' @export
genDWF <- function(
    fun = c("linear","power","hyperbolic","spherical", "exponential",
            "Gaussian", "hole_effect"),
    range,
    shape = 1
) {
  fun <- match.arg(fun)
  flist <- c("linear","power","hyperbolic","spherical","exponential",
             "Gaussian", "hole_effect")
  method <- which(flist == fun)
  function(d)
    if(is.complex(d)) {
      .Call("pMEM_dwfCplx", PACKAGE="pMEM", d, method, c(range, shape))
    } else
      .Call("pMEM_dwfReal", PACKAGE="pMEM", d, method, c(range, shape))
}
#'