R/api_setops.R

Defines functions names2pairs .all_subsets .all_subsets0 subsetof is.subsetof .isin is_inset remove_redundant minimal_sets maximal_sets

Documented in is_inset is.subsetof maximal_sets minimal_sets names2pairs remove_redundant subsetof

## #############################################################
##
#' @title Suite of set operations
#' @description Set operations for gRbase and related packages.
#' @name set-operations
#' @author Søren Højsgaard, \email{sorenh@@math.aau.dk}
##
## #############################################################
#' 
#' @param x,set,set2 Vector representing a set.
#' @param setlist List of vectors (representing a set of subsets)
#' @param maximal Logical; see section 'Details' for a description.
#' @param all Logical; see section 'Details' for a description.
#' @param index Logical; should indices (in setlist) be returned or a
#'     set of subsets.
#'
#' @details
#'
#'  'setlist' is a list of vectors representing a set of subsets;
#'  i.e. V1,...VQ where Vk is a subset of some base set V.
#'
#'  'all' If true, \code{get_superset} will return index of all
#'  vectors containing the element; otherwise only the first index is
#'  returned.
#'
#'  \code{is_inset}: Checks if the set
#'  x is in one of the Vk's.
#'
#'  \code{remove_redundant}: Returns those Vk which are not contained
#'  in other subsets; i.e. gives the maximal sets. If maximal is FALSE
#'  then returns the minimal sets; i.e. Vk is returned if Vk is
#'  contained in one of the other sets Vl and there are no set Vn
#'  contained in Vk.
#'  
#'  Notice that the comparisons are made by turning the elements into
#'  characters and then comparing these. Hence 1 is identical to "1".
#'
#' @examples
#'
#' set <- list(c(1, 2), c(1, 2, 3), c(2, 3, 6), c(2, 4), c(5, 6), 5)            
#'                                                             
#' el1 <- c(2, 1)                                               
#' el2 <- c(2, 3)                                               
#' el3 <- c(4, 3)                                               
#' el4 <- c(2, 1, 3)                                             
#'                                                             
#' maximal_sets(set)                                           
#' minimal_sets(set)                                           
#'                                                             
#' remove_redundant(set)                                       
#' remove_redundant(set, maximal=FALSE)                        
#'                                                             
#' is_inset(el1, set)                                          
#' is_inset(el2, set)                                          
#' is_inset(el3, set)                                          
#'                                                             
#' get_subset(el1, set)
#' get_subset(el1, set)                                        
#' get_subset(el2, set)                                        
#' get_subset(el3, set)                                        
#'
#' get_superset(el1, set)                                      
#' get_superset(el1, set, all=TRUE)                                      
#' get_superset(el2, set)                                      
#' get_superset(el3, set)
#' 
#' is_subsetof(el1, el1)                                       
#' is_subsetof(el1, el2)                                       
#' is_subsetof(el1, el4)
#' 


#' @export
#' @rdname set-operations
maximal_sets <- function(setlist, index=FALSE){
    max_set_(setlist, index=index)
}

#' @export
#' @rdname set-operations
minimal_sets <- function(setlist, index=FALSE){
    min_set_(setlist, index=index)
}

## A function to remove redundant generators.  If maximal=T, returns
## the maximal generators, if =F, the minimal generators.
## Can be speeded up if the as.character part can be avoided...

#' @export
#' @rdname set-operations
remove_redundant <- function(setlist, maximal=TRUE, index=FALSE){
  if (maximal) maximal_sets(setlist, index)
  else minimal_sets(setlist, index)
}

## Is x contained in any vector in setlist;
#' @export
#' @rdname set-operations
is_inset <- function(x, setlist, index=FALSE){
  .isin(setlist, x, index)
}

.isin <- function(setlist, x, index=FALSE){
    isin_(setlist, x, index=index)
}





#' @export
#' @rdname set-operations
get_subset <- get_subset_

#' @export
#' @rdname set-operations
get_superset <- get_superset_

