R/genericfunctions.R

In Farewe/virtualspecies: Generation of Virtual Species Distributions

#' @export
#' @import terra
#' @method `$` VSSampledPoints
`$.VSSampledPoints` <- function(x, name)
{
  if(inherits(as.list(x)[[name]], "PackedSpatRaster")) {
    return(unwrap(`[[`(as.list(x), name)))
  } else {
    return(`[[`(as.list(x), name))
  }
}

#' @export
#' @import terra
#' @method `[[` VSSampledPoints
`[[.VSSampledPoints` <- function(x, name)
{
  if(inherits(as.list(x)[[name]], "PackedSpatRaster")) {
    return(unwrap(`[[`(as.list(x), name)))
  } else {
    return(`[[`(as.list(x), name))
  }
}

#' @export
#' @method `as.list` VSSampledPoints
as.list.VSSampledPoints <- function(x, ...)
{
  class(x) <- "list"
  return(x)
}


#' @export
#' @import terra
#' @method `$` virtualspecies
`$.virtualspecies` <- function(x, name)
{
  if(inherits(as.list(x)[[name]], "PackedSpatRaster")) {
    return(unwrap(`[[`(as.list(x), name)))
  } else {
    return(`[[`(as.list(x), name))
  }
}

#' @export
#' @import terra
#' @method `[[` virtualspecies
`[[.virtualspecies` <- function(x, name)
{
  if(inherits(as.list(x)[[name]], "PackedSpatRaster")) {
    return(unwrap(`[[`(as.list(x), name)))
  } else {
    return(`[[`(as.list(x), name))
  }
}

#' @export
#' @method `as.list` virtualspecies
as.list.virtualspecies <- function(x, ...)
{
  class(x) <- "list"
  return(x)
}


#' @export
#' @method print virtualspecies
print.virtualspecies <- function(x, ...)
{
  cat(paste("Virtual species generated from", 
            length(x$details$variables), 
            "variables:\n",
            paste(x$details$variables, collapse = ", ")))
  cat("\n\n- Approach used:")
  if(x$approach == "response")
  {
    cat(" Responses to each variable")

    cat("\n- Response functions:")
    sapply(x$details$variables, FUN = function(y)
    {
      cat("\n   .", y, 
          "  [min=", x$details$parameters[[y]]$min, 
          "; max=", x$details$parameters[[y]]$max,
          "] : ", 
          x$details$parameters[[y]]$fun,
          "   (", 
          paste(names(x$details$parameters[[y]]$args), 
                x$details$parameters[[y]]$args, sep = '=', collapse = "; "),
          ")", sep = "")
    })
    
    if (x$details$rescale.each.response)
    {
      cat("\n- Each response function was rescaled between 0 and 1")
    } else
    {
      cat("\n- Response functions were not rescaled between 0 and 1")
    }
    
    cat("\n- Environmental suitability formula = ", x$details$formula, sep = "")
    
    if (x$details$rescale)
    {
      cat("\n- Environmental suitability was rescaled between 0 and 1\n")
    } else
    {
      cat("\n- Environmental suitability was not rescaled between 0 and 1\n")
    }
    
  } else if(x$approach == "pca")
  {
    cat(" Response to axes of a PCA")
    cat("\n- Axes: ", 
        paste(x$details$axes, collapse = ", "),
        "; ", round(sum(x$details$pca$eig[x$details$axes])/sum(x$details$pca$eig) * 100, 2),
        "% explained by these axes")
    cat("\n- Responses to axes:")
    sapply(1:length(x$details$axes), function(y)
    {
      cat("\n   .Axis ", x$details$axes[y],
          "  [min=", round(min(x$details$pca$li[, x$details$axes[y]]), 2),
          "; max=", round(max(x$details$pca$li[, x$details$axes[y]]), 2),
          "] : dnorm (mean=", x$details$means[y], "; sd=", x$details$sds[y],
          ")", sep = "")
    })
    if (x$details$rescale)
    {
      cat("\n- Environmental suitability was rescaled between 0 and 1\n")
    } else
    {
      cat("\n- Environmental suitability was not rescaled between 0 and 1\n")
    }
  } else if(x$approach == "bca"){
    cat(" Response to axes of a BCA")
    cat("\n- Axes: ", 
        paste(x$details$axes, collapse = " & "),
        "; ", round(sum(x$details$bca$eig[x$details$axes])/sum(x$details$bca$eig) * 100, 2),
        "% explained by these axes")
    cat("\n- Responses to axes:")
    sapply(1:length(x$details$axes), function(y)
    {
      cat("\n   .Axis ", x$details$axes[y],
          "  [min=", round(min(x$details$bca$ls[, x$details$axes[y]]), 2),
          "; max=", round(max(x$details$bca$ls[, x$details$axes[y]]), 2),
          "] : dnorm (mean=", x$details$means[y], "; sd=", x$details$sds[y],
          ")", sep = "")
    })
    if (x$details$rescale)
    {
      cat("\n- Environmental suitability was rescaled between 0 and 1")
    } else
    {
      cat("\n- Environmental suitability was not rescaled between 0 and 1")
    }
  }
  if(!is.null(x$PA.conversion))
  {
    cat("\n- Converted into presence-absence:")
    cat("\n   .Method =", x$PA.conversion["conversion.method"])
    if(x$PA.conversion["conversion.method"] == "probability")
    {
      if(x$PA.conversion["probabilistic.method"] == "logistic")
      {
        cat("\n   .probabilistic method    =", x$PA.conversion["probabilistic.method"])
        cat("\n   .alpha (slope)           =", x$PA.conversion["alpha"])
        cat("\n   .beta  (inflexion point) =", x$PA.conversion["beta"])
        cat("\n   .species prevalence      =", x$PA.conversion["species.prevalence"])
      } else if(x$PA.conversion["probabilistic.method"] == "linear")
      {
        cat("\n   .probabilistic method    =", x$PA.conversion["probabilistic.method"])
        cat("\n   .a (slope)               =", x$PA.conversion["a"])
        cat("\n   .b (intercept)           =", x$PA.conversion["b"])
        cat("\n   .species prevalence      =", x$PA.conversion["species.prevalence"])
      }

    } else if(x$PA.conversion["conversion.method"] == "threshold")
    {
      cat("\n   .threshold           =", x$PA.conversion["cutoff"])
      cat("\n   .species prevalence  =", x$PA.conversion["species.prevalence"], "\n")
    }
  }
  if(!is.null(x$occupied.area))
  {
    if(!is.null(x$geographical.limit))
    {
      cat("\n- Distribution bias introduced:")
      cat("\n   .method used :", x$geographical.limit$method)
      if(x$geographical.limit$method %in% c("country", "region", "continent"))
      {
        cat("\n   .area(s)     :", x$geographical.limit$area, "\n")
      } else if(x$geographical.limit$method == "extent")
      {
        cat("\n   .extent      : [Xmin; Xmax] = [", 
            ext(x$geographical.limit$extent)[1], "; ",
            ext(x$geographical.limit$extent)[2], "] - [Ymin; Ymax] = [",
            ext(x$geographical.limit$extent)[3], "; ",
            ext(x$geographical.limit$extent)[4], "]", "\n", sep = "")
      } else if(x$geographical.limit$method == "polygon")
      {
        cat("\n   .polygon    : Object of class ", class(x$geographical.limit$area), "\n", sep = "")
      }
    }
  }
}

