v 9.1.0

Author: peekxc

DESCRIPTION

@@ -9,7 +9,6 @@ Maintainer: Matt Piekenbrock <[email protected]>
 Description: An efficient implementation of the Mapper algorithm, and other related algorithms and tools used in Topological Data Analysis. 
 Imports: R6, Rcpp, stats, methods
 LinkingTo: Rcpp, simplextree
-RcppModules: segment_tree_module, union_find_module
 License: file LICENSE
 BugReports: https://github.com/peekxc/mapper
 Suggests: 

NAMESPACE

@@ -7,10 +7,7 @@ export(AdaptiveCover)
 export(BallCover)
 export(CoverRef)
 export(FixedIntervalCover)
-export(MapperDataInput)
-export(MapperFilterInput)
 export(MapperRef)
-export(MapperVis)
 export(RestrainedIntervalCover)
 export(SubspaceCover)
 export(bin_color)
@@ -21,14 +18,11 @@ export(gromov_hausdorff)
 export(hausdorff_distance)
 export(landmarks)
 export(mapper)
-export(multiscale)
 export(segment_tree)
-export(thd)
 export(union_find)
 import(Rcpp)
 import(methods)
 import(modules)
-import(shiny)
 import(simplextree)
 importFrom(Rcpp,Module)
 importFrom(Rcpp,cpp_object_initializer)

NEWS.md

@@ -1,7 +1,12 @@
 
+# Mapper 0.9.1
+- Moved filter aspect from cover to MapperRef class, added 9 popular filter functions and a 'use_filter' API
+- Nerve computation can now construct arbitrary dimensional simplicial complexes
+- Removed grapher visualization method, added pixiplex as a replacement
+
 # Mapper 0.9.0
 - Added many API-breaking changes, including: 
-- (1) Changed field name 'ls_vertex_map' to pullback
+- (1) Changed field name 'ls\_vertex\_map' to pullback to match theory more correctly
 - (2) Changed name of 'rectangular'-type covers to 'interval'
 - (3) Added ability to construct individual subsets of the cover via 'pullback' method
 - Added first vignette describing application of Mapper for Shape Comparison 

R/CoverRef.R

@@ -14,47 +14,36 @@
 #' \itemize{
 #'  \item{\emph{.level_sets}}{ named list, indexed by \code{.index_set}, whose values represent indices in the original data set to cluster over.}
 #'  \item{\emph{.index_set}}{ character vector of keys that uniquely index the level sets.}
-#'  \item{\emph{.filter_dim}}{ constant representing the filter dimension.}
-#'  \item{\emph{.filter_size}}{ constant representing the number of points in the filter space.}
 #'  \item{\emph{.typename}}{ unique string identifier of the covering method.}
 #' }
-#'  
 #'    
 #' @docType class
-#' @field filter_values (n x d) matrix of filter values
 #' @field typename Unique string identifier for the covering. 
 #' @field index_set character vector used to index the 'level_sets' list 
-#' @field level_sets list of the 
+#' @field level_sets list of the point in the preimages of the sets comprising the cover, indexed by the index set
 #' @format An \code{\link{R6Class}} generator object
 #' 
 #' @method level_sets_to_compare testing
 #' 
 #' @author Matt Piekenbrock
 #' @export CoverRef
 CoverRef <- R6::R6Class("CoverRef", 
-  public = list(filter_values=NA),
   private = list(
     .level_sets = NA,
-    .index_set = NA,
-    .filter_size = NA,
-    .filter_dim = NA, 
+    .index_set = NA, 
     .typename = character(0)
   ), 
   lock_class = FALSE,  ## Feel free to add your own members
   lock_objects = FALSE ## Or change existing ones 
 )
 
 ## Cover initialization
