Package structure

DESCRIPTION

@@ -0,0 +1,16 @@
+Package: Moms
+Title: Measuring Occupancy of Multidimensional Spaces
+Author: Thomas Guillerme [aut, cre, cph]
+Maintainer: Thomas Guillerme <[email protected]>
+Version: 0.1
+Date: 2019-03-15
+Description: A shiny app for exploring measurements of multidimensional space occupancy (disparity).
+Depends:
+	R (>= 3.5.2),
+    dispRity
+License: GPL-3 | file LICENSE
+Suggests:
+    testthat,
+    knitr
+RoxygenNote: 6.0.1
+URL: https://github.com/TGuillerme/Moms

NAMESPACE

@@ -0,0 +1,8 @@
+#Dependencies
+import(dispRity)
+
+## Utilities
+export(plot.space)
+
+## Functions
+export(reduce.space)

R/plot.utilities.R

@@ -0,0 +1,20 @@
+#' @title Plot space
+#' @description plotting space changes
+#' @param space the space to plot (matrix)
+#' @param remove logical, the elements to remove or add (using !)
+#' @param main the title
+#' @param defaults a list of parameters for plot() and points()
+
+#' @example
+
+#' @export
+
+## Plot space function (utility shortcut)
+plot.space <- function(space, remove, main, defaults) {
+    ## Plot the first space
+    plot(space, pch = defaults$pch, xlim = defaults$xlim, ylim = defaults$ylim, col = defaults$col1,
+         main = main, xlab = defaults$xlab, ylab = defaults$ylab)
+
+    ## Plot the second space
+    points(space[remove,], pch = defaults$pch, col = defaults$col2)
+}

R/reduce.space.R

@@ -0,0 +1,119 @@
+#' @title Reduce space
+#'
+#' @description Remove a proportion of elements in a space following different types
+#'
+#' @param space the trait space
+#' @param type how to reduce the space (either \code{"random"}, \code{"limit"}, \code{"displacement"} or \code{"density"})
+#' @param remove the proportion of elements to be removed (in probability)
+#' @param parameters the parameter(s) for removal selection (see details). If left empty, the \code{parameters} is estimated to reach the amount set by \code{remove}.
+#' @param tuning Optinal parameters for tuning the parameter estimations (if remove is required and parameters is missing) a list of three parameters: "max" for the maximum of operations, "tol" for the tuning (e.g. 0.1 close) "good" for when to decide it's good enough (i.e. stop if it reaches the tuning after X number of times).
+#' @param verbose
+#' 
+#' @details
+#' - \code{limit.removal parameters}: a list of \code{parameters$centre}, the centre from which to count the radius (if missing, is set to \code{0}); and \code{parameters$radius}, the radius for removal.
+#' 
+#' - \code{displacement.removal parameters}: a list of \code{parameters$value}, value the threshold value from which to remove elements.
+#' 
+#' - \code{density.removal parameters}: a list of \code{parameters$what} "close" (default) for close neighbours or "distant" for distant ones; \code{parameters$diameter} the diameter for considering closeness or distance; \code{parameters$output} either "singles" or "pairs" to return the pairs of neighbours or one of them only (the first).
+#' 
+#' @examples
+#'
+#' @seealso
+#' 
+#' @author Thomas Guillerme
+
+reduce.space <- function(space, type, remove, parameters, tuning, verbose = FALSE) {
+
+    ## Add sanitizing
+    type_available <- c("random", "limit", "displacement", "density")   
+
+    ## Simple removal (simple)
+    if(type == "random") {
+        ## Number of elements
+        elements <- nrow(space)
+        ## Return a portion of the space
+        to_remove <- sample(1:elements, elements*remove)
+        return(1:elements %in% to_remove)
+    }
+
+    ## Tolerance
+    if(missing(tuning)) {
+        tuning <- list()
+    }
+    if(is.null(tuning$max)) {
+        tuning$max <- 100
+    }
+    if(is.null(tuning$tol)) {
+        tuning$tol <- 0.01
+    }
+    if(is.null(tuning$inc.steps)) {
+        tuning$inc.steps <- 2
+    }
+
+    ## Complex removals
+    if(missing(parameters)) {
+        parameters <- list()
+    }
+
+    ## Set parameters for specific cases
+    if(type == "limit") {
+        ## Type function
+        fun <- run.limit.removal
+        ## Parameters
+        if(is.null(parameters$centre)) {
+            parameters$centre <- rep(0, ncol(space))
+        } 
+        if(is.null(parameters$radius)) {
+            parameters$radius <- 1
+        }
+        ## Parameter to optimise
+        parameters$optimise <- parameters$radius
+        ## List of arguments
+        args <- list("space" = space, "parameters" = parameters)
+    }
+
+    if(type == "displacement") {
+        ## Type function
+        fun <- run.displacement.removal
+        ## Parameters
+        if(is.null(parameters$value)) {
+            parameters$value <- 1
+        } 
+        ## Parameter to optimise
+        parameters$optimise <- parameters$value
+    }
+
+    if(type == "density") {
+        ## Type function
+        fun <- run.density.removal
+        ## Parameters
+        if(is.null(parameters$distance)) {
+            parameters$distance <- as.matrix(dist(space))
+        }
+        if(is.null(parameters$diameter)) {
+            parameters$diameter <- 0.5
+        }  
+        ## Parameter to optimise
+        parameters$optimise <- parameters$diameter
+    }
+
+    ## List of arguments
+    args <- list("space" = space, "parameters" = parameters)
+    ## Run the complex removal
+    to_remove <- do.call(fun, args)
+
+    ## Optimise the function (if necessary)
+    if(!missing(remove)) {
+
+        ## Get out of the corner case of all being TRUE or FALSE
+        if(all(to_remove) || all(!to_remove)) {
+            args$parameters$optimise <- runif(1)
+            to_remove <- do.call(fun, args)
+        }
+
+        ## Optimise
+        to_remove <- optimise.results(to_remove, fun = fun, remove = remove, args = args, tuning = tuning, verbose = verbose, space = space)
+    }
+
+    return(to_remove)
+}

R/reduce.space_fun.R

@@ -0,0 +1,143 @@
+# ' @description Optimise a parameter selection
+# ' @param function the function to run for optimisation
+# ' @param optimise the argument to optimise
+# ' @param criterion the optimisation criterion (e.g. remove = 0.5)
+# ' @param tuning a list of three parameters: "max" for the maximum of operations, "tol" for the tuning (e.g. 0.1 close) "good" for when to decide it's good enough (i.e. stop if it reaches the tuning after X number of times).
+# ' @param parameters other parameters for the function
+# ' @param to_remove the logical list of elements to remove for automatically running the optimisation
+# ' @param remove the proportion of elements to be removed (in probability)
+# ' @param verbose
+# ' @param space
+#' 
+## Optimisation function
+optimise.parameter <- function(fun, args, criterion, tuning, verbose) {
+
+    ## Initialise the optimisation
+    counter <- 0
+    increment <- 1
+
+    ## First run
+    difference <- length(which(do.call(fun, args)))-criterion
+
+    ## Optimisation loop
+    while(difference != 0) {
+
+        ## Tolerance
+        if(abs(difference) < tuning$tol*criterion) {
+            break
+        }
+
+        ## Modify the parameter to optimise
+        args$parameters$optimise <- ifelse(difference <= 0, args$parameters$optimise + increment, args$parameters$optimise - increment)
+
+        ## Second run
+        new_difference <- length(which(do.call(fun, args))) - criterion
+
+        ## Check if the increment is to big
+        while(abs(new_difference/difference) > 1) {
+            ## Reject the optimisation
+            args$parameters$optimise <- ifelse(difference < 0, args$parameters$optimise - increment, args$parameters$optimise + increment)
+            ## And decrease the increment
+            increment <- increment/tuning$inc.steps
+            ## Update the optimisation
+            args$parameters$optimise <- ifelse(difference < 0, args$parameters$optimise + increment, args$parameters$optimise - increment)
+
+            # print(args$parameters$optimise)
+
+            ## Re-do the second run
+            new_difference <- length(which(do.call(fun, args))) - criterion
+
+            ## Increment the counter
+            if(counter < tuning$max) {
+                counter <- counter + 1
+                if(verbose) cat(".")
+            } else {
+                break
+            }
+        }
+
+        ## Update the difference
+        difference <- new_difference
+
+        ## Increment the counter
+        if(counter < tuning$max) {
+            counter <- counter + 1
+            if(verbose) cat(".")
+        } else {
+            break
+        }
+    }
+
+    ## Return the optimal parameter
+    return(args$parameters$optimise)
+}
+## Wrapping optimisation function
+optimise.results <- function(to_remove, fun, remove, args, tuning, verbose = FALSE, space) {
+
+    ## Set the optimality criterion
+    criterion <- round(remove * nrow(space))
+    ## Check if optimisation is necessary
+    if(length(which(to_remove)) != criterion) {
+
+        if(verbose) cat("Run parameter optimisation:")
+
+        ## Find the optimal parameter
+        args$parameters$optimise <- optimise.parameter(fun, args, criterion = criterion, tuning = tuning, verbose = verbose)
+
+        ## Rerun the function with the optimal parameter
+        to_remove <- do.call(fun, args)
+
+        if(verbose) cat("Done.\n")
+    }
+    return(to_remove)
+}
+
+## The different run functions
+run.limit.removal <- function(space, parameters) {
+    return(apply(space, 1, point.in.circle, centre = parameters$centre, radius = parameters$optimise))
+}
+run.displacement.removal <- function(space, parameters) {
+    return(apply(space, 1, select.value, value = parameters$optimise*-1))
+}
+run.density.removal <- function(space, parameters) {
+    close_neigbhours <- get.neigbhours(space, distance = parameters$distance, diameter = parameters$optimise)
+    return(1:nrow(space) %in% close_neigbhours)
+}
+
+
+
+# ' @description Selecting points within a circle
+# ' @param point a point in space
+# ' @param centre the centre from which to count the radius
+# ' @param radius the radius for removal
+#' 
+point.in.circle <- function(point, centre = c(0,0), radius) {
+
+    ## Measure the distance from the center
+    distance <- sqrt((centre[1]-abs(point[1]))^2 + (centre[2]-abs(point[2]))^2)
+
+    ## Results
+    return(ifelse(distance < radius, TRUE, FALSE))
+}
+
+# ' @description Select only the points above one value
+# ' @param point a point in space
+# ' @param value the threshold value
+#' 
+select.value <- function(point, value) {
+    return(ifelse(point[1] > value && point[2] > value, TRUE, FALSE))
+}
+
+# ' @description Selects pairs of nearest neighbours
+# ' @param trait_space the space
+# ' @param distance a distance matrix of the trait space
+# ' @param diameter the diameter for cosidering closeness or distance
+# '
+get.neigbhours <- function(trait_space, distance, diameter = 0.1) {
+
+    ## Get the neighbors
+    neighbors <- which(distance < diameter, arr.ind = TRUE)
+
+    ## Select the neighbors
+    return(unique(neighbors[neighbors[,1] != neighbors[,2]]))
+} 

test/testthat.R

@@ -0,0 +1,4 @@
+library(testthat)
+library(Moms)
+
+test_check("Moms", reporter = "list")

test/testthat/test-reduce.space.R

@@ -0,0 +1,77 @@
+context("reduce.space")
+
+# stop("DEBUG")
+# library(testthat)
+# library(dispRity)
+# source("../reduce.space.R")
+# source("../reduce.space_fun.R")
+
+
+
+## Test
+test_that("reduce.space works", {
+
+    ## Sanitizing
+    #expect_error(reduce.space())
+
+    set.seed(42)
+    space <- dispRity::space.maker(300, 2, distribution = rnorm)
+
+    ## Random removal, super easy
+    test <- reduce.space(space, type = "random", remove = 0.3)
+    expect_is(test, "logical")
+    expect_equal(length(test), 300)
+    expect_equal(length(which(test)), 90)
+
+    ## Limit removal
+    set.seed(1)
+    iter <- capture_output(test1 <- reduce.space(space, type = "limit", remove = 0.5, verbose = TRUE))
+    expect_is(test1, "logical")
+    expect_equal(length(test1), 300)
+    expect_equal(length(which(test1)), 150)
+    expect_equal(iter, "Run parameter optimisation:.......Done.")
+
+    set.seed(1)
+    test2 <- reduce.space(space, type = "limit", parameters = list("radius" = 1.21875))
+    expect_is(test2, "logical")
+    expect_equal(length(test2), 300)
+    expect_equal(length(which(test2)), 150)
+
+    expect_equal(test1, test2)
+
+
+    ## Displacement removal
+    set.seed(1)
+    iter <- capture_output(test1 <- reduce.space(space, type = "displacement", remove = 0.5, verbose = TRUE, tuning = list("tol" = 0)))
+    expect_is(test1, "logical")
+    expect_equal(length(test1), 300)
+    expect_equal(length(which(test1)), 150)
+    expect_equal(iter, "Run parameter optimisation:........Done.")
+
+    set.seed(1)
+    test2 <- reduce.space(space, type = "displacement", parameters = list("value" = 0.484375))
+    expect_is(test2, "logical")
+    expect_equal(length(test2), 300)
+    expect_equal(length(which(test2)), 150)
+
+    expect_equal(test1, test2)
+
+
+    ## Displacement removal
+    set.seed(1)
+    iter <- capture_output(test1 <- reduce.space(space, type = "density", remove = 0.5, verbose = TRUE))
+    expect_is(test1, "logical")
+    expect_equal(length(test1), 300)
+    expect_equal(length(which(test1)), 151)
+    expect_equal(iter, "Run parameter optimisation:............Done.")
+
+    set.seed(1)
+    test2 <- reduce.space(space, type = "density", parameters = list("diameter" = 0.1015625))
+    expect_is(test2, "logical")
+    expect_equal(length(test2), 300)
+    expect_equal(length(which(test2)), 151)
+
+    expect_equal(test1, test2)
+
+
+})