Skip to content

Commit

Permalink
Moved 3 taxmap funcs to taxonomy
Browse files Browse the repository at this point in the history 
Added warnings if taxmap options are used with taxonomy objects

resolves #47
  • Loading branch information
@zachary-foster
zachary-foster committed May 24, 2017
1 parent 3959789 commit ce14332
Show file tree
Hide file tree
Showing 12 changed files with 487 additions and 521 deletions.
6 changes: 3 additions & 3 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ S3method(all_names,Taxonomy)
S3method(all_names,default)
S3method(arrange_obs,Taxmap)
S3method(arrange_obs,default)
S3method(arrange_taxa,Taxmap)
S3method(arrange_taxa,Taxonomy)
S3method(arrange_taxa,default)
S3method(data_used,Taxonomy)
S3method(data_used,default)
Expand Down Expand Up @@ -44,11 +44,11 @@ S3method(roots,Taxonomy)
S3method(roots,default)
S3method(sample_frac_obs,Taxmap)
S3method(sample_frac_obs,default)
S3method(sample_frac_taxa,Taxmap)
S3method(sample_frac_taxa,Taxonomy)
S3method(sample_frac_taxa,default)
S3method(sample_n_obs,Taxmap)
S3method(sample_n_obs,default)
S3method(sample_n_taxa,Taxmap)
S3method(sample_n_taxa,Taxonomy)
S3method(sample_n_taxa,default)
S3method(select_obs,Taxmap)
S3method(select_obs,default)
Expand Down
204 changes: 0 additions & 204 deletions R/taxmap--class.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -165,143 +165,6 @@ Taxmap <- R6::R6Class(
return(output)
},

filter_taxa = function(..., subtaxa = FALSE, supertaxa = FALSE,
taxonless = FALSE, reassign_obs = TRUE,
reassign_taxa = TRUE, invert = FALSE) {

# non-standard argument evaluation
selection <- lazyeval::lazy_eval(lazyeval::lazy_dots(...),
data = self$data_used(...))

# convert taxon_ids to logical
is_char <- vapply(selection, is.character, logical(1))
selection[is_char] <- lapply(selection[is_char],
function(x) self$taxon_ids() %in% x)

# convert indexes to logical
is_index <- vapply(selection, is.numeric, logical(1))
selection[is_index] <- lapply(selection[is_index],
function(x) 1:nrow(self$edge_list) %in% x)

# combine filters
selection <- Reduce(`&`, selection)

# default to all taxa if no selection is provided
if (is.null(selection)) {
selection <- rep(TRUE, length(self$taxon_ids()))
}

# Get taxa of subset
if (is.logical(subtaxa) && subtaxa == FALSE) {
subtaxa = 0
}
if (is.logical(supertaxa) && supertaxa == FALSE) {
supertaxa = 0
}
taxa_subset <- unique(c(which(selection),
self$subtaxa(subset = selection,
recursive = subtaxa,
return_type = "index",
include_input = FALSE,
simplify = TRUE),
self$supertaxa(subset = selection,
recursive = supertaxa,
return_type = "index",
na = FALSE, simplify = TRUE,
include_input = FALSE)
))

# Invert selection
if (invert) {
taxa_subset <- (1:nrow(self$edge_list))[-taxa_subset]
}

# Reassign taxonless observations
reassign_obs <- parse_possibly_named_logical(
reassign_obs,
self$data,
default = formals(self$filter_taxa)$reassign_obs
)
process_one <- function(data_index) {

reassign_one <- function(parents) {
included_parents <- parents[parents %in% taxa_subset]
return(self$taxon_ids()[included_parents[1]])
}

# Get the taxon ids of the current object
if (is.null((data_taxon_ids <-
get_data_taxon_ids(self$data[[data_index]])))) {
return(NULL) # if there is no taxon id info, dont change anything
}

# Generate replacement taxon ids
to_reassign <- ! data_taxon_ids %in% self$taxon_ids()[taxa_subset]
supertaxa_key <- self$supertaxa(
subset = unique(data_taxon_ids[to_reassign]),
recursive = TRUE, simplify = FALSE, include_input = FALSE,
return_type = "index", na = FALSE
)
reassign_key <- vapply(supertaxa_key, reassign_one, character(1))
new_data_taxon_ids <- reassign_key[data_taxon_ids[to_reassign]]

# Replace taxon ids
if (is.data.frame(self$data[[data_index]])) {
self$data[[data_index]][to_reassign, "taxon_id"] <- new_data_taxon_ids
} else {
names(self$data[[data_index]])[to_reassign] <- new_data_taxon_ids
}
}

unused_output <- lapply(seq_along(self$data)[reassign_obs], process_one)

# Reassign subtaxa
if (reassign_taxa) {
reassign_one <- function(parents) {
included_parents <- parents[parents %in% taxa_subset]
return(self$taxon_ids()[included_parents[1]])
}

to_reassign <- ! self$edge_list$from %in% self$taxon_ids()[taxa_subset]
supertaxa_key <- self$supertaxa(
subset = unique(self$taxon_ids()[to_reassign]),
recursive = TRUE, simplify = FALSE, include_input = FALSE,
return_type = "index", na = FALSE)
reassign_key <- vapply(supertaxa_key, reassign_one, character(1)
)
self$edge_list[to_reassign, "from"] <-
reassign_key[self$taxon_ids()[to_reassign]]
}


# Remove taxonless observations
taxonless <- parse_possibly_named_logical(
taxonless,
self$data,
default = formals(self$filter_taxa)$taxonless
)
process_one <- function(my_index) {

# Get the taxon ids of the current object
if (is.null((data_taxon_ids <-
get_data_taxon_ids(self$data[[my_index]])))) {
return(NULL) # if there is no taxon id info, dont change anything
}

obs_subset <- data_taxon_ids %in% self$taxon_ids()[taxa_subset]
private$remove_obs(dataset = my_index,
indexes = obs_subset,
unname_only = taxonless[my_index])
}
unused_output <- lapply(seq_along(self$data), process_one)


# Remove filtered taxa
private$remove_taxa(taxa_subset)

return(self)
},