-CoverRef$set("public", "initialize", function(filter_values, typename){
-  if (is.null(dim(filter_values))) { filter_values <- array(filter_values, dim = c(length(filter_values), 1)) }
-  self$filter_values <- filter_values
-  private$.filter_size <- dim(filter_values)[[1]]
-  private$.filter_dim <- dim(filter_values)[[2]]
+CoverRef$set("public", "initialize", function(typename){
   private$.typename <- typename
 })
 
 CoverRef$set("public", "format", function(...){
-  message <- c(sprintf("Open cover for %d objects (d = %d)", nrow(self$filter_values), private$.filter_dim))
+  # message <- c(sprintf("Open cover for %d objects (d = %d)", nrow(self$filter_values), private$.filter_dim))
   return(message)
 })
 
@@ -124,9 +113,9 @@ CoverRef$set("public", "validate", function(){
     stop("Cover invalid: Not all the level sets have a corresponding index in the index set.")
   }
   idx <- unique(unlist(private$.level_sets))
-  if ( length(idx) != private$.filter_size ){
-    stop("Cover invalid: Not all point indices account for in the open sets!")
-  }
+  # if ( length(idx) != private$.filter_size ){
+  #   stop("Cover invalid: Not all point indices account for in the open sets!")
+  # }
 })
 
 # TODO

R/FixedIntervalCover.R

@@ -20,21 +20,20 @@ FixedIntervalCover <- R6::R6Class("FixedIntervalCover",
 )
 
 #' @export
-FixedIntervalCover$set("public", "initialize", function(filter_values, ...){
-  super$initialize(filter_values, typename="Fixed Interval")
+FixedIntervalCover$set("public", "initialize", function(...){
+  super$initialize(typename="Fixed Interval")
   params <- list(...)
   if ("number_intervals" %in% names(params)){ self$number_intervals <- params[["number_intervals"]] }
   if ("percent_overlap" %in% names(params)){ self$percent_overlap <- params[["percent_overlap"]] }
 })
 
 ## Set overlap/gain threshold
+## percent_overlap ----
 FixedIntervalCover$set("active", "percent_overlap",
   function(value){
     if (missing(value)){ private$.percent_overlap }
     else {
       if (any(value < 0) || any(value >= 100)){ stop("The percent overlap must be a percentage between [0, 100).") }
-      if (length(value) != private$.filter_dim && length(value) != 1){ stop("The percent overlap must be a single scalar or a vector of scalars with length equal to the dimensionality of the filter space.") }
-      if (length(value) == 1 && private$.filter_dim > 1){ value <- rep(value, private$.filter_dim) } ## create a vector
       private$.percent_overlap <- value
       self
     }
@@ -44,19 +43,36 @@ FixedIntervalCover$set("active", "percent_overlap",
 ## Active binding to set the number of intervals to distribute along each dimension. 
 ## By default, if a scalar is given and the filter dimensionality is > 1, the scalar is 
 ## repeated along each dimension. 
+## number_intervals ----
 FixedIntervalCover$set("active", "number_intervals", 
   function(value){
     if (missing(value)){ private$.number_intervals }
     else {
-      if (length(value) == 1 && private$.filter_dim > 1){ value <- rep(value, private$.filter_dim) } ## create a vector
       stopifnot(all(value > 0))
-      stopifnot(length(value) == private$.filter_dim)
       private$.number_intervals <- value
       self
     }
   }
 )
 
+## Validates the parameter settings
+## validate ----
+FixedIntervalCover$set("public", "validate", function(filter){
+  stopifnot(!is.na(private$.percent_overlap))
+  stopifnot(!is.na(private$.number_intervals))
+  stopifnot(all(self$number_intervals > 0))
+  stopifnot(all(self$percent_overlap >= 0), all(self$percent_overlap < 100))
+  fv <- filter()
+  f_dim <- ncol(fv)
+  if (length(self$number_intervals) == 1 && f_dim > 1){
+    self$number_intervals <- rep(self$number_intervals[1], f_dim)
+  }
+  if (length(self$percent_overlap) == 1 && f_dim > 1){
+    self$percent_overlap <- rep(self$percent_overlap[1], f_dim)
+  }
+})
+
+## format ----
 FixedIntervalCover$set("public", "format", function(...){
   # type_pretty <- paste0(toupper(substr(self$typename, start = 1, stop = 1)), tolower(substr(self$typename, start = 2, stop = nchar(self$typename))))
   sprintf("Cover: (typename = %s, number intervals = [%s], percent overlap = [%s]%%)",
@@ -66,12 +82,13 @@ FixedIntervalCover$set("public", "format", function(...){
 })
 
 ## This function is specific to the interval-type covers
-FixedIntervalCover$set("public", "interval_bounds", function(index=NULL){
-  stopifnot(!is.na(private$.percent_overlap))
-  stopifnot(!is.na(private$.number_intervals))
- 
+## interval_bounds ----
+FixedIntervalCover$set("public", "interval_bounds", function(filter, index=NULL){
+  self$validate(filter)
+  
   ## Get filter min and max ranges
-  filter_rng <- apply(self$filter_values, 2, range)
+  fv <- filter()
+  filter_rng <- apply(fv, 2, range)
   { filter_min <- filter_rng[1,]; filter_max <- filter_rng[2,] }
   filter_len <- diff(filter_rng)
 
@@ -98,15 +115,20 @@ FixedIntervalCover$set("public", "interval_bounds", function(index=NULL){
 })
 
 ## Setup a valid index set (via cartesian product)
+## construct_index_set ----
 FixedIntervalCover$set("public", "construct_index_set", function(...){
   cart_prod <- arrayInd(seq(prod(self$number_intervals)), .dim = self$number_intervals)
   self$index_set <- apply(cart_prod, 1, function(x){ sprintf("(%s)", paste0(x, collapse = " ")) })
 })
 
 ## Given the current set of parameter values, construct the level sets whose union covers the filter space
-FixedIntervalCover$set("public", "construct_cover", function(index=NULL){
-  stopifnot(!is.na(private$.percent_overlap))
-  stopifnot(!is.na(private$.number_intervals))
+## construct_cover ----
+FixedIntervalCover$set("public", "construct_cover", function(filter, index=NULL){
+  self$validate(filter)
+  
+  ## Get filter values 
+  fv <- filter()
+  f_dim <- ncol(fv)
 
   ## If the index set hasn't been made yet, construct it.
   if (any(is.na(self$index_set))){ self$construct_index_set() }
@@ -115,34 +137,36 @@ FixedIntervalCover$set("public", "construct_cover", function(index=NULL){
   ## If no index specified, return the level sets either by construction
   if (missing(index) || is.null(index)){
     stopifnot(!index %in% self$index_set)
-    set_bnds <- self$interval_bounds()
-    self$level_sets <- constructIsoAlignedLevelSets(self$filter_values, as.matrix(set_bnds))
+    set_bnds <- self$interval_bounds(filter)
+    self$level_sets <- constructIsoAlignedLevelSets(fv, as.matrix(set_bnds))
     return(invisible(self)) ## return invisibly 
   } else {
     if (!is.na(self$level_sets) && index %in% names(self$level_sets)){
       return(self$level_sets[[index]])
     } else {
       p_idx <- which(index == self$index_set)
-      set_bnds <- self$interval_bounds(index)
-      level_set <- constructIsoAlignedLevelSets(self$filter_values, set_bnds)
+      set_bnds <- self$interval_bounds(filter, index)
+      level_set <- constructIsoAlignedLevelSets(fv, set_bnds)
       return(level_set)
     }
   }
 })
 
 ## Constructs a 'neighborhood', which is an (n x k+1) subset of pullback ids representing 
 ## the set of n unique (k+1)-fold intersections are required to construct the nerve. 
-FixedIntervalCover$set("public", "neighborhood", function(k){
+## neighborhood ----
+FixedIntervalCover$set("public", "neighborhood", function(filter, k){
   stopifnot(!is.na(private$.index_set))
+  fv <- filter()
   if (k == 1){
     all_pairs <- t(combn(1L:length(private$.index_set), 2))
     multi_index <- arrayInd(seq(prod(self$number_intervals)), .dim = self$number_intervals)
 
     ## Get filter min and max ranges
-    filter_rng <- apply(self$filter_values, 2, range)
+    filter_rng <- apply(fv, 2, range)
     { filter_min <- filter_rng[1,]; filter_max <- filter_rng[2,] }
     filter_len <- diff(filter_rng)
-    d_rng <- 1:ncol(self$filter_values)
+    d_rng <- 1:ncol(fv)
 
     ## Compute the critical distances that determine which pairwise combinations to compare
     base_interval_length <- filter_len/self$number_intervals
@@ -169,9 +193,10 @@ FixedIntervalCover$set("public", "neighborhood", function(k){
 })
 
 ## Converts percent overlap to interval length for a fixed number of intervals
-FixedIntervalCover$set("public", "overlap_to_interval_len", function(percent_overlap){
+FixedIntervalCover$set("public", "overlap_to_interval_len", function(filter, percent_overlap){
   stopifnot(all(is.numeric(self$number_intervals)))
-  filter_rng <- apply(self$filter_values, 2, range)
+  fv <- filter()
+  filter_rng <- apply(fv, 2, range)
   { filter_min <- filter_rng[1,]; filter_max <- filter_rng[2,] }
   filter_len <- diff(filter_rng)
   base_interval_length <- filter_len/self$number_intervals
@@ -180,9 +205,10 @@ FixedIntervalCover$set("public", "overlap_to_interval_len", function(percent_ove
 })
 
 ## Converts interval length to percent overlap for a fixed number of intervals
-FixedIntervalCover$set("public", "interval_len_to_percent_overlap", function(interval_len){
+FixedIntervalCover$set("public", "interval_len_to_percent_overlap", function(filter, interval_len){
   stopifnot(all(is.numeric(self$number_intervals)))
-  filter_rng <- apply(self$filter_values, 2, range)
+  fv <- filter()
+  filter_rng <- apply(fv, 2, range)
   { filter_min <- filter_rng[1,]; filter_max <- filter_rng[2,] }
   filter_len <- diff(filter_rng)
   base_interval_length <- filter_len/self$number_intervals

R/Mapper-package.r

@@ -10,12 +10,7 @@
 #' @docType package
 NULL
 
-#' MapperVis
-#' @description 'MapperVis' is a \code{\link[modules]{module}} containing \code{\link[shiny::callModule]{shiny modules}}
-#' that simplify making shiny applications with Mapper.
-#' @import modules
-#' @export
-MapperVis <- modules::use(file.path("R", "shiny_modules.R"))
+# <- modules::use(file.path("R", "shiny_modules.R"))
 
 #' bin_color
 #' @param x A numeric vector whose magnitudes should be binned onto the color palette. 
@@ -25,13 +20,14 @@ MapperVis <- modules::use(file.path("R", "shiny_modules.R"))
 #' @details Given a numeric vector \code{x}, bins the values from low to high on a given color gradient. 
 #' Defaults to the reversed rainbow gradient, where blue == low, red == high.
 #' @export
-bin_color <- function(x, col_pal = "rainbow", 
-                     output_format = c("hex9", "hex7")){
+bin_color <- function(x, col_pal = "rainbow", output_format = c("hex9", "hex7")){
   if (missing(col_pal) || col_pal == "rainbow"){ col_pal <- rev(grDevices::rainbow(100L, start = 0, end = 4/6)) }
   col_res <- length(col_pal)
   binned_idx <- cut(x, breaks = col_res, labels = FALSE)
   binned_colors <- col_pal[binned_idx]
   if (missing(output_format) || output_format == "hex9"){ return(binned_colors) }
   else if (output_format == "hex7"){ return(substr(binned_colors, start = 0L, stop = 7L)) }
   else { stop("'output_format' must be one of 'hex9' or 'hex7'.") }
-}
+}
+
+.filters_available <- c("PC", "IC", "ECC", "KDE", "DTM", "MDS", "ISOMAP", "LE", "UMAP")