#' @export
#' @rdname set-operations
is_subsetof <- is_subsetof_

## FIXME: is.subsetof : Use Rcpp implementation

#' @export
#' @rdname set-operations
is.subsetof <- function(x, set){
  all(match(x, set) > 0)
}

## grain/grim uses subsetof; handles NULL arguments
## FIXME: Clean subsetof-functions

#' @export
#' @rdname set-operations
subsetof <- function(x, set){
  all(match(x, set, 0) > 0)
}







## ###################################################################
##
#' @title Create all subsets
#' @description Create all subsets of a vector
#' @name all_subsets
#' @author Søren Højsgaard, \email{sorenh@@math.aau.dk}
##
## Issues: deprecate allSubsets; use all_subsets instead
##
## ###################################################################
#' @param x Vector

#' @export
#' @rdname all-subsets
all_subsets <- allSubsets_

#' @export
#' @rdname all-subsets
all_subsets0 <- allSubsets0_


.all_subsets0 <- function(x) {
    y <- list(vector(mode(x), length = 0))
    for (i in seq_along(x)) {
        y <- c(y, lapply(y, "c", x[i]))
    }
    y[-1L]
}

.all_subsets <- function(x){
    out <- vector("list", length=2^length(x))
    ny = 1 # filled elements of out
    for (i in seq_along(x)){
        z = x[i]
        for (k in 1:ny){
            out[[ny + k]] = c(out[[k]],z)
        }
        ny = 2 * ny
    }
    out[-1]
}



## #' @rdname all-subsets
## #' @param g.sep Pick a value which is not in x
## allSubsets <- function(x, g.sep="+"){
##   if (length(x)==1)
##     return(x)
##   else {
##     val <- x[1]
##     for (i in 2:length(x)){
##       v <- paste(val,x[i],sep=g.sep)
##       val <- c(val,x[i],v)
##     }
##     val <- strsplit(val,paste("\\",g.sep,sep=""))
##     return(val)
##   }
## }





## ###################################################################
##
#' @title Create all possible pairs
#' @description Create all possible pairs of two character vectors.
#' @name all_pairs
#' @author Søren Højsgaard, \email{sorenh@@math.aau.dk}
#'
## ###################################################################
#'
#' @param x,y Character vectors.
#' @param sort Logical.
#' @param result A list or a matrix.
#'
#' @details NOTICE: If y is not NULL then x and y must be disjoint (no
#'     checks are made); otherwise pairs of identical elements wil also be obtained. 
#'
#' @examples
#'
#' x <- letters[1:4]
#' y <- letters[5:7]
#'
#' all_pairs(x)
#' all_pairs(x, result="matrix")
#'
#' all_pairs(x, y)
#' all_pairs(x, y, result="matrix")

#' @export
#' @rdname all_pairs
all_pairs <- all_pairs__

## FIXME names2pairs should be deprecated and replaced by all_pairs
#' @export
#' @rdname all_pairs
names2pairs <- function(x, y=NULL, sort=TRUE, result="list"){
  result <- match.arg(result, c("list", "matrix"))
  lenx <- length(x)
  leny <- length(y)

  if (leny == 0){
    if (lenx == 1){
      if (result == "matrix")
        return(matrix(nrow=0, ncol=2))
      else
        return(list())
    } else {
      cc   <- combn_prim(1:length(x), 2)
      out  <- x[cc]
      dim(out) <- dim(cc)
      if (sort){
        idx <- out[1,] > out[2, ]
        out[1:2,idx] <- out[2:1, idx]
      }
      if (result == "matrix")
        return(t.default(out))
      else
        return(colmat2list(out))
    }
  } else {
    out <- cbind(rep(x, each=leny), rep(y, times=lenx))
    if (sort){
      idx <- out[,1] > out[,2]
      out[idx, 1:2] <- out[idx, 2:1]
    }

    if (identical(result, "matrix")) out 
    else rowmat2list__(out)
  }
}
hojsgaard/gRbase documentation built on Jan. 10, 2024, 9:40 p.m.