filter_obs = function(target, ..., unobserved = TRUE) {
# Check that the target data exists
Expand Down Expand Up @@ -448,20 +311,6 @@ Taxmap <- R6::R6Class(
return(self)
},

arrange_taxa = function(...) {
data_used <- self$data_used(...)
data_used <- data_used[! names(data_used) %in% names(self$edge_list)]
if (length(data_used) == 0) {
self$edge_list <- dplyr::arrange(self$edge_list, ...)
} else {
target_with_extra_cols <- dplyr::bind_cols(data_used, self$edge_list)
self$edge_list <-
dplyr::arrange(target_with_extra_cols, ...)[, -seq_along(data_used)]
}

return(self)
},


sample_n_obs = function(target, size, replace = FALSE, taxon_weight = NULL,
obs_weight = NULL, use_supertaxa = TRUE,
Expand Down Expand Up @@ -539,59 +388,6 @@ Taxmap <- R6::R6Class(
collapse_func = collapse_func, ...)
},

sample_n_taxa = function(size, taxon_weight = NULL, obs_weight = NULL,
obs_target = NULL, use_subtaxa = TRUE,
collapse_func = mean, ...) {
# non-standard argument evaluation
data_used <- eval(substitute(self$data_used(taxon_weight, obs_weight)))
taxon_weight <- lazyeval::lazy_eval(lazyeval::lazy(taxon_weight),
data = data_used)
obs_weight <- lazyeval::lazy_eval(lazyeval::lazy(obs_weight),
data = data_used)

# Calculate observation component of taxon weights
if (is.null(obs_weight)) {
taxon_obs_weight <- rep(1, nrow(self$edge_list))
} else {
if (is.null(obs_target)) {
stop(paste("If the option `obs_weight` is used, then `obs_target`",
"must also be defined."))
}
my_obs <- self$obs(obs_target, recursive = use_subtaxa,
simplify = FALSE)
taxon_obs_weight <- vapply(my_obs,
function(x) collapse_func(obs_weight[x]),
numeric(1))
}
taxon_obs_weight <- taxon_obs_weight / sum(taxon_obs_weight)

# Calculate taxon component of taxon weights
if (is.null(taxon_weight)) {
taxon_weight <- rep(1, nrow(self$edge_list))
}
taxon_weight <- taxon_weight / sum(taxon_weight)

# Combine observation and taxon weight components
combine_func <- prod
weight <- mapply(taxon_weight, taxon_obs_weight,
FUN = function(x, y) combine_func(c(x,y)))
weight <- weight / sum(weight)

# Sample observations
sampled_rows <- sample.int(nrow(self$edge_list), size = size,
replace = FALSE, prob = weight)
self$filter_taxa(sampled_rows, ...)
},

sample_frac_taxa = function(size = 1, taxon_weight = NULL,
obs_weight = NULL, obs_target = NULL,
use_subtaxa = TRUE, collapse_func = mean, ...) {
self$sample_n_taxa(size = size * nrow(self$edge_list),
taxon_weight = taxon_weight,
obs_weight = obs_weight, obs_target = obs_target,
use_subtaxa = use_subtaxa,
collapse_func = collapse_func, ...)
},

n_obs = function(target) {
vapply(self$obs(target, recursive = TRUE, simplify = FALSE),
Expand Down
Loading

0 comments on commit ce14332

Please sign in to comment.