1reduction <- 2function(x, operation, ...) 3 UseMethod("reduction") 4 5reduction.default <- 6function(x, operation, ...) 7 stop("Not implemented.") 8 9reduction.set <- 10function(x, operation = c("union", "intersection"), ...) 11{ 12 operation <- match.arg(operation) 13 if (length(x) < 2L) return(x) 14 if (!all(sapply(x, is.cset))) 15 stop("reduction only defined on set of (c,g)sets.") 16 17 if (all(sapply(x, is.set))) { 18 19 dom <- .as.list(do.call(set_union, x)) 20 x <- lapply(x, .make_list_elements) 21 22 members <- 23 binary_reduction(do.call(rbind, lapply(x, function(i) dom %in% i)), 24 operation) 25 26 .make_set_from_list(.list_sort(apply(members, 1L, 27 function(i) .make_set_from_list(dom[i]) 28 ) 29 ) 30 ) 31 } else if (all(sapply(x, is.gset))) { 32 clo <- closure(x, operation) 33 FUN <- function(e) 34 !isTRUE(gset_is_equal(closure(gset_difference(x, set(e)), 35 operation), clo)) 36 as.set(Filter(FUN, .as.list(x))) 37 } else { 38 clo <- closure(x, operation) 39 FUN <- function(e) 40 !isTRUE(cset_is_equal(closure(cset_difference(x, set(e)), 41 operation), clo)) 42 as.set(Filter(FUN, .as.list(x))) 43 } 44} 45 46binary_reduction <- 47function(x, operation = c("union", "intersection")) 48 .Call(sets_reduction, x, 49 pmatch(match.arg(operation), c("union", "intersection"))) 50