R/inters.R

In dst: Using the Theory of Belief Functions

#'Intersection of two tables of propositions
#' 
#' Function \code{inters} returns a table of the intersection between two (0,1) or boolean matrices or two vectors. The two matrices must have the same number of columns. The two vectors must be of the same length. This function generalizes the intersection of two subsets represented by boolean vectors to the intersection of two matrices of subsets. 
#' 
#' @param x A (0,1)-matrix or a boolean matrix of M rows by K columns, or a vector of length K.
#' @param y A (0,1)-matrix or a boolean matrix of N rows by K columns or a vector of length K.
#' @return The result is a (0,1)-table of dimensions (M x K) x N). In the case of vectors, the result is a (0,1)-table of dimensions (1 x K) x 1)
#' @author Claude Boivin
#' @examples 
#' mx <- matrix(c(0,1,0,0,1,1,1,1,1),nrow = 3, byrow = TRUE, dimnames = list(NULL, c("a", "b", "c")))
#'  rownames(mx) <- nameRows(mx)
#' my<-matrix(c(0,0,1,1,1,1),nrow = 2, byrow = TRUE, dimnames = list(NULL, c("a", "b", "c")))
#'  rownames(my) <- nameRows(my)
#' inters(mx,my)
#' b1 <- matrix(c(FALSE, TRUE, TRUE), nrow=1)
#' b2 <- matrix(c(TRUE, TRUE, FALSE), nrow=1)
#' colnames(b1) <- colnames(b2) <- c("c1","c2","c3")
#' inters(b1,b2)
#' x3<-matrix(c(1,1,0,1), ncol = 2, dimnames = list(NULL, c("a","b")))
#' y3<-matrix(c(0,1,1,1), ncol = 2, dimnames = list(NULL, c("a","b")))
#' inters(x3,y3)
#' x4 <-matrix(c(1,0,1,1,1,1,1,1),nrow = 2, byrow = TRUE, dimnames = list(NULL, c("a", "b", "c","d")))
#' y4 <-matrix(c(1,0,0,1,1,1,1,1),nrow = 2, byrow = TRUE, dimnames = list(NULL, c("a", "b", "c","d")))
#' inters(x4,y4)
#' # Sparse matrices
#' stt1 <- Matrix::sparseMatrix(i= c(1,1,2,2,3,3,3), j= c(2,3,1,2,1,2,3), x = 1, dims = c(3,3))
#' y1 <- bca(tt = stt1, m = c(0.2,0.5, 0.3), 
#'          cnames = c("a", "b", "c"),  
#'          varnames = "x", idvar = 1) 
#' stt2 <- Matrix::sparseMatrix(i= c(1,2,2,2), j= c(1,1,2,3), x = 1, dims = c(2,3))
#' y2 <- bca(tt = stt2, m = c(0.6, 0.4),  
#'          cnames = c("a", "b", "c"),  
#'          varnames = "x", idvar = 1)
#'  sr <-inters(y1$tt, y2$tt)   
#'  sr 
#'  class(sr)    
#' @export
#' 
inters<-function(x, y) { 
  #
  # Local variables : none
  #
  # Functions calls: nameRows
  #
  # 2. checks
  #
  if (((isS4(x) == FALSE) & (is.matrix(x) == FALSE ) ) | ((isS4(y) == FALSE) & (is.matrix(y) == FALSE )) ) {
    stop("Input error. Check your input data")
  }
  if ((is.null(nrow(x)) == TRUE) | (is.null(nrow(y)) == TRUE) ) {
    x<-rbind(x) # transforms vectors to matrices
    y<-rbind(y)
  }
  if (ncol(x) != ncol(y)) {
    stop("Error in input arguments: check your input data.") 
  }
  if ((is.null(colnames(x))) | (is.null(colnames(y) ) ) ) {    
    warning("No column names supplied. They have been generated by the program.")
    cnames <- colnames(x, do.NULL = FALSE, prefix = "col")
  } else {
    cnames <- colnames(x)
  }
  # End checks
  #
  # Calculations
  #
  N12 <- list()
    for(i in 1:nrow(x) ) {
      temp <- lapply(X=1:nrow(y), FUN = function(X) {diag(outer(x[i,], y[X,]) )} )
      N12 <- c(N12,temp)
    }
  N12 <- t(array(unlist(N12), dim = c(shape(N12[[1]])[1], shape(N12))) )
  if ((isS4(x) == TRUE ) | (isS4(y) == TRUE ) ) {
    N12 <- methods::as(N12, "RsparseMatrix")
  }
  colnames(N12) <- colnames(x)
  rownames(N12) <- nameRows(N12)
  return(N12)
  }