# R/compute_closure.R In fcaR: Formal Concept Analysis

#### Defines functions .simplification_logic.compute_closure

```.compute_closure <- function(S, LHS, RHS, attributes,
reduce = FALSE, verbose = FALSE,
is_direct = FALSE) {

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

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

}

# 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]

}

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))

}
```

## Try the fcaR package in your browser

Any scripts or data that you put into this service are public.

fcaR documentation built on May 29, 2024, 2:05 a.m.