R/compute_closure_fuzzy.R

In neuroimaginador/fcaR: Formal Concept Analysis

.compute_closure_fuzzy <- function(S, LHS, RHS, attributes,
                             reduce = FALSE, verbose = FALSE,
                             is_direct = FALSE,
                             logic = "Lukasiewicz") {

  if (is.null(LHS) || (ncol(LHS) == 0)) {

    return(list(closure = S,
                implications = list(lhs = LHS,
                                    rhs = RHS)))

  }

  tnorm <- get_tnorm(logic)
  implication <- get_implication(logic)

  end <- FALSE
  while (!end) {

    end <- TRUE

    for (i in seq(ncol(LHS))) {

      subsethood <- sapply(seq_along(attributes),
                           \(j) {
                             implication(LHS[j, i], S[j])
                            }) |>
        min()

      add <- sapply(seq_along(attributes),
                    \(j) {
                      tnorm(subsethood, RHS[j, i])
                    }) |>
        convert_to_sparse()

      if (!.subset(add, S)[1]) {

        end <- FALSE
        S <- .union(S, add)

      }

    }

  }

  #
  # # Which are the rules applicable to the set S?
  # S_subsets <- .subset(LHS, S)
  #
  # idx_subsets <- S_subsets@i + 1
  #
  # do_not_use <- rep(FALSE, ncol(LHS))
  #
  # passes <- 0
  #
  # # While there are applicable rules, apply!!
  # while (length(idx_subsets) > 0) {
  #
  #   passes <- passes + 1
  #   if (verbose) cat("Pass #", passes, "\n")
  #
  #   if (length(idx_subsets) == 1) {
  #
  #     A <- Matrix::Matrix(RHS[, idx_subsets], sparse = TRUE)
  #
  #   } else {
  #
  #     A <- RHS[, idx_subsets]
  #
  #   }
  #
  #   S <- .multiunion(add_col(A, S))
  #
  #   do_not_use[idx_subsets] <- TRUE
  #
  #   if (reduce) {
  #
  #     L <- .simplification_logic(S = S,
  #                                LHS = LHS,
  #                                RHS = RHS)
  #
  #     LHS <- L$lhs
  #     RHS <- L$rhs
  #
  #     for (rem in L$idx_removed) {
  #
  #       do_not_use <- do_not_use[-rem]
  #
  #     }
  #
  #   }
  #
  #
  #   if (is.null(LHS) || (ncol(LHS) == 0)) {
  #
  #     return(list(closure = S,
  #                 implications = list(lhs = LHS,
  #                                     rhs = RHS)))
  #   }
  #
  #   if (!is_direct) {
  #
  #     S_subsets <- .subset(LHS, S)
  #
  #     idx_subsets <- S_subsets@i + 1
  #     idx_subsets <- setdiff(idx_subsets, which(do_not_use))
  #
  #     if (verbose) {
  #
  #       print(idx_subsets)
  #       print(Set$new(attributes = attributes,
  #                     M = S))
  #       cat("\n")
  #
  #     }
  #
  #
  #   } else {
  #
  #     idx_subsets <- c()
  #
  #   }
  #
  # }

  if (reduce) {

    return(list(closure = S,
                implications = .simplification_logic(S,
                                                     LHS,
                                                     RHS)))

  } else {

    return(list(closure = S,
                implications = list(LHS,
                                    RHS)))

  }

}

.simplification_logic <- function(S, LHS, RHS) {

  # Equivalence II
  subsets <- .subset(RHS, S)
  idx_subsets <- subsets@i + 1

  idx_removed <- list()

  if (length(idx_subsets) > 0) {

    idx_removed[[1]] <- idx_subsets

    LHS <- Matrix::Matrix(LHS[, -idx_subsets], sparse = TRUE)
    RHS <- Matrix::Matrix(RHS[, -idx_subsets], sparse = TRUE)

  }

  if (ncol(LHS) == 0) {

    return(list(lhs = NULL, rhs = NULL))

  }

  # Equivalence III
  C <- LHS
  D <- RHS

  CD <- .union(LHS, RHS)

  intersections <- .intersection(x = S, y = CD)
  idx_not_empty <- Matrix::which(Matrix::colSums(intersections) > 0)

  if (length(idx_not_empty) > 0) {

    if (length(idx_not_empty) == 1) {

      Cidx <- .extract_column(C, idx_not_empty)
      Didx <- .extract_column(D, idx_not_empty)

    } else {

      Cidx <- C[, idx_not_empty]
      Didx <- D[, idx_not_empty]

    }

    C_B <- set_difference_single(Cidx@i, Cidx@p, Cidx@x,
                                 S@i, S@p, S@x,
                                 nrow(Cidx))

    D_B <- set_difference_single(Didx@i, Didx@p, Didx@x,
                                 S@i, S@p, S@x,
                                 nrow(Didx))

    idx_zeros <- Matrix::which(Matrix::colSums(D_B) == 0)

    if (length(idx_zeros) > 0) {

      C_B <- Matrix::Matrix(C_B[, -idx_zeros], sparse = TRUE)
      D_B <- Matrix::Matrix(D_B[, -idx_zeros], sparse = TRUE)

    }

    LHS <- cbind(C_B,
                 Matrix::Matrix(C[, -idx_not_empty], sparse = TRUE))
    RHS <- cbind(D_B,
                 Matrix::Matrix(D[, -idx_not_empty], sparse = TRUE))

  }

  L <- .generalization(LHS, RHS)
  L <- .composition(L$lhs, L$rhs)
  LHS <- L$lhs
  RHS <- L$rhs

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

}