Merge f23f24a into a172814

NAMESPACE

@@ -11,6 +11,7 @@ export("%>%")
 export("cutoff<-")
 export("distalgo<-")
 export("distargs<-")
+export("distenv<-")
 export("distname<-")
 export("mlg.filter<-")
 export("mll.custom<-")
@@ -35,6 +36,7 @@ export(cutoff_predictor)
 export(diss.dist)
 export(distalgo)
 export(distargs)
+export(distenv)
 export(distname)
 export(diversity_boot)
 export(diversity_ci)

NEWS.md

@@ -18,6 +18,12 @@ MISC
   function with the out-of-scope operator (`<<-`) (see #205)
 * `shufflepop()` is now safer as it now uses a for loop instead of a
   function with the out-of-scope operator (`<<-`) (see #205)
+* The MLG class gains a new `distenv` slot, which will store the environment
+  where the distance function or matrix exists. This is accompanied by an 
+  accessor of the same name (see #206).
+* `"mlg.filter<-"()` replacement methods will no longer search the global
+  environment when evaluating the distance function or matrix (see #206).
+* Tests for `mlg.filter()` no longer assign objects to the global environment
 
 
 poppr 2.8.2

R/aaaMLGclass.R

@@ -58,6 +58,7 @@ setClassUnion("charORLang", c("character", "language"))
 #'   accessed.
 #' @slot distname the name of the distance function or matrix used to collapse 
 #'   mlgs.
+#' @slot distenv the environment that contains the distance function or matrix
 #' @slot distargs the arguments provided to compute the distance function.
 #' @slot distalgo the algorithm used to contract multilocus genotypes.
 #' @slot cutoff Two numbers specifying the cutoff value for expanding and 
@@ -97,12 +98,14 @@ setClass("MLG",
          representation(visible = "character",
                         cutoff = "numeric",
                         distname = "charORLang",
+                        distenv  = "environment",
                         distargs = "list",
                         distalgo = "character",
                         mlg = "data.frame"),
          prototype(visible = character(0), 
                    cutoff = numeric(0), 
                    distname = character(0), 
+                   distenv = as.environment(.GlobalEnv),
                    distargs = list(),
                    distalgo = "farthest_neighbor", 
                    mlg = data.frame(expanded = numeric(0), 
@@ -111,4 +114,4 @@ setClass("MLG",
                                     custom = factor(character(0))
                                     )
                    )
-         )
+         )

R/aaaMLGmethods.R

@@ -91,6 +91,7 @@ setMethod(
     slot(.Object, "mlg")      <- mlg
     slot(.Object, "visible")  <- "original"
     slot(.Object, "distname") <- "diss.dist"
+    slot(.Object, "distenv")  <- .GlobalEnv
     slot(.Object, "distargs") <- list()
     slot(.Object, "distalgo") <- "farthest_neighbor"
     return(.Object)
@@ -444,6 +445,22 @@ setMethod(
     x@distname
   })
 
+#==============================================================================#
+#' @rdname MLG-accessors
+#' @aliases distenv,MLG-method
+#' @export
+#==============================================================================#
+setGeneric("distenv", function(x) {
+  standardGeneric("distenv")
+})
+
+setMethod(
+  f = "distenv", 
+  signature(x = "MLG"), 
+  definition = function(x) {
+    x@distenv
+  })
+
 #==============================================================================#
 #' @rdname MLG-accessors
 #' @aliases distname<-,MLG-method
@@ -461,6 +478,23 @@ setMethod(
     return(x)
   })
 
+#==============================================================================#
+#' @rdname MLG-accessors
+#' @aliases distenv<-,MLG-method
+#' @export
+#==============================================================================#
+setGeneric("distenv<-", function(x, value) {
+  standardGeneric("distenv<-")
+})
+
+setMethod(
+  f = "distenv<-", 
+  signature(x = "MLG"), 
+  definition = function(x, value) {
+    x@distenv <- value
+    return(x)
+  })
+
 #==============================================================================#
 #' @rdname MLG-accessors
 #' @aliases distargs,MLG-method
@@ -560,4 +594,4 @@ setMethod(
   definition = function(x, value) {
     x@cutoff <- value
     return(x)
-  })
+  })

R/internal_methods.R

@@ -220,7 +220,8 @@ mll.levels.internal <- function(x, set = TRUE, value){
 #==============================================================================#
 mlg.filter.internal <- function(gid, threshold = 0.0, missing = "asis", 
                                 memory = FALSE, algorithm = "farthest_neighbor", 
-                                distance = "diss.dist", threads = 1L, 
+                                distance = "diss.dist", denv = .GlobalEnv,
+                                threads = 1L, 
                                 stats = "MLGs", the_call = match.call(), ...){
 
   if (threads != 1L){
@@ -229,17 +230,20 @@ mlg.filter.internal <- function(gid, threshold = 0.0, missing = "asis",
   }
   # This will return a vector indicating the multilocus genotypes after applying
   # a minimum required distance threshold between multilocus genotypes.
-  if (is.character(distance) || is.function(distance)) {
+  dist_is_fun <- is.function(distance)
+  if (is.character(distance) || dist_is_fun) {
     if (memory==TRUE && identical(c(gid, distance, ...), .last.value.param$get())){
       dis <- .last.value.dist$get()
     } else {
       if (is.genind(gid)) {
-        the_dist <- as.character(the_call[["distance"]])
+        the_dist <- if (!dist_is_fun) as.character(the_call[["distance"]])
         call_len <- length(the_dist)
         is_diss_dist <- the_dist %in% "diss.dist"
-        any_dist <- the_dist %in% c("diss.dist", "nei.dist", "prevosti.dist",
-                                    "edwards.dist", "reynolds.dist", 
-                                    "rogers.dist", "provesti.dist")
+
+        dists <- c("diss.dist", "nei.dist", "prevosti.dist", "edwards.dist",
+                   "reynolds.dist", "rogers.dist", "provesti.dist")
+        any_dist <- the_dist %in% dists
+
         if (missing == "mean" && call_len == 1 && is_diss_dist){
           disswarn <- paste("Cannot use function diss.dist and correct for", 
                             "mean values.", "diss.dist will automatically",
@@ -255,7 +259,8 @@ mlg.filter.internal <- function(gid, threshold = 0.0, missing = "asis",
       } else {
         mpop <- gid
       }
-      DISTFUN <- match.fun(distance)
+      # browser()
+      DISTFUN <- if (!is.function(distance)) get(distance, envir = denv) else distance
       dis <- DISTFUN(mpop, ...)
       dis <- as.matrix(dis)
       if (memory == TRUE)
@@ -322,6 +327,7 @@ mlg.filter.internal <- function(gid, threshold = 0.0, missing = "asis",
     stop("Threshold must be a numeric or integer value", .call = FALSE)
   } 
     # Stats must be logical
+  # browser()
   STATARGS <- c("MLGS", "THRESHOLDS", "DISTANCES", "SIZES", "ALL")
   stats <- match.arg(toupper(stats), STATARGS, several.ok = TRUE)