#' @export
#' @method str virtualspecies
str.virtualspecies <- function(object, ...)
{
  args <- list(...)
  if(is.null(args$max.level))
  {
    args$max.level <- 2
  }
  NextMethod("str", object = object, max.level = args$max.level)
}

#' @export
#' @method plot virtualspecies
plot.virtualspecies <- function(x, ...)
{
  y <- x$suitab.raster
  names(y) <- "Suitability.raster"
  if(!is.null(x$probability.of.occurrence))
  {
    y <- c(y,
           x$probability.of.occurrence)
    names(y)[[nlyr(y)]] <- "Probability.of.occurrence.raster"
  }
  if(!is.null(x$pa.raster))
  {
    y <- c(y,
               x$pa.raster)
    names(y)[[nlyr(y)]] <- "Presence.absence.raster"
  }
  if(!is.null(x$occupied.area))
  {
    y <- c(y,
               x$occupied.area)
    names(y)[[nlyr(y)]] <- "Occupied.area.raster"
  }
  x <- y
  
  defaults <- list(x = x,
                   col = rev(viridis::magma(10)))
  args <- utils::modifyList(defaults, list(...))
  do.call("plot", defaults)
}

#' @export
#' @method print VSSampledPoints
print.VSSampledPoints <- function(x, ...)
{
  # Next line is to ensure retrocompatibility with earlier versions of
  # virtualspecies where no print function was designed for VSSampledPoints
  if(!is.list(x$detection.probability))
  {
    print(x)
  } else
  {
    cat(paste("Occurrence points sampled from a virtual species"))
    cat(paste("\n\n- Type:", x$type))
    cat(paste("\n- Number of points:", nrow(x$sample.points)))
    if(length(x$bias))
    {
      cat("\n- Sampling bias: ")
      cat(paste("\n   .Bias type:", 
                x$bias$bias))
      cat(paste("\n   .Bias strength:",
                x$bias$bias.strength))
    } else
    {
      cat("\n- No sampling bias")
    }
    cat(paste0("\n- Detection probability: "))
    cat(paste0("\n   .Probability: ", x$detection.probability$detection.probability))
    cat(paste0("\n   .Corrected by suitability: ", x$detection.probability$correct.by.suitability))
    cat(paste0("\n- Probability of identification error (false positive): ", x$error.probability))
    if(length(x$sample.prevalence))
    {
      cat(paste0("\n- Sample prevalence: "))
      cat(paste0("\n   .True:", x$sample.prevalence["true.sample.prevalence"]))
      cat(paste0("\n   .Observed:", x$sample.prevalence["observed.sample.prevalence"]))
    }
    cat(paste0("\n- Multiple samples can occur in a single cell: ", 
               ifelse(x$replacement, "Yes", "No")))
    cat("\n\n")
    if(nrow(x$sample.points) > 10)
    {
      cat("First 10 lines: \n")
      print(x$sample.points[1:10, ])
      cat(paste0("... ", nrow(x$sample.points) - 10, " more lines.\n"))
    } else
    {
      print(x$sample.points)
    }
  }
}

#' @export
#' @method str VSSampledPoints
str.VSSampledPoints <- function(object, ...)
{
  args <- list(...)
  if(is.null(args$max.level))
  {
    args$max.level <- 2
  }
  NextMethod("str", object = object, max.level = args$max.level)
}