Nothing
R/concept_lattice.R
In fcaR: Formal Concept Analysis
#' @title
#' R6 class for a concept lattice
#'
#' @description
#' This class implements the data structure and methods for concept lattices.
#'
#' @examples
#' # Build a formal context
#' fc_planets <- FormalContext$new(planets)
#'
#' # Find the concepts
#' fc_planets$find_concepts()
#'
#' # Find join- and meet- irreducible elements
#' fc_planets$concepts$join_irreducibles()
#' fc_planets$concepts$meet_irreducibles()
#'
#' # Get concept support
#' fc_planets$concepts$support()
#'
#' @export
#' @import R6
#'
ConceptLattice <- R6::R6Class(
classname = "ConceptLattice",
inherit = ConceptSet,
public = list(
#' @description
#' Create a new \code{ConceptLattice} object.
#'
#' @param extents (\code{dgCMatrix}) The extents of all concepts
#' @param intents (\code{dgCMatrix}) The intents of all concepts
#' @param objects (character vector) Names of the objects in the formal context
#' @param attributes (character vector) Names of the attributes in the formal context
#' @param I (\code{dgCMatrix}) The matrix of the formal context
#'
#' @return
#' A new \code{ConceptLattice} object.
#'
#' @export
initialize = function(extents, intents, objects, attributes, I = NULL) {
private$objects <- objects
private$attributes <- attributes
private$pr_extents <- extents
private$pr_intents <- intents
if (!capabilities()["long.double"] & getRversion() < "4.1.0") {
private$can_plot <- FALSE
}
super$initialize(
extents,
intents,
objects,
attributes,
I
)
},
#' @description
#' Plot the concept lattice
#'
#' @param object_names (logical) Deprecated. Use \code{mode} instead. If \code{TRUE} (default), implies \code{mode = "reduced"} or similar depending on heuristics. Kept for backward compatibility.
#' @param to_latex (logical) If \code{TRUE}, exports the plot as TikZ code (LaTeX) instead of drawing it. Returns an object of class \code{tikz_code} that prints the LaTeX code to console.
#' @param method (character) The layout algorithm to use. Options are:
#' \itemize{
#' \item \code{"sugiyama"} (default): A hierarchical layout that minimizes edge crossings and centers nodes (similar to ConExp or hasseDiagram).
#' \item \code{"force"}: A force-directed (spring) layout, useful for large or non-hierarchical lattices.
#' }
#' @param mode (character) The labeling mode for the nodes. If \code{NULL} (default), a heuristic based on lattice size is used. Options are:
#' \itemize{
#' \item \code{"reduced"}: Standard FCA labeling. Nodes are labeled with an attribute (or object) only if they are the supreme (or infimum) of that attribute (or object).
#' \item \code{"full"}: Each node shows its complete extent and intent.
#' \item \code{"attributes"}: Nodes show only their intent (attributes).
#' \item \code{"empty"}: Nodes are drawn as points without labels. Recommended for very large lattices (>50 concepts).
#' }
#' @param viewer (character) The viewer to use for plotting. Options are:
#' \itemize{
#' \item \code{"ggraph"} (default): Use \code{ggraph} for drawing.
#' \item \code{"base"}: Use R base graphics. This is a lightweight alternative that supports themes.
#' }
#' @param theme (character) The color theme to use for the \code{"base"} viewer. Options are: \code{"standard"}, \code{"nord"}, \code{"latex"}, \code{"vibrant"}.
#' @param ... Other parameters passed to the internal plotting function (e.g., graphical parameters for \code{ggraph} or \code{base}).
#'
#' @return If \code{to_latex} is \code{FALSE}, it returns (invisibly) the \code{ggplot2} object representing the graph (for \code{ggraph}) or \code{NULL} (for \code{base}).
#' If \code{to_latex} is \code{TRUE}, it returns a \code{tikz_code} object containing the LaTeX code.
#' @export
plot = function(
object_names = TRUE,
to_latex = FALSE,
method = c("sugiyama", "force"),
mode = NULL,
viewer = c("ggraph", "base"),
theme = "standard",
...
) {
# 1. Verificación de estado
if (self$size() == 0) {
warning("No concepts to plot.", call. = FALSE)
return(invisible(NULL))
}
private$build_adjacency()
private$build_covering()
# 2. Construcción del índice de nodos (Data Frame mínimo)
# Solo creamos los IDs (1..N). La función externa calculará grados y layout.
nodes_df <- data.frame(
id = seq_len(self$size()),
stringsAsFactors = FALSE
)
# --- CONVERSIÓN IMPORTANTE ---
# Convertimos los SparseSets a listas estándar de R para que la función de plot
# pueda hacer `extents[[i]]` sin errores S4.
extents_list <- sparse_to_list(private$pr_extents)
intents_list <- sparse_to_list(private$pr_intents)
# 3. Delegación a lattice_plot
# Pasamos los datos privados necesarios (matriz, objetos, atributos)
method <- match.arg(method)
viewer <- match.arg(viewer)
lattice_plot(
nodes_df = nodes_df,
cover_matrix = private$covering_matrix,
method = method, # Pasamos el método
mode = mode, # Pasamos el modo (o NULL para heurística)
objects = private$objects,
attributes = private$attributes,
# Pasamos los conjuntos dispersos para calcular reduced/full labels
extents = extents_list,
intents = intents_list,
object_names = self$objects,
to_latex = to_latex,
viewer = viewer,
theme = theme,
...
)
},
#' @description
#' Sublattice
#'
#' @param ... See Details.
#'
#' @details
#' As argument, one can provide both integer indices or \code{Concepts}, separated by commas. The corresponding concepts are used to generate a sublattice.
#'
#' @return
#' The generated sublattice as a new \code{ConceptLattice} object.
#'
#' @export
sublattice = function(...) {
idx <- private$to_indices(...)
if (length(idx) > 0) {
private$build_adjacency()
idx <- .get_sublattice(private$subconcept_matrix, starting_idx = idx)
if (length(idx) > 1) {
my_intents <- private$pr_intents[, idx]
my_extents <- private$pr_extents[, idx]
} else {
my_intents <- .extract_column(private$pr_intents, idx)
my_extents <- .extract_column(private$pr_extents, idx)
}
cl <- ConceptLattice$new(
extents = my_extents,
intents = my_intents,
objects = private$objects,
attributes = private$attributes,
I = private$I
)
return(cl)
}
},
#' @description
#' Build a sublattice from selected concepts
#'
#' @param attributes Character vector of attribute names, or \code{NULL} (default).
#' @param match \code{"all"} (default) or \code{"any"}: how to combine several attributes.
#' @param min_support Numeric in \eqn{[0, 1]}. Discard concepts with smaller support.
#' @param top_n Integer or \code{NULL}. Keep the \code{top_n} concepts with highest support.
#' @param verbose Logical; print a short summary.
#'
#' @return A \code{ConceptLattice} object.
#' @export
sublattice_from = function(attributes = NULL,
match = c("all", "any"),
min_support = 0,
top_n = 7L,
verbose = TRUE) {
match <- match.arg(match)
n_all <- self$size()
if (n_all < 1L) {
stop("No concepts found. Call find_concepts() first.", call. = FALSE)
}
if (!is.numeric(min_support) || length(min_support) != 1L ||
is.na(min_support) || min_support < 0 || min_support > 1) {
stop("`min_support` must be a single number in [0, 1].", call. = FALSE)
}
if (!is.null(top_n)) {
top_n <- as.integer(top_n)
if (length(top_n) != 1L || is.na(top_n) || top_n < 1L) {
stop("`top_n` must be a positive integer or NULL.", call. = FALSE)
}
}
candidates <- seq_len(n_all)
query <- list(
attributes = attributes,
match = if (!is.null(attributes)) match else NA_character_,
min_support = min_support,
top_n = top_n
)
# Filter by attributes in the intent
if (!is.null(attributes)) {
atts <- private$attributes
attributes <- as.character(attributes)
if (length(attributes) == 0L) {
stop("`attributes` must be non-empty or NULL.", call. = FALSE)
}
unknown <- setdiff(attributes, atts)
if (length(unknown) > 0L) {
stop(
"Unknown attribute(s): ", paste(unknown, collapse = ", "),
"\nAvailable: ", paste(atts, collapse = ", "),
call. = FALSE
)
}
intents <- self$intents()
rows <- match(attributes, atts)
present <- lapply(rows, function(r) {
as.vector(intents[r, , drop = FALSE] > 0)
})
if (match == "all") {
hit <- Reduce(`&`, present)
} else {
hit <- Reduce(`|`, present)
}
candidates <- which(hit)
if (length(candidates) == 0L) {
stop(
"No concepts have ", match, " of {",
paste(attributes, collapse = ", "), "} in their intent.",
call. = FALSE
)
}
}
# Filter by minimum support
sup <- self$support()
if (min_support > 0) {
candidates <- candidates[sup[candidates] >= min_support]
if (length(candidates) == 0L) {
stop(
"No concepts left with support >= ", min_support, ".",
call. = FALSE
)
}
}
n_candidates <- length(candidates)
# Rank by support
ord <- order(sup[candidates], decreasing = TRUE)
ranked <- candidates[ord]
if (is.null(top_n)) {
generators <- ranked
if (length(generators) > 25L) {
warning(
length(generators),
" concepts will generate the sublattice; ",
"the join/meet closure may be slow and the plot hard to read. ",
"Consider setting top_n (e.g. top_n = 8).",
call. = FALSE
)
}
} else {
if (top_n > length(ranked)) {
if (isTRUE(verbose)) {
message(
"top_n = ", top_n, " > ", length(ranked),
" candidates; using all candidates."
)
}
top_n <- length(ranked)
}
generators <- ranked[seq_len(top_n)]
}
sub <- self$sublattice(generators)
if (isTRUE(verbose)) {
how <- if (is.null(attributes)) {
"by support"
} else {
paste0(
"intent contains ", match, " of {",
paste(attributes, collapse = ", "), "}"
)
}
message(sprintf(
"sublattice_from: %s; %d candidate(s) -> %d generator(s) -> %d concept(s)",
how, n_candidates, length(generators), sub$size()
))
}
attr(sub, "generators") <- generators
attr(sub, "n_candidates") <- n_candidates
attr(sub, "query") <- query
return(sub)
},
#' @description Top of a Lattice
#'
#' @return The top of the Concept Lattice
#' @export
#'
#' @examples
#' fc <- FormalContext$new(planets)
#' fc$find_concepts()
#' fc$concepts$top()
#'
top = function() {
private$build_adjacency()
idx <- which(Matrix::colSums(private$subconcept_matrix) == self$size())
self[idx]$to_list()[[1]]
},
#' @description Bottom of a Lattice
#'
#' @return The bottom of the Concept Lattice
#' @export
#'
#' @examples
#' fc <- FormalContext$new(planets)
#' fc$find_concepts()
#' fc$concepts$bottom()
#'
bottom = function() {
private$build_adjacency()
idx <- which(Matrix::colSums(private$subconcept_matrix) == 1)
self[idx]$to_list()[[1]]
},
#' @description
#' Join-irreducible Elements
#'
#' @return
#' The join-irreducible elements in the concept lattice.
#'
#' @export
#'
join_irreducibles = function() {
private$build_adjacency()
private$build_covering()
idx <- which(Matrix::colSums(private$covering_matrix) == 1)
self[idx]
},
#' @description
#' Meet-irreducible Elements
#'
#' @return
#' The meet-irreducible elements in the concept lattice.
#'
#' @export
#'
meet_irreducibles = function() {
private$build_adjacency()
M <- .reduce_transitivity(Matrix::t(private$subconcept_matrix))
idx <- which(Matrix::colSums(M) == 1)
self[idx]
},
#' @description
#' Decompose a concept as the supremum of meet-irreducible concepts
#'
#' @param C A list of \code{Concept}s
#' @return
#' A list, each field is the set of meet-irreducible elements whose supremum is the corresponding element in \code{C}.
#'
#' @export
#'
decompose = function(C) {
irreducible <- self$meet_irreducibles()
irr_intents <- irreducible$intents()
C_intents <- C$intents()
ss <- lapply(
seq(C$size()),
function(i) {
r <- Matrix::Matrix(C_intents[, i], sparse = TRUE)
if (sum(r) == 0) {
return(C[i])
}
id <- Matrix::which(.subset(
irr_intents,
r
))
if (length(id) > 1) {
MM <- .subset(irr_intents[, id])
id <- id[Matrix::rowSums(MM) == 1]
}
decomposition <- irreducible[id]
return(decomposition)
}
)
return(ss)
},
#' @description
#' Supremum of Concepts
#'
#' @param ... See Details.
#'
#' @details
#' As argument, one can provide both integer indices or \code{Concepts}, separated by commas. The corresponding concepts are used to compute their supremum in the lattice.
#'
#' @return
#' The supremum of the list of concepts.
#'
#' @export
supremum = function(...) {
idx <- private$to_indices(...)
private$build_adjacency()
return(self[join(private$subconcept_matrix, idx)]$to_list()[[1]])
},
#' @description
#' Infimum of Concepts
#'
#' @param ... See Details.
#'
#' @details
#' As argument, one can provide both integer indices or \code{Concepts}, separated by commas. The corresponding concepts are used to compute their infimum in the lattice.
#'
#' @return
#' The infimum of the list of concepts.
#'
#' @export
infimum = function(...) {
idx <- private$to_indices(...)
private$build_adjacency()
return(self[meet(private$subconcept_matrix, idx)]$to_list()[[1]])
},
#' @description
#' Subconcepts of a Concept
#'
#' @param C (numeric or \code{SparseConcept}) The concept to which determine all its subconcepts.
#'
#' @return
#' A list with the subconcepts.
#' @export
subconcepts = function(C) {
idx <- private$to_indices(C)
private$build_adjacency()
# Get the index of all subconcepts
M <- Matrix::t(private$subconcept_matrix)[idx, ]
candidates <- Matrix::which(M > 0)
if (length(candidates) > 1) {
return(
ConceptLattice$new(
attributes = private$attributes,
objects = private$objects,
extents = private$pr_extents[, candidates],
intents = private$pr_intents[, candidates],
I = private$I
)
)
}
return(
ConceptLattice$new(
attributes = private$attributes,
objects = private$objects,
extents = .extract_column(
private$pr_extents,
candidates
),
intents = .extract_column(
private$pr_intents,
candidates
),
I = private$I
)
)
},
#' @description
#' Superconcepts of a Concept
#'
#' @param C (numeric or \code{SparseConcept}) The concept to which determine all its superconcepts.
#'
#' @return
#' A list with the superconcepts.
#' @export
superconcepts = function(C) {
idx <- private$to_indices(C)
private$build_adjacency()
# Get the index of all superconcepts
M <- private$subconcept_matrix[idx, ]
candidates <- which(M > 0)
if (length(candidates) > 1) {
return(
ConceptLattice$new(
attributes = private$attributes,
objects = private$objects,
extents = private$pr_extents[, candidates],
intents = private$pr_intents[, candidates],
I = private$I
)
)
}
return(
ConceptLattice$new(
attributes = private$attributes,
objects = private$objects,
extents = .extract_column(
private$pr_extents,
candidates
),
intents = .extract_column(
private$pr_intents,
candidates
),
I = private$I
)
)
},
#' @description
#' Lower Neighbours of a Concept
#'
#' @param C (\code{SparseConcept}) The concept to which find its lower neighbours
#'
#' @return
#' A list with the lower neighbours of \code{C}.
#'
#' @export
lower_neighbours = function(C) {
idx <- private$to_indices(C)
private$build_adjacency()
private$build_covering()
self[which(private$covering_matrix[, idx] > 0)]
},
#' @description
#' Upper Neighbours of a Concept
#'
#' @param C (\code{SparseConcept}) The concept to which find its upper neighbours
#'
#' @return
#' A list with the upper neighbours of \code{C}.
#'
#' @export
upper_neighbours = function(C) {
idx <- private$to_indices(C)
private$build_adjacency()
private$build_covering()
self[which(private$covering_matrix[idx, ] > 0)]
},
#' @description
#' Computes the stability of each concept.
#'
#' @return A numeric vector with the stability of each concept.
#' @export
stability = function() {
if (self$size() == 0) {
return(numeric(0))
}
# Pass internal sparse extents directly
return(calculate_stability(private$pr_extents))
},
#' @description
#' Computes the separation of each concept.
#' Separation is the number of objects covered by the concept but not by any of its immediate subconcepts.
#'
#' @return A numeric vector with the separation of each concept.
#' @importFrom Matrix rowSums
#' @export
separation = function() {
if (self$size() == 0) {
return(numeric(0))
}
private$build_adjacency()
# 1. Obtener la matriz de extents (Objetos x Conceptos)
M <- as(private$pr_extents, "CsparseMatrix")
# 2. Obtener la relación de cobertura (Hijos directos)
# Usamos la función interna .reduce_transitivity disponible en el paquete
# Se aplica sobre la matriz de subconceptos (orden parcial)
# Asumimos que subconcept_matrix es C_i <= C_j
private$build_covering()
cover_matrix <- private$covering_matrix
# 3. Calcular separación usando el helper (definido en metrics.R)
# Pasamos M (extents) y cover_matrix (grafo)
return(calculate_separation_internal(M, cover_matrix))
},
#' @description
#' Computes the fuzzy density of each concept.
#'
#' @param I (Optional) The original incidence matrix. If NULL, it tries to access it from the parent FormalContext if linked.
#' @return A numeric vector with the density of each concept.
#' @export
density = function(I = NULL) {
if (self$size() == 0) {
return(numeric(0))
}
# Ideally, ConceptLattice should know about I.
# If not passed, we might default to binary (density 1) or error.
if (is.null(I)) {
# User must provide I if not stored.
# For now, return NA or 1 if binary.
warning("Incidence matrix I not provided. Assuming density = 1.")
return(rep(1.0, self$size()))
}
return(calculate_density(private$pr_extents, private$pr_intents, I))
},
#' @description
#' Check if the lattice is distributive.
#' A lattice is distributive if \eqn{x \wedge (y \vee z) = (x \wedge y) \vee (x \wedge z)} for all elements.
#' @return Logical.
#' @export
is_distributive = function() {
if (!is.na(private$properties$distributivity)) {
return(private$properties$distributivity)
}
private$build_structure()
res <- check_distributivity_internal(
private$meet_matrix,
private$join_matrix
)
private$properties$distributivity <- res
return(res)
},
#' @description
#' Check if the lattice is modular.
#' A lattice is modular if \eqn{x \le z \implies x \vee (y \wedge z) = (x \vee y) \wedge z}.
#' Distributive lattices are always modular.
#' @return Logical.
#' @export
is_modular = function() {
if (!is.na(private$properties$modularity)) {
return(private$properties$modularity)
}
private$build_structure()
res <- check_modularity_internal(private$meet_matrix, private$join_matrix)
private$properties$modularity <- res
return(res)
},
#' @description
#' Check if the lattice is upper semimodular.
#' A lattice is upper semimodular if for every \eqn{x, y}: if \eqn{x} covers \eqn{x \wedge y}, then \eqn{x \vee y} covers \eqn{y}.
#' @return Logical.
#' @export
is_semimodular = function() {
if (!is.na(private$properties$semimodularity)) {
return(private$properties$semimodularity)
}
private$build_structure()
# Necesita Meet, Join y la relación de Cobertura
res <- check_semimodularity_internal(
private$meet_matrix,
private$join_matrix,
private$covering_matrix
)
private$properties$semimodularity <- res
return(res)
},
#' @description
#' Check if the lattice is atomic.
#' A lattice is atomic if for every element \eqn{x > \bot}, there exists an atom \eqn{a} such that \eqn{a \le x}.
#' Atoms are elements that cover the bottom element.
#' @return Logical.
#' @export
is_atomic = function() {
if (!is.na(private$properties$atomicity)) {
return(private$properties$atomicity)
}
private$build_structure()
# Necesita Adyacencia (Orden) y Cobertura (Hasse)
res <- check_atomicity_internal(
private$subconcept_matrix,
private$covering_matrix
)
private$properties$atomicity <- res
return(res)
},
#' @description
#' Computes the Dilworth's width of the lattice.
#' The width is the size of the largest antichain.
#' @return Integer.
#' @export
width = function() {
if (!is.na(private$properties$width)) {
return(private$properties$width)
}
private$build_adjacency()
adj <- private$subconcept_matrix
res <- calculate_width_cpp(adj@i, adj@p, adj@Dim[1])
private$properties$width <- res
return(res)
},
#' @description
#' Computes the order dimension (Dushnik-Miller) of the lattice.
#' Note: This uses a heuristic and may return an estimate for large lattices.
#' @return Integer.
#' @export
dimension = function() {
if (!is.na(private$properties$dimension)) {
return(private$properties$dimension)
}
private$build_adjacency()
adj <- private$subconcept_matrix
res <- calculate_dimension_heuristic_cpp(adj@i, adj@p, adj@Dim[1])
private$properties$dimension <- res
return(res)
},
#' @description
#' Internal method to set state from JSON import
#' @param state List of internal state variables
set_state = function(state) {
private$pr_extents <- state$extents
private$pr_intents <- state$intents
private$objects <- state$objects
private$attributes <- state$attributes
# Reconstruct basic info
# Hierarchy? covering_matrix?
# If hierarchy is provided, rebuild covering matrix
if (!is.null(state$hierarchy)) {
# List of source->target
# Rebuild covering matrix
n <- ncol(private$pr_extents)
i_idx <- integer(0)
j_idx <- integer(0)
for (h in state$hierarchy) {
i_idx <- c(i_idx, h$source)
j_idx <- c(j_idx, h$target)
}
if (length(i_idx) > 0) {
private$covering_matrix <- Matrix::sparseMatrix(
i = i_idx,
j = j_idx,
dims = c(n, n),
x = 1
)
}
}
},
#' @description
#' Export the concept lattice to JSON
#'
#' @param file (character) The path of the file to save the JSON to.
#' @param return_list (logical) If TRUE, returns the list representation instead of the JSON string.
#'
#' @return A JSON string representing the concept lattice, or a list if \code{return_list} is TRUE.
#' @export
to_json = function(file = NULL, return_list = FALSE) {
check_needed_pkg("jsonlite", "export to JSON")
# Helper to convert sparse matrix to list of indices/values
mat_to_list <- function(M) {
if (is.null(M)) {
return(list())
}
# Fix deprecation: use TsparseMatrix directly if possible, or via generalMatrix
# Trying direct cast first
T <- as(M, "TsparseMatrix")
if (length(T@x) == 0 && length(T@i) == 0) {
return(replicate(ncol(M), integer(0), simplify = FALSE))
}
# 1-based indices
df <- data.frame(i = T@i + 1, j = T@j + 1)
res <- split(df$i, factor(df$j, levels = seq_len(ncol(M))))
return(res)
}
# Extents and Intents (Concepts are columns)
extents_list <- mat_to_list(private$pr_extents)
intents_list <- mat_to_list(private$pr_intents)
concepts <- lapply(seq_len(self$size()), function(k) {
list(
id = k,
extent = extents_list[[k]],
intent = intents_list[[k]]
)
})
# Hierarchy (Covering relation)
private$build_covering()
hierarchy <- list()
if (!is.null(private$covering_matrix)) {
T <- as(as(private$covering_matrix, "dgCMatrix"), "dgTMatrix")
if (length(T@i) > 0) {
hierarchy <- lapply(seq_along(T@i), function(k) {
list(source = T@i[k] + 1, target = T@j[k] + 1)
})
}
}
# Context I
I_data <- NULL
if (!is.null(private$I)) {
I_data <- mat_to_list(Matrix::t(private$I))
}
out <- list(
type = "ConceptLattice",
objects = private$objects,
attributes = private$attributes,
concepts = concepts,
hierarchy = hierarchy,
I = I_data
)
if (return_list) {
return(out)
}
json <- jsonlite::toJSON(out, auto_unbox = TRUE)
if (!is.null(file)) {
writeLines(json, file)
}
return(json)
}
),
private = list(
properties = list(
distributivity = NA,
modularity = NA,
semimodularity = NA,
atomicity = NA,
width = NA,
dimension = NA
),
subconcept_matrix = NULL,
covering_matrix = NULL,
meet_matrix = NULL,
join_matrix = NULL,
build_adjacency = function() {
if (self$size() == 0) {
return(invisible(self))
}
if (is.null(private$subconcept_matrix)) {
private$subconcept_matrix <- .subset(private$pr_extents)
}
invisible(self)
},
build_covering = function() {
private$build_adjacency()
if (is.null(private$subconcept_matrix)) {
return(NULL)
}
if (is.null(private$covering_matrix)) {
private$covering_matrix <- as(
.reduce_transitivity(private$subconcept_matrix),
"nMatrix"
)
}
invisible(self)
},
build_meet_join = function() {
private$build_adjacency()
if (is.null(private$meet_matrix)) {
adj <- private$subconcept_matrix
# 2. Llamada a C++
# Pasamos punteros de la nMatrix
res <- compute_meet_join_cpp(adj@i, adj@p, adj@Dim)
# 3. Reconstruir ngCMatrix
# Nota: C++ devuelve base-1 en 'x' y base-0 en 'i' (para slots internos)
# Pero para new(), 'x' son los valores.
private$meet_matrix <- new(
"dgCMatrix",
i = res$meet$i,
p = res$meet$p,
x = as.double(res$meet$x),
Dim = res$meet$Dim
)
private$join_matrix <- new(
"dgCMatrix",
i = res$join$i,
p = res$join$p,
x = as.double(res$join$x),
Dim = res$join$Dim
)
}
return(invisible(self))
},
build_structure = function() {
private$build_adjacency()
private$build_covering()
private$build_meet_join()
},
can_plot = TRUE,
concept_list_to_indices = function(concept_list) {
extents <- lapply(
concept_list,
function(l) l$get_extent()$get_vector()
)
extents <- Reduce(cbind, extents)
indices <- .equal_sets(
x = extents,
y = private$pr_extents
)
indices <- arrayInd(Matrix::which(indices), .dim = dim(indices))[, 2]
return(indices)
},
to_indices = function(...) {
dots <- list(...)
if (is.list(dots[[1]])) {
dots <- unlist(dots)
}
if (is.logical(dots[[1]])) {
return(which(dots[[1]]))
}
csets_idx <- sapply(
dots,
function(l) inherits(l, "ConceptSet")
)
if (length(csets_idx) > 0) {
csets <- sapply(
dots[csets_idx],
function(l) l$to_list()
) |>
unlist()
} else {
csets <- c()
}
sets <- sapply(
dots,
function(l) {
inherits(l, "Concept")
}
)
sets <- c(csets, dots[which(sets)])
indices <- sapply(dots, is.numeric)
idx <- c()
if (length(indices) > 0) {
idx <- c(idx, Reduce(c, dots[indices]))
}
if (length(sets) > 0) {
idx <- c(
idx,
private$concept_list_to_indices(sets)
)
}
return(idx)
}
)
)
Try the fcaR package in your browser
Any scripts or data that you put into this service are public.
fcaR documentation built on July 27, 2026, 5:06 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#' @title
#' R6 class for a concept lattice
#'
#' @description
#' This class implements the data structure and methods for concept lattices.
#'
#' @examples
#' # Build a formal context
#' fc_planets <- FormalContext$new(planets)
#'
#' # Find the concepts
#' fc_planets$find_concepts()
#'
#' # Find join- and meet- irreducible elements
#' fc_planets$concepts$join_irreducibles()
#' fc_planets$concepts$meet_irreducibles()
#'
#' # Get concept support
#' fc_planets$concepts$support()
#'
#' @export
#' @import R6
#'
ConceptLattice <- R6::R6Class(
classname = "ConceptLattice",
inherit = ConceptSet,
public = list(
#' @description
#' Create a new \code{ConceptLattice} object.
#'
#' @param extents (\code{dgCMatrix}) The extents of all concepts
#' @param intents (\code{dgCMatrix}) The intents of all concepts
#' @param objects (character vector) Names of the objects in the formal context
#' @param attributes (character vector) Names of the attributes in the formal context
#' @param I (\code{dgCMatrix}) The matrix of the formal context
#'
#' @return
#' A new \code{ConceptLattice} object.
#'
#' @export
initialize = function(extents, intents, objects, attributes, I = NULL) {
private$objects <- objects
private$attributes <- attributes
private$pr_extents <- extents
private$pr_intents <- intents
if (!capabilities()["long.double"] & getRversion() < "4.1.0") {
private$can_plot <- FALSE
}
super$initialize(
extents,
intents,
objects,
attributes,
I
)
},
#' @description
#' Plot the concept lattice
#'
#' @param object_names (logical) Deprecated. Use \code{mode} instead. If \code{TRUE} (default), implies \code{mode = "reduced"} or similar depending on heuristics. Kept for backward compatibility.
#' @param to_latex (logical) If \code{TRUE}, exports the plot as TikZ code (LaTeX) instead of drawing it. Returns an object of class \code{tikz_code} that prints the LaTeX code to console.
#' @param method (character) The layout algorithm to use. Options are:
#' \itemize{
#' \item \code{"sugiyama"} (default): A hierarchical layout that minimizes edge crossings and centers nodes (similar to ConExp or hasseDiagram).
#' \item \code{"force"}: A force-directed (spring) layout, useful for large or non-hierarchical lattices.
#' }
#' @param mode (character) The labeling mode for the nodes. If \code{NULL} (default), a heuristic based on lattice size is used. Options are:
#' \itemize{
#' \item \code{"reduced"}: Standard FCA labeling. Nodes are labeled with an attribute (or object) only if they are the supreme (or infimum) of that attribute (or object).
#' \item \code{"full"}: Each node shows its complete extent and intent.
#' \item \code{"attributes"}: Nodes show only their intent (attributes).
#' \item \code{"empty"}: Nodes are drawn as points without labels. Recommended for very large lattices (>50 concepts).
#' }
#' @param viewer (character) The viewer to use for plotting. Options are:
#' \itemize{
#' \item \code{"ggraph"} (default): Use \code{ggraph} for drawing.
#' \item \code{"base"}: Use R base graphics. This is a lightweight alternative that supports themes.
#' }
#' @param theme (character) The color theme to use for the \code{"base"} viewer. Options are: \code{"standard"}, \code{"nord"}, \code{"latex"}, \code{"vibrant"}.
#' @param ... Other parameters passed to the internal plotting function (e.g., graphical parameters for \code{ggraph} or \code{base}).
#'
#' @return If \code{to_latex} is \code{FALSE}, it returns (invisibly) the \code{ggplot2} object representing the graph (for \code{ggraph}) or \code{NULL} (for \code{base}).
#' If \code{to_latex} is \code{TRUE}, it returns a \code{tikz_code} object containing the LaTeX code.
#' @export
plot = function(
object_names = TRUE,
to_latex = FALSE,
method = c("sugiyama", "force"),
mode = NULL,
viewer = c("ggraph", "base"),
theme = "standard",
...
) {
# 1. Verificación de estado
if (self$size() == 0) {
warning("No concepts to plot.", call. = FALSE)
return(invisible(NULL))
}
private$build_adjacency()
private$build_covering()
# 2. Construcción del índice de nodos (Data Frame mínimo)
# Solo creamos los IDs (1..N). La función externa calculará grados y layout.
nodes_df <- data.frame(
id = seq_len(self$size()),
stringsAsFactors = FALSE
)
# --- CONVERSIÓN IMPORTANTE ---
# Convertimos los SparseSets a listas estándar de R para que la función de plot
# pueda hacer `extents[[i]]` sin errores S4.
extents_list <- sparse_to_list(private$pr_extents)
intents_list <- sparse_to_list(private$pr_intents)
# 3. Delegación a lattice_plot
# Pasamos los datos privados necesarios (matriz, objetos, atributos)
method <- match.arg(method)
viewer <- match.arg(viewer)
lattice_plot(
nodes_df = nodes_df,
cover_matrix = private$covering_matrix,
method = method, # Pasamos el método
mode = mode, # Pasamos el modo (o NULL para heurística)
objects = private$objects,
attributes = private$attributes,
# Pasamos los conjuntos dispersos para calcular reduced/full labels
extents = extents_list,
intents = intents_list,
object_names = self$objects,
to_latex = to_latex,
viewer = viewer,
theme = theme,
...
)
},
#' @description
#' Sublattice
#'
#' @param ... See Details.
#'
#' @details
#' As argument, one can provide both integer indices or \code{Concepts}, separated by commas. The corresponding concepts are used to generate a sublattice.
#'
#' @return
#' The generated sublattice as a new \code{ConceptLattice} object.
#'
#' @export
sublattice = function(...) {
idx <- private$to_indices(...)
if (length(idx) > 0) {
private$build_adjacency()
idx <- .get_sublattice(private$subconcept_matrix, starting_idx = idx)
if (length(idx) > 1) {
my_intents <- private$pr_intents[, idx]
my_extents <- private$pr_extents[, idx]
} else {
my_intents <- .extract_column(private$pr_intents, idx)
my_extents <- .extract_column(private$pr_extents, idx)
}
cl <- ConceptLattice$new(
extents = my_extents,
intents = my_intents,
objects = private$objects,
attributes = private$attributes,
I = private$I
)
return(cl)
}
},
#' @description
#' Build a sublattice from selected concepts
#'
#' @param attributes Character vector of attribute names, or \code{NULL} (default).
#' @param match \code{"all"} (default) or \code{"any"}: how to combine several attributes.
#' @param min_support Numeric in \eqn{[0, 1]}. Discard concepts with smaller support.
#' @param top_n Integer or \code{NULL}. Keep the \code{top_n} concepts with highest support.
#' @param verbose Logical; print a short summary.
#'
#' @return A \code{ConceptLattice} object.
#' @export
sublattice_from = function(attributes = NULL,
match = c("all", "any"),
min_support = 0,
top_n = 7L,
verbose = TRUE) {
match <- match.arg(match)
n_all <- self$size()
if (n_all < 1L) {
stop("No concepts found. Call find_concepts() first.", call. = FALSE)
}
if (!is.numeric(min_support) || length(min_support) != 1L ||
is.na(min_support) || min_support < 0 || min_support > 1) {
stop("`min_support` must be a single number in [0, 1].", call. = FALSE)
}
if (!is.null(top_n)) {
top_n <- as.integer(top_n)
if (length(top_n) != 1L || is.na(top_n) || top_n < 1L) {
stop("`top_n` must be a positive integer or NULL.", call. = FALSE)
}
}
candidates <- seq_len(n_all)
query <- list(
attributes = attributes,
match = if (!is.null(attributes)) match else NA_character_,
min_support = min_support,
top_n = top_n
)
# Filter by attributes in the intent
if (!is.null(attributes)) {
atts <- private$attributes
attributes <- as.character(attributes)
if (length(attributes) == 0L) {
stop("`attributes` must be non-empty or NULL.", call. = FALSE)
}
unknown <- setdiff(attributes, atts)
if (length(unknown) > 0L) {
stop(
"Unknown attribute(s): ", paste(unknown, collapse = ", "),
"\nAvailable: ", paste(atts, collapse = ", "),
call. = FALSE
)
}
intents <- self$intents()
rows <- match(attributes, atts)
present <- lapply(rows, function(r) {
as.vector(intents[r, , drop = FALSE] > 0)
})
if (match == "all") {
hit <- Reduce(`&`, present)
} else {
hit <- Reduce(`|`, present)
}
candidates <- which(hit)
if (length(candidates) == 0L) {
stop(
"No concepts have ", match, " of {",
paste(attributes, collapse = ", "), "} in their intent.",
call. = FALSE
)
}
}
# Filter by minimum support
sup <- self$support()
if (min_support > 0) {
candidates <- candidates[sup[candidates] >= min_support]
if (length(candidates) == 0L) {
stop(
"No concepts left with support >= ", min_support, ".",
call. = FALSE
)
}
}
n_candidates <- length(candidates)
# Rank by support
ord <- order(sup[candidates], decreasing = TRUE)
ranked <- candidates[ord]
if (is.null(top_n)) {
generators <- ranked
if (length(generators) > 25L) {
warning(
length(generators),
" concepts will generate the sublattice; ",
"the join/meet closure may be slow and the plot hard to read. ",
"Consider setting top_n (e.g. top_n = 8).",
call. = FALSE
)
}
} else {
if (top_n > length(ranked)) {
if (isTRUE(verbose)) {
message(
"top_n = ", top_n, " > ", length(ranked),
" candidates; using all candidates."
)
}
top_n <- length(ranked)
}
generators <- ranked[seq_len(top_n)]
}
sub <- self$sublattice(generators)
if (isTRUE(verbose)) {
how <- if (is.null(attributes)) {
"by support"
} else {
paste0(
"intent contains ", match, " of {",
paste(attributes, collapse = ", "), "}"
)
}
message(sprintf(
"sublattice_from: %s; %d candidate(s) -> %d generator(s) -> %d concept(s)",
how, n_candidates, length(generators), sub$size()
))
}
attr(sub, "generators") <- generators
attr(sub, "n_candidates") <- n_candidates
attr(sub, "query") <- query
return(sub)
},
#' @description Top of a Lattice
#'
#' @return The top of the Concept Lattice
#' @export
#'
#' @examples
#' fc <- FormalContext$new(planets)
#' fc$find_concepts()
#' fc$concepts$top()
#'
top = function() {
private$build_adjacency()
idx <- which(Matrix::colSums(private$subconcept_matrix) == self$size())
self[idx]$to_list()[[1]]
},
#' @description Bottom of a Lattice
#'
#' @return The bottom of the Concept Lattice
#' @export
#'
#' @examples
#' fc <- FormalContext$new(planets)
#' fc$find_concepts()
#' fc$concepts$bottom()
#'
bottom = function() {
private$build_adjacency()
idx <- which(Matrix::colSums(private$subconcept_matrix) == 1)
self[idx]$to_list()[[1]]
},
#' @description
#' Join-irreducible Elements
#'
#' @return
#' The join-irreducible elements in the concept lattice.
#'
#' @export
#'
join_irreducibles = function() {
private$build_adjacency()
private$build_covering()
idx <- which(Matrix::colSums(private$covering_matrix) == 1)
self[idx]
},
#' @description
#' Meet-irreducible Elements
#'
#' @return
#' The meet-irreducible elements in the concept lattice.
#'
#' @export
#'
meet_irreducibles = function() {
private$build_adjacency()
M <- .reduce_transitivity(Matrix::t(private$subconcept_matrix))
idx <- which(Matrix::colSums(M) == 1)
self[idx]
},
#' @description
#' Decompose a concept as the supremum of meet-irreducible concepts
#'
#' @param C A list of \code{Concept}s
#' @return
#' A list, each field is the set of meet-irreducible elements whose supremum is the corresponding element in \code{C}.
#'
#' @export
#'
decompose = function(C) {
irreducible <- self$meet_irreducibles()
irr_intents <- irreducible$intents()
C_intents <- C$intents()
ss <- lapply(
seq(C$size()),
function(i) {
r <- Matrix::Matrix(C_intents[, i], sparse = TRUE)
if (sum(r) == 0) {
return(C[i])
}
id <- Matrix::which(.subset(
irr_intents,
r
))
if (length(id) > 1) {
MM <- .subset(irr_intents[, id])
id <- id[Matrix::rowSums(MM) == 1]
}
decomposition <- irreducible[id]
return(decomposition)
}
)
return(ss)
},
#' @description
#' Supremum of Concepts
#'
#' @param ... See Details.
#'
#' @details
#' As argument, one can provide both integer indices or \code{Concepts}, separated by commas. The corresponding concepts are used to compute their supremum in the lattice.
#'
#' @return
#' The supremum of the list of concepts.
#'
#' @export
supremum = function(...) {
idx <- private$to_indices(...)
private$build_adjacency()
return(self[join(private$subconcept_matrix, idx)]$to_list()[[1]])
},
#' @description
#' Infimum of Concepts
#'
#' @param ... See Details.
#'
#' @details
#' As argument, one can provide both integer indices or \code{Concepts}, separated by commas. The corresponding concepts are used to compute their infimum in the lattice.
#'
#' @return
#' The infimum of the list of concepts.
#'
#' @export
infimum = function(...) {
idx <- private$to_indices(...)
private$build_adjacency()
return(self[meet(private$subconcept_matrix, idx)]$to_list()[[1]])
},
#' @description
#' Subconcepts of a Concept
#'
#' @param C (numeric or \code{SparseConcept}) The concept to which determine all its subconcepts.
#'
#' @return
#' A list with the subconcepts.
#' @export
subconcepts = function(C) {
idx <- private$to_indices(C)
private$build_adjacency()
# Get the index of all subconcepts
M <- Matrix::t(private$subconcept_matrix)[idx, ]
candidates <- Matrix::which(M > 0)
if (length(candidates) > 1) {
return(
ConceptLattice$new(
attributes = private$attributes,
objects = private$objects,
extents = private$pr_extents[, candidates],
intents = private$pr_intents[, candidates],
I = private$I
)
)
}
return(
ConceptLattice$new(
attributes = private$attributes,
objects = private$objects,
extents = .extract_column(
private$pr_extents,
candidates
),
intents = .extract_column(
private$pr_intents,
candidates
),
I = private$I
)
)
},
#' @description
#' Superconcepts of a Concept
#'
#' @param C (numeric or \code{SparseConcept}) The concept to which determine all its superconcepts.
#'
#' @return
#' A list with the superconcepts.
#' @export
superconcepts = function(C) {
idx <- private$to_indices(C)
private$build_adjacency()
# Get the index of all superconcepts
M <- private$subconcept_matrix[idx, ]
candidates <- which(M > 0)
if (length(candidates) > 1) {
return(
ConceptLattice$new(
attributes = private$attributes,
objects = private$objects,
extents = private$pr_extents[, candidates],
intents = private$pr_intents[, candidates],
I = private$I
)
)
}
return(
ConceptLattice$new(
attributes = private$attributes,
objects = private$objects,
extents = .extract_column(
private$pr_extents,
candidates
),
intents = .extract_column(
private$pr_intents,
candidates
),
I = private$I
)
)
},
#' @description
#' Lower Neighbours of a Concept
#'
#' @param C (\code{SparseConcept}) The concept to which find its lower neighbours
#'
#' @return
#' A list with the lower neighbours of \code{C}.
#'
#' @export
lower_neighbours = function(C) {
idx <- private$to_indices(C)
private$build_adjacency()
private$build_covering()
self[which(private$covering_matrix[, idx] > 0)]
},
#' @description
#' Upper Neighbours of a Concept
#'
#' @param C (\code{SparseConcept}) The concept to which find its upper neighbours
#'
#' @return
#' A list with the upper neighbours of \code{C}.
#'
#' @export
upper_neighbours = function(C) {
idx <- private$to_indices(C)
private$build_adjacency()
private$build_covering()
self[which(private$covering_matrix[idx, ] > 0)]
},
#' @description
#' Computes the stability of each concept.
#'
#' @return A numeric vector with the stability of each concept.
#' @export
stability = function() {
if (self$size() == 0) {
return(numeric(0))
}
# Pass internal sparse extents directly
return(calculate_stability(private$pr_extents))
},
#' @description
#' Computes the separation of each concept.
#' Separation is the number of objects covered by the concept but not by any of its immediate subconcepts.
#'
#' @return A numeric vector with the separation of each concept.
#' @importFrom Matrix rowSums
#' @export
separation = function() {
if (self$size() == 0) {
return(numeric(0))
}
private$build_adjacency()
# 1. Obtener la matriz de extents (Objetos x Conceptos)
M <- as(private$pr_extents, "CsparseMatrix")
# 2. Obtener la relación de cobertura (Hijos directos)
# Usamos la función interna .reduce_transitivity disponible en el paquete
# Se aplica sobre la matriz de subconceptos (orden parcial)
# Asumimos que subconcept_matrix es C_i <= C_j
private$build_covering()
cover_matrix <- private$covering_matrix
# 3. Calcular separación usando el helper (definido en metrics.R)
# Pasamos M (extents) y cover_matrix (grafo)
return(calculate_separation_internal(M, cover_matrix))
},
#' @description
#' Computes the fuzzy density of each concept.
#'
#' @param I (Optional) The original incidence matrix. If NULL, it tries to access it from the parent FormalContext if linked.
#' @return A numeric vector with the density of each concept.
#' @export
density = function(I = NULL) {
if (self$size() == 0) {
return(numeric(0))
}
# Ideally, ConceptLattice should know about I.
# If not passed, we might default to binary (density 1) or error.
if (is.null(I)) {
# User must provide I if not stored.
# For now, return NA or 1 if binary.
warning("Incidence matrix I not provided. Assuming density = 1.")
return(rep(1.0, self$size()))
}
return(calculate_density(private$pr_extents, private$pr_intents, I))
},
#' @description
#' Check if the lattice is distributive.
#' A lattice is distributive if \eqn{x \wedge (y \vee z) = (x \wedge y) \vee (x \wedge z)} for all elements.
#' @return Logical.
#' @export
is_distributive = function() {
if (!is.na(private$properties$distributivity)) {
return(private$properties$distributivity)
}
private$build_structure()
res <- check_distributivity_internal(
private$meet_matrix,
private$join_matrix
)
private$properties$distributivity <- res
return(res)
},
#' @description
#' Check if the lattice is modular.
#' A lattice is modular if \eqn{x \le z \implies x \vee (y \wedge z) = (x \vee y) \wedge z}.
#' Distributive lattices are always modular.
#' @return Logical.
#' @export
is_modular = function() {
if (!is.na(private$properties$modularity)) {
return(private$properties$modularity)
}
private$build_structure()
res <- check_modularity_internal(private$meet_matrix, private$join_matrix)
private$properties$modularity <- res
return(res)
},
#' @description
#' Check if the lattice is upper semimodular.
#' A lattice is upper semimodular if for every \eqn{x, y}: if \eqn{x} covers \eqn{x \wedge y}, then \eqn{x \vee y} covers \eqn{y}.
#' @return Logical.
#' @export
is_semimodular = function() {
if (!is.na(private$properties$semimodularity)) {
return(private$properties$semimodularity)
}
private$build_structure()
# Necesita Meet, Join y la relación de Cobertura
res <- check_semimodularity_internal(
private$meet_matrix,
private$join_matrix,
private$covering_matrix
)
private$properties$semimodularity <- res
return(res)
},
#' @description
#' Check if the lattice is atomic.
#' A lattice is atomic if for every element \eqn{x > \bot}, there exists an atom \eqn{a} such that \eqn{a \le x}.
#' Atoms are elements that cover the bottom element.
#' @return Logical.
#' @export
is_atomic = function() {
if (!is.na(private$properties$atomicity)) {
return(private$properties$atomicity)
}
private$build_structure()
# Necesita Adyacencia (Orden) y Cobertura (Hasse)
res <- check_atomicity_internal(
private$subconcept_matrix,
private$covering_matrix
)
private$properties$atomicity <- res
return(res)
},
#' @description
#' Computes the Dilworth's width of the lattice.
#' The width is the size of the largest antichain.
#' @return Integer.
#' @export
width = function() {
if (!is.na(private$properties$width)) {
return(private$properties$width)
}
private$build_adjacency()
adj <- private$subconcept_matrix
res <- calculate_width_cpp(adj@i, adj@p, adj@Dim[1])
private$properties$width <- res
return(res)
},
#' @description
#' Computes the order dimension (Dushnik-Miller) of the lattice.
#' Note: This uses a heuristic and may return an estimate for large lattices.
#' @return Integer.
#' @export
dimension = function() {
if (!is.na(private$properties$dimension)) {
return(private$properties$dimension)
}
private$build_adjacency()
adj <- private$subconcept_matrix
res <- calculate_dimension_heuristic_cpp(adj@i, adj@p, adj@Dim[1])
private$properties$dimension <- res
return(res)
},
#' @description
#' Internal method to set state from JSON import
#' @param state List of internal state variables
set_state = function(state) {
private$pr_extents <- state$extents
private$pr_intents <- state$intents
private$objects <- state$objects
private$attributes <- state$attributes
# Reconstruct basic info
# Hierarchy? covering_matrix?
# If hierarchy is provided, rebuild covering matrix
if (!is.null(state$hierarchy)) {
# List of source->target
# Rebuild covering matrix
n <- ncol(private$pr_extents)
i_idx <- integer(0)
j_idx <- integer(0)
for (h in state$hierarchy) {
i_idx <- c(i_idx, h$source)
j_idx <- c(j_idx, h$target)
}
if (length(i_idx) > 0) {
private$covering_matrix <- Matrix::sparseMatrix(
i = i_idx,
j = j_idx,
dims = c(n, n),
x = 1
)
}
}
},
#' @description
#' Export the concept lattice to JSON
#'
#' @param file (character) The path of the file to save the JSON to.
#' @param return_list (logical) If TRUE, returns the list representation instead of the JSON string.
#'
#' @return A JSON string representing the concept lattice, or a list if \code{return_list} is TRUE.
#' @export
to_json = function(file = NULL, return_list = FALSE) {
check_needed_pkg("jsonlite", "export to JSON")
# Helper to convert sparse matrix to list of indices/values
mat_to_list <- function(M) {
if (is.null(M)) {
return(list())
}
# Fix deprecation: use TsparseMatrix directly if possible, or via generalMatrix
# Trying direct cast first
T <- as(M, "TsparseMatrix")
if (length(T@x) == 0 && length(T@i) == 0) {
return(replicate(ncol(M), integer(0), simplify = FALSE))
}
# 1-based indices
df <- data.frame(i = T@i + 1, j = T@j + 1)
res <- split(df$i, factor(df$j, levels = seq_len(ncol(M))))
return(res)
}
# Extents and Intents (Concepts are columns)
extents_list <- mat_to_list(private$pr_extents)
intents_list <- mat_to_list(private$pr_intents)
concepts <- lapply(seq_len(self$size()), function(k) {
list(
id = k,
extent = extents_list[[k]],
intent = intents_list[[k]]
)
})
# Hierarchy (Covering relation)
private$build_covering()
hierarchy <- list()
if (!is.null(private$covering_matrix)) {
T <- as(as(private$covering_matrix, "dgCMatrix"), "dgTMatrix")
if (length(T@i) > 0) {
hierarchy <- lapply(seq_along(T@i), function(k) {
list(source = T@i[k] + 1, target = T@j[k] + 1)
})
}
}
# Context I
I_data <- NULL
if (!is.null(private$I)) {
I_data <- mat_to_list(Matrix::t(private$I))
}
out <- list(
type = "ConceptLattice",
objects = private$objects,
attributes = private$attributes,
concepts = concepts,
hierarchy = hierarchy,
I = I_data
)
if (return_list) {
return(out)
}
json <- jsonlite::toJSON(out, auto_unbox = TRUE)
if (!is.null(file)) {
writeLines(json, file)
}
return(json)
}
),
private = list(
properties = list(
distributivity = NA,
modularity = NA,
semimodularity = NA,
atomicity = NA,
width = NA,
dimension = NA
),
subconcept_matrix = NULL,
covering_matrix = NULL,
meet_matrix = NULL,
join_matrix = NULL,
build_adjacency = function() {
if (self$size() == 0) {
return(invisible(self))
}
if (is.null(private$subconcept_matrix)) {
private$subconcept_matrix <- .subset(private$pr_extents)
}
invisible(self)
},
build_covering = function() {
private$build_adjacency()
if (is.null(private$subconcept_matrix)) {
return(NULL)
}
if (is.null(private$covering_matrix)) {
private$covering_matrix <- as(
.reduce_transitivity(private$subconcept_matrix),
"nMatrix"
)
}
invisible(self)
},
build_meet_join = function() {
private$build_adjacency()
if (is.null(private$meet_matrix)) {
adj <- private$subconcept_matrix
# 2. Llamada a C++
# Pasamos punteros de la nMatrix
res <- compute_meet_join_cpp(adj@i, adj@p, adj@Dim)
# 3. Reconstruir ngCMatrix
# Nota: C++ devuelve base-1 en 'x' y base-0 en 'i' (para slots internos)
# Pero para new(), 'x' son los valores.
private$meet_matrix <- new(
"dgCMatrix",
i = res$meet$i,
p = res$meet$p,
x = as.double(res$meet$x),
Dim = res$meet$Dim
)
private$join_matrix <- new(
"dgCMatrix",
i = res$join$i,
p = res$join$p,
x = as.double(res$join$x),
Dim = res$join$Dim
)
}
return(invisible(self))
},
build_structure = function() {
private$build_adjacency()
private$build_covering()
private$build_meet_join()
},
can_plot = TRUE,
concept_list_to_indices = function(concept_list) {
extents <- lapply(
concept_list,
function(l) l$get_extent()$get_vector()
)
extents <- Reduce(cbind, extents)
indices <- .equal_sets(
x = extents,
y = private$pr_extents
)
indices <- arrayInd(Matrix::which(indices), .dim = dim(indices))[, 2]
return(indices)
},
to_indices = function(...) {
dots <- list(...)
if (is.list(dots[[1]])) {
dots <- unlist(dots)
}
if (is.logical(dots[[1]])) {
return(which(dots[[1]]))
}
csets_idx <- sapply(
dots,
function(l) inherits(l, "ConceptSet")
)
if (length(csets_idx) > 0) {
csets <- sapply(
dots[csets_idx],
function(l) l$to_list()
) |>
unlist()
} else {
csets <- c()
}
sets <- sapply(
dots,
function(l) {
inherits(l, "Concept")
}
)
sets <- c(csets, dots[which(sets)])
indices <- sapply(dots, is.numeric)
idx <- c()
if (length(indices) > 0) {
idx <- c(idx, Reduce(c, dots[indices]))
}
if (length(sets) > 0) {
idx <- c(
idx,
private$concept_list_to_indices(sets)
)
}
return(idx)
}
)
)
Try the fcaR package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.