R/simplification.R

In fcaR: Formal Concept Analysis

.simplification <- function(LHS, RHS, attributes, trace = FALSE) {
  LHS <- convert_to_sparse(LHS)
  RHS <- convert_to_sparse(RHS)

  LHS_subsets <- Matrix::Matrix(
    FALSE,
    sparse = TRUE,
    ncol = ncol(LHS),
    nrow = ncol(LHS)
  )
  intersections <- .self_intersection(LHS, RHS)

  id_inter <- Matrix::which(intersections == 0)

  LHS_subsets[, id_inter] <- Matrix::t(.subset(
    Matrix::Matrix(LHS[, id_inter], sparse = TRUE),
    LHS
  ))

  # This gives the LHS that are subsets of other LHS
  col_values <- Matrix::colSums(LHS_subsets)
  condition1 <- col_values > 1

  # This gives those LHS which are disjoint to their RHS
  condition2 <- intersections == 0

  are_subset <- Matrix::which(condition1 & condition2)

  black_list <- rep(FALSE, ncol(LHS))

  count <- 0

  while (length(are_subset) > 0) {
    count <- count + 1

    id1 <- which.max(col_values[are_subset])
    this_row <- are_subset[id1]

    my_idx <- which_at_col(LHS_subsets@i, LHS_subsets@p, this_row)

    # this_row <- id_inter[this_row]
    my_idx <- setdiff(my_idx, this_row)

    # This finding of subsets corresponds to Simplification logic.
    # Specifically, we are looking for implications A -> B and C -> D such that A is a subset of C.
    # If A \subseteq C, then A -> B implies C -> B (by Armstrong's axioms / Augmentation).
    # Thus, we have inferred C -> B.
    # The original rule C -> D can be simplified.
    # If we have C -> D, and we know C -> B, we can decompose D into D \setminus B.
    # So we replace C -> D with C -> (D \setminus B).
    # This is equivalent to removing attributes from the RHS of the more specific rule
    # that are already covered by the more general rule.

    if (length(my_idx) > 1) {
      C <- LHS[, my_idx, drop = FALSE]
      D <- RHS[, my_idx, drop = FALSE]
    } else {
      C <- Matrix::Matrix(LHS[, my_idx, drop = FALSE], sparse = TRUE)
      D <- Matrix::Matrix(RHS[, my_idx, drop = FALSE], sparse = TRUE)
    }
    B <- Matrix::Matrix(RHS[, this_row, drop = FALSE], sparse = TRUE)
    # Perform the set difference on the RHS: D_new = D \setminus B
    newLHS <- set_difference_single(C@i, C@p, C@x, B@i, B@p, B@x, nrow(C))
    newRHS <- set_difference_single(D@i, D@p, D@x, B@i, B@p, B@x, nrow(D))

    LHS[, my_idx] <- newLHS
    RHS[, my_idx] <- newRHS

    intersections[my_idx] <- .self_intersection(newLHS, newRHS)
    id_inter <- which(intersections == 0)

    LHS_subsets[my_idx, id_inter] <- Matrix::t(.subset(
      Matrix::Matrix(LHS[, id_inter, drop = FALSE], sparse = TRUE),
      newLHS
    ))
    col_values <- Matrix::colSums(LHS_subsets)
    condition1 <- col_values > 1

    condition2 <- (intersections == 0) & (Matrix::colSums(RHS) > 0)

    black_list[this_row] <- TRUE
    are_subset <- Matrix::which(condition1 & condition2 & (!black_list))
  }

  # Cleaning phase
  idx_to_remove <- Matrix::which(Matrix::colSums(RHS) == 0)

  if (length(idx_to_remove) > 0) {
    LHS <- LHS[, -idx_to_remove, drop = FALSE]
    RHS <- RHS[, -idx_to_remove, drop = FALSE]
  }

  return(list(lhs = LHS, rhs = RHS))
}