Nothing
R/formal_context.R
In fcaR: Formal Concept Analysis
#' @title
#' R6 class for a formal context
#'
#' @description
#' This class implements the data structure and methods for formal contexts.
#'
#' @examples
#' # Build and print the formal context
#' fc_planets <- FormalContext$new(planets)
#' print(fc_planets)
#'
#' # Define a set of attributes
#' S <- Set$new(attributes = fc_planets$attributes)
#' S$assign(moon = 1, large = 1)
#'
#' # Compute the closure of S
#' Sc <- fc_planets$closure(S)
#' # Is Sc a closed set?
#' fc_planets$is_closed(Sc)
#'
#' # Clarify and reduce the formal context
#' fc2 <- fc_planets$reduce(TRUE)
#'
#' # Find implications
#' fc_planets$find_implications()
#'
#' # Read a formal context from CSV
#' filename <- system.file("contexts", "airlines.csv", package = "fcaR")
#' fc <- FormalContext$new(filename)
#'
#' # Read a formal context from a CXT file
#' filename <- system.file("contexts", "lives_in_water.cxt", package = "fcaR")
#' fc <- FormalContext$new(filename)
#'
#' @references
#'
#' Guigues J, Duquenne V (1986). “Familles minimales d'implications informatives résultant d'un tableau de données binaires.” _Mathématiques et Sciences humaines_, *95*, 5-18.
#'
#' Ganter B, Wille R (1999). _Formal concept analysis : mathematical foundations_. Springer. ISBN 3540627715.
#'
#' Belohlavek R (2002). “Algorithms for fuzzy concept lattices.” In _Proc. Fourth Int. Conf. on Recent Advances in Soft Computing_. Nottingham, United Kingdom, 200-205.
#'
#' Hahsler M, Grun B, Hornik K (2005). “arules - a computational environment for mining association rules and frequent item sets.” _J Stat Softw_, *14*, 1-25.
#'
#' @export
FormalContext <- R6::R6Class(
classname = "FormalContext",
public = list(
#' @field I The table of the formal context as a matrix.
I = NULL,
#' @field attributes The attributes of the formal context.
attributes = NULL,
#' @field objects The objects of the formal context.
objects = NULL,
#' @field grades_set The set of degrees (in \[0, 1\]) the whole set of attributes can take.
grades_set = NULL,
#' @field expanded_grades_set The set of degrees (in \[0, 1\]) each attribute can take.
expanded_grades_set = NULL,
#' @field concepts The concept lattice associated to the formal context as a \code{\link{ConceptLattice}}.
concepts = NULL,
#' @field implications A set of implications on the formal context as an \code{\link{ImplicationSet}}.
implications = NULL,
#' @description
#' Creator for the Formal Context class
#'
#' @param I (numeric matrix) The table of the formal context.
#' @param filename (character) Path of a file to import.
#' @param remove_const (logical) If \code{TRUE}, remove constant columns. The default is \code{FALSE}.
#'
#' @details
#' Columns of \code{I} should be named, since they are the names of the attributes of the formal context.
#'
#' If no \code{I} is used, the resulting \code{FormalContext} will be empty and not usable unless for loading a previously saved one. In this case, one can provide a \code{filename} to import. Only RDS, CSV and CXT files are currently supported.
#'
#' @return An object of the \code{FormalContext} class.
#' @export
#'
initialize = function(I, filename,
remove_const = FALSE) {
if (missing(I)) {
if (!missing(filename) && file.exists(filename)) {
self$load(filename)
}
return(invisible(self))
}
if ((length(I) == 1) && is.character(I) && file.exists(I)) {
self$load(I)
return(invisible(self))
}
version
if (!capabilities()["long.double"] & getRversion() < "4.1.0") {
private$can_plot <- FALSE
}
# Transform the formal context to sparse
if (inherits(I, "transactions")) {
# If it comes from the arules package
attributes <- I@itemInfo$labels
I <- convert_to_sparse(I@data)
objects <- paste0(seq(ncol(I)))
dimnames(I) <- list(attributes, objects)
} else {
# Or if it comes from a numeric table
if (length(colnames(I)) > 0) {
attributes <- colnames(I)
} else {
attributes <- paste0("A", seq(ncol(I)))
}
if (length(rownames(I)) > 0) {
objects <- rownames(I)
} else {
objects <- paste0("O", seq(nrow(I)))
}
private$is_many_valued <- check_many_valued(I)
if (!private$is_many_valued) {
I <- as.matrix(I)
# Remove the constant columns
if (remove_const) {
constant_cols <- which(apply(I, 2, max) == apply(I, 2, min))
if (length(constant_cols) > 0) {
str <- paste0("Removed constant columns: ", stringr::str_flatten(attributes[constant_cols], collapse = ", "))
message(stringr::str_wrap(str,
exdent = 2,
width = 75))
I <- I[, -constant_cols]
attributes <- attributes[-constant_cols]
}
}
# # TODO: save tI???
# tI <- new_spm(I)
# I <- new_spm(t(I))
I <- convert_to_sparse(
Matrix::Matrix(t(I), sparse = TRUE))
}
}
self$objects <- objects
self$attributes <- attributes
if (!private$is_many_valued) {
# Assign everything to its corresponding field
expanded_grades_set <- compute_grades(Matrix::t(I))
grades_set <- sort(unique(unlist(expanded_grades_set)))
self$I <- I
self$grades_set <- unique(c(0, grades_set, 1))
self$expanded_grades_set <- expanded_grades_set
colnames(self$I) <- self$objects
rownames(self$I) <- self$attributes
# Is the FormalContext binary?
private$is_binary <- length(self$grades_set) == 2
} else {
# browser()
private$many_valued_I <- I
# colnames(private$many_valued_I) <- self$objects
# rownames(private$many_valued_I) <- self$attributes
}
# Create a new empty implication set inside
self$implications <- ImplicationSet$new(attributes = attributes,
I = self$I)
# Create a new empty ConceptLattice inside
self$concepts <- ConceptLattice$new(extents = NULL,
intents = NULL,
objects = self$objects,
attributes = self$attributes,
I = self$I)
},
#' @description
#' Check if the \code{FormalContext} is empty
#'
#' @return \code{TRUE} if the \code{FormalContext} is empty, that is, has not been provided with a matrix, and \code{FALSE} otherwise.
#'
#' @export
is_empty = function() {
return(is.null(self$I) && is.null(private$many_valued_I))
},
#' @description
#' Scale the context
#'
#' @param attributes The attributes to scale
#' @param type Type of scaling.
#' @param ...
#'
#' @details
#' The types of scaling are implemented in a registry,
#' so that \code{scalingRegistry$get_entries()} returns
#' all types.
#'
#' @return The scaled formal context
#' @export
#' @examples
#' filename <- system.file("contexts", "aromatic.csv", package = "fcaR")
#' fc <- FormalContext$new(filename)
#' fc$scale("nitro", "ordinal", comparison = `>=`, values = 1:3)
#' fc$scale("OS", "nominal", c("O", "S"))
#' fc$scale(attributes = "ring", type = "nominal")
scale = function(attributes, type, ...) {
# TODO: Check that the attributes are in self$attributes
I <- self$incidence()
for (att in attributes) {
scaled <-
scale_context(I, column = att,
type = type,
...)
I <- scaled$derived
private$scales <- c(private$scales,
scaled$scale)
names(private$scales)[length(private$scales)] <- att
# Add implications to the bg_implications
private$bg_implications <- combine_implications(
private$bg_implications,
scaled$bg_implications)
# if (scaled$bg_implications$cardinality() > 0) {
#
# private$bg_implications$to_basis()
#
# }
}
self$initialize(I)
},
#' @description
#' Scales applied to the formal context
#'
#' @param attributes (character) Name of the attributes for which scales
#' (if applied) are returned.
#'
#' @return The scales that have been applied to the specified attributes
#' of the formal context. If no \code{attributes} are passed,
#' then all applied scales are returned.
#'
#' @export
#' @examples
#' filename <- system.file("contexts", "aromatic.csv", package = "fcaR")
#' fc <- FormalContext$new(filename)
#' fc$scale("nitro", "ordinal", comparison = `>=`, values = 1:3)
#' fc$scale("OS", "nominal", c("O", "S"))
#' fc$scale(attributes = "ring", type = "nominal")
#' fc$get_scales()
get_scales = function(attributes = names(private$scales)) {
# TODO: Get the scales applied to only one or some
# of the self$attributes.
attributes <- attributes[attributes %in% names(private$scales)]
res <- private$scales[attributes]
if (length(res) > 0) {
if (length(res) > 1) {
return(res)
} else {
return(res[[1]])
}
} else {
message("No scaling has been performed on these attributes.")
}
},
#' @description
#' Background knowledge of a scaled formal context
#'
#' @return
#' An \code{ImplicationSet} with the implications
#' extracted from the application of scales.
#'
#' @export
#'
#' @examples
#' filename <- system.file("contexts", "aromatic.csv", package = "fcaR")
#' fc <- FormalContext$new(filename)
#' fc$scale("nitro", "ordinal", comparison = `>=`, values = 1:3)
#' fc$scale("OS", "nominal", c("O", "S"))
#' fc$scale(attributes = "ring", type = "nominal")
#' fc$background_knowledge()
background_knowledge = function() {
if (!is.null(private$bg_implications)) {
if (is.null(private$bg_implications_basis)) {
private$bg_implications_basis <- private$bg_implications$clone()
# private$bg_implications_basis$to_basis()
suppressMessages(private$bg_implications_basis$apply_rules(c("comp", "simp", "rsimp")))
}
private$bg_implications_basis$clone()
# private$bg_implications$clone()
} else {
ImplicationSet$new(attributes = self$attributes)
}
},
#' @description
#' Get the dual formal context
#'
#' @return A \code{FormalContext} where objects and attributes have interchanged their roles.
#'
#' @export
dual = function() {
if (private$is_many_valued) {
return(FormalContext$new(t(private$many_valued_I)))
} else {
I <- Matrix::as.matrix(self$I)
colnames(I) <- self$objects
rownames(I) <- self$attributes
return(FormalContext$new(I))
}
},
#' @description
#' Get the intent of a fuzzy set of objects
#'
#' @param S (\code{Set}) The set of objects to compute the intent for.
#'
#' @return A \code{Set} with the intent.
#'
#' @export
intent = function(S) {
if (private$is_many_valued) error_many_valued()
if (inherits(S, "Set")) {
if (all(S$get_attributes() == self$objects)) {
S <- S$get_vector()
} else {
S <- match_attributes(S, self$objects)
S <- S$get_vector()
warn <- c("The attributes in the input set are not the same",
" that in the formal context. Attempting to match",
" attribute names gives ",
.set_to_string(S, self$objects)) %>%
stringr::str_flatten()
warning(warn, call. = FALSE, immediate. = TRUE)
# stop("It is not a set of the required type (set of objects).", call. = FALSE)
}
}
if (length(S) == length(self$objects)) {
R <- compute_intent(
S,
Matrix::as.matrix(Matrix::t(self$I)),
connection = private$connection,
name = private$logic)
if (length(R@i) > 0) {
# Non-empty set:
R <- Matrix::sparseMatrix(i = R@i + 1,
j = rep(1, length(R@i)),
x = R@x,
dims = c(length(self$attributes), 1))
R <- Set$new(attributes = self$attributes,
M = R)
} else {
# Empty intent
R <- Set$new(attributes = self$attributes)
}
return(R)
} else {
stop("It is not a set of the required type (set of objects).", call. = FALSE)
}
},
#' @description
#' Get the intent of a fuzzy set of objects
#'
#' @param S (\code{Set}) The set of objects to compute the intent for.
#'
#' @return A \code{Set} with the intent.
#'
#' @export
uparrow = function(S) {
self$intent(S)
},
#' @description
#' Get the extent of a fuzzy set of attributes
#'
#' @param S (\code{Set}) The set of attributes to compute the extent for.
#'
#' @return A \code{Set} with the intent.
#'
#' @export
extent = function(S) {
# TODO: Apply scales to Sets.
if (private$is_many_valued) error_many_valued()
if (inherits(S, "Set")) {
if (all(S$get_attributes() == self$attributes)) {
S <- S$get_vector()
} else {
S <- match_attributes(S, self$attributes)
S <- S$get_vector()
warn <- c("The attributes in the input set are not the same",
" that in the formal context. Attempting to match",
" attribute names gives ",
.set_to_string(S, self$attributes)) %>%
stringr::str_flatten()
warning(warn, call. = FALSE, immediate. = TRUE)
# stop("It is not a set of the required type (set of attributes).", call. = FALSE)
}
}
if (length(S) == length(self$attributes)) {
R <- compute_extent(
S,
Matrix::as.matrix(Matrix::t(self$I)),
connection = private$connection,
name = private$logic)
if (length(R@i) > 0) {
# Non-empty set:
R <- Matrix::sparseMatrix(i = R@i + 1,
j = rep(1, length(R@i)),
x = R@x,
dims = c(length(self$objects), 1))
R <- Set$new(attributes = self$objects,
M = R)
} else {
# Empty extent
R <- Set$new(attributes = self$objects)
}
return(R)
} else {
stop("It is not a set of the required type (set of objects).", call. = FALSE)
}
},
#' @description
#' Get the extent of a fuzzy set of attributes
#'
#' @param S (\code{Set}) The set of attributes to compute the extent for.
#'
#' @return A \code{Set} with the intent.
#'
#' @export
downarrow = function(S) {
self$extent(S)
},
#' @description
#' Get the closure of a fuzzy set of attributes
#'
#' @param S (\code{Set}) The set of attributes to compute the closure for.
#'
#' @return A \code{Set} with the closure.
#'
#' @export
closure = function(S) {
if (private$is_many_valued) error_many_valued()
if (inherits(S, "Set")) {
if (all(S$get_attributes() == self$attributes)) {
S <- S$get_vector()
} else {
S <- match_attributes(S, self$attributes)
S <- S$get_vector()
warn <- c("The attributes in the input set are not the same",
" that in the formal context. Attempting to match",
" attribute names gives ",
.set_to_string(S, self$attributes)) %>%
stringr::str_flatten()
warning(warn, call. = FALSE, immediate. = TRUE)
# stop("It is not a set of the required type (set of attributes).", call. = FALSE)
}
}
if (length(S) == length(self$attributes)) {
R <- compute_closure(
S,
Matrix::as.matrix(Matrix::t(self$I)),
connection = private$connection,
name = private$logic)
if (length(R@i) > 0) {
# Non-empty set:
R <- Matrix::sparseMatrix(i = R@i + 1,
j = rep(1, length(R@i)),
x = R@x,
dims = c(length(self$attributes), 1))
R <- Set$new(attributes = self$attributes,
M = R)
} else {
# Empty closure
R <- Set$new(attributes = self$attributes)
}
return(R)
} else {
stop("It is not a set of the required type (set of objects).", call. = FALSE)
}
},
#' @description
#' Object Concept
#'
#' @param object (character) Name of the object to compute its associated concept
#'
#' @return
#' The object concept associated to the object given.
#'
#' @export
obj_concept = function(object) {
if (private$is_many_valued) error_many_valued()
S <- Set$new(attributes = self$objects)
S$assign(attributes = object, values = 1)
B <- self$intent(S)
A <- self$extent(B)
C <- Concept$new(extent = A, intent = B)
return(C)
},
#' @description
#' Attribute Concept
#'
#' @param attribute (character) Name of the attribute to compute its associated concept
#'
#' @return
#' The attribute concept associated to the attribute given.
#'
#' @export
att_concept = function(attribute) {
if (private$is_many_valued) error_many_valued()
S <- Set$new(attributes = self$attributes)
S$assign(attributes = attribute, values = 1)
A <- self$extent(S)
B <- self$intent(A)
C <- Concept$new(extent = A, intent = B)
return(C)
},
#' @description
#' Is a Concept?
#'
#' @param C A \code{Concept} object
#'
#' @return
#' \code{TRUE} if \code{C} is a concept.
#'
#' @export
is_concept = function(C) {
O <- C$get_extent()
A <- C$get_intent()
# O should be the extent of A, and A should be intent of O
return((self$extent(A) %==% O) && (self$intent(O) %==% A))
},
#' @description
#' Testing closure of attribute sets
#'
#' @param S A \code{Set} of attributes
#'
#' @return
#' \code{TRUE} if the set \code{S} is closed in this formal context.
#' @export
is_closed = function(S) {
Sc <- self$closure(S)
return(S %==% Sc)
},
#' @description
#' Clarify a formal context
#'
#' @param copy (logical) If \code{TRUE}, a new \code{FormalContext} object is created with the clarified context, otherwise the current one is overwritten.
#'
#' @return The clarified \code{FormalContext}.
#'
#' @export
clarify = function(copy = FALSE) {
if (private$is_many_valued) error_many_valued()
# Redundant attributes
my_I <- .clarify_matrix(Matrix::t(self$I),
rows = self$objects,
cols = self$attributes)
# And redundant objects
my_I <- .clarify_matrix(Matrix::t(my_I),
rows = colnames(my_I),
cols = self$objects)
my_I <- Matrix::as.matrix(Matrix::t(my_I))
if (copy) {
fc2 <- FormalContext$new(my_I)
return(fc2)
} else {
self$initialize(my_I)
return(invisible(self))
}
},
#' @description
#' Reduce a formal context
#'
#' @param copy (logical) If \code{TRUE}, a new \code{FormalContext} object is created with the clarified and reduced context, otherwise the current one is overwritten.
#'
#' @return The clarified and reduced \code{FormalContext}.
#'
#' @export
reduce = function(copy = FALSE) {
if (!private$is_binary) {
stop("This FormalContext is not binary. Reduction is not implemented for fuzzy contexts.", call. = FALSE)
}
# Make a copy with the clarified context
fc2 <- self$clarify(TRUE)
my_I <- Matrix::as.matrix(Matrix::t(fc2$I))
att <- fc2$attributes
Z <- Set$new(attributes = att)
for (y in att) {
R <- Set$new(attributes = fc2$objects)
R$assign(attributes = fc2$objects,
values = rep(1, length(fc2$objects)))
R <- R$get_vector()
yv <- Set$new(attributes = att)
yv$assign(attributes = y, values = 1)
y_down <- fc2$extent(yv)
for (yp in setdiff(att, y)) {
ypv <- Set$new(attributes = att)
ypv$assign(attributes = yp, values = 1)
yp_down <- fc2$extent(ypv)
S <- .subset(y_down$get_vector(),
yp_down$get_vector())
if (S[1]) {
R[Matrix::which(yp_down$get_vector() < R)] <- yp_down$get_vector()[Matrix::which(yp_down$get_vector() < R)]
}
}
if (!.equal_sets(R, y_down$get_vector())[1]) {
Z$assign(attributes = y, values = 1)
}
}
new_att <- Z$get_attributes()[Matrix::which(Z$get_vector() > 0)]
idx <- match(new_att, att)
# if (length(idx) == 1) {
#
# my_I <- .extract_column(my_I, idx)
#
# } else {
#
# my_I <- my_I[, idx]
#
# }
my_I <- matrix(my_I[, idx], ncol = length(idx))
colnames(my_I) <- new_att
rownames(my_I) <- fc2$objects
if (copy) {
fc3 <- FormalContext$new(my_I)
return(fc3)
} else {
self$initialize(my_I)
return(invisible(self))
}
},
#' @description
#' Build the Standard Context
#'
#' @details
#' All concepts must be previously computed.
#'
#' @return
#' The standard context using the join- and meet- irreducible elements.
#' @export
standardize = function() {
if (private$is_many_valued) error_many_valued()
if (self$concepts$is_empty()) {
stop("Concepts must be computed beforehand.\n", call. = FALSE)
}
join_irr <- self$concepts$join_irreducibles()$to_list()
meet_irr <- self$concepts$meet_irreducibles()$to_list()
nj <- length(join_irr)
nm <- length(meet_irr)
I <- matrix(0, nrow = nj, ncol = nm)
for (i in seq(nj)) {
for (j in seq(nm)) {
I[i, j] <- ifelse(join_irr[[i]] %<=% meet_irr[[j]], 1, 0)
}
}
colnames(I) <- paste0("M", seq(nm))
rownames(I) <- paste0("J", seq(nj))
return(FormalContext$new(I))
},
#' @description
#' Use Ganter Algorithm to compute concepts
#'
#' @param verbose (logical) TRUE will provide a verbose output.
#'
#' @return A list with all the concepts in the formal context.
#'
#' @export
find_concepts = function(verbose = FALSE) {
private$check_empty()
if (private$is_many_valued) error_many_valued()
my_I <- Matrix::as.matrix(Matrix::t(self$I))
# my_I <- unique(my_I)
grades_set <- rep(list(self$grades_set), length(self$attributes))
# grades_set <- self$expanded_grades_set
attrs <- self$attributes
L <- next_closure_concepts(
I = my_I,
grades_set = grades_set,
attrs = attrs,
connection = private$connection,
name = private$logic,
verbose = verbose)
# Since the previous function gives the list of intents of
# the computed concepts, now we will compute the corresponding
# extents.
if (length(self$attributes) == 1) {
my_intents <- Matrix::Matrix(t(as.vector(L$intents)), sparse = TRUE)
my_extents <- Matrix::Matrix(t(as.vector(L$extents)), sparse = TRUE)
} else {
my_intents <- L$intents
my_extents <- L$extents
}
self$concepts <- ConceptLattice$new(
extents = my_extents,
intents = my_intents,
objects = self$objects,
attributes = self$attributes,
I = self$I)
if (verbose) {
cat("Number of closures", L$closure_count, "\n")
}
# return(invisible(self$concepts))
return(invisible(self))
},
#' @description
#' Use modified Ganter algorithm to compute both concepts and implications
#'
#' @param save_concepts (logical) \code{TRUE} will also compute and save the concept lattice. \code{FALSE} is usually faster, since it only computes implications.
#' @param verbose (logical) \code{TRUE} will provide a verbose output.
#'
#' @return Nothing, just updates the internal fields \code{concepts} and \code{implications}.
#'
#'
#' @export
find_implications = function(save_concepts = TRUE,
verbose = FALSE) {
private$check_empty()
if (private$is_many_valued) error_many_valued()
my_I <- Matrix::as.matrix(Matrix::t(self$I))
my_I <- unique(my_I)
grades_set <- rep(list(self$grades_set), length(self$attributes))
# grades_set <- self$expanded_grades_set
attrs <- self$attributes
# if (is.null(private$bg_implications)) {
L <- next_closure_implications(
I = my_I,
grades_set = grades_set,
attrs = attrs,
save_concepts = save_concepts,
connection = private$connection,
name = private$logic,
verbose = verbose)
# }
if (!is.null(private$bg_implications) && private$bg_implications$cardinality() > 0) {
private$bg_implications <- reorder_attributes(
private$bg_implications,
self$attributes
)
# n_bg <- private$bg_implications$cardinality()
#
# L <- next_closure_implications_bg2(I = my_I,
# grades_set = grades_set,
# attrs = attrs,
# lhs_bg = private$bg_implications$get_LHS_matrix(),
# rhs_bg = private$bg_implications$get_RHS_matrix(),
# n_bg = n_bg,
# save_concepts = save_concepts,
# verbose = verbose)
bg <- private$bg_implications$clone()
suppressMessages(bg$apply_rules(c("simp", "rsimp")))
# print(private$bg_implications %~% bg)
lhs_bg <- bg$get_LHS_matrix()
rhs_bg <- bg$get_RHS_matrix()
L1 <- complete_rhs(LHS = lhs_bg, RHS = rhs_bg)
lhs_bg <- L1$lhs
rhs_bg <- L1$rhs
L2 <- .imp_to_basis_bg(
lhs_bg = lhs_bg,
rhs_bg = rhs_bg,
LHS = L$LHS,
RHS = L$RHS,
attributes = self$attributes)
L3 <- .clean(L2$lhs, L2$rhs)
L$LHS <- L3$lhs
L$RHS <- L3$rhs
}
# Since the previous function gives the list of intents of
# the computed concepts, now we will compute the corresponding
# extents.
if (save_concepts) {
my_intents <- L$concepts
my_extents <- L$extents
}
if (save_concepts) {
self$concepts <- ConceptLattice$new(
extents = my_extents,
intents = my_intents,
objects = self$objects,
attributes = self$attributes,
I = self$I)
}
# Now, add the computed implications
# TODO: check what happens with only 1 implication.
if (ncol(L$LHS) > 0) {
# There are implications (the first one is dummy
# emptyset -> emptyset )
my_LHS <- convert_to_sparse(L$LHS)
my_RHS <- convert_to_sparse(L$RHS)
extracted_implications <- ImplicationSet$new(
attributes = self$attributes,
lhs = my_LHS,
rhs = my_RHS,
I = self$I)
} else {
extracted_implications <- ImplicationSet$new(
attributes = self$attributes,
I = self$I)
}
self$implications <- extracted_implications
return(invisible(self))
},
#' @description
#' Convert the formal context to object of class \code{transactions} from the \code{arules} package
#'
#' @return A \code{transactions} object.
#'
#' @export
to_transactions = function() {
private$check_empty()
if (private$is_many_valued) error_many_valued()
return(methods::as(methods::as(self$I, "nMatrix"), "transactions"))
# return(to_transactions.SpM(self$I))
},
#' @description
#' Save a \code{FormalContext} to RDS or CXT format
#'
#' @param filename (character) Path of the file where to store the \code{FormalContext}.
#'
#' @return Invisibly the current \code{FormalContext}.
#'
#' @details The format is inferred from the extension of the filename.
#'
#' @export
save = function(filename = tempfile(fileext = ".rds")) {
private$check_empty()
pattern <- "(?<!^|[.]|/)[.]([^.]+)$"
extension <- filename %>%
stringr::str_extract_all(pattern) %>%
unlist() %>%
tolower()
if (extension == ".cxt") {
if (!private$is_many_valued) {
to_cxt(I = self$incidence(),
objects = self$objects,
attributes = self$attributes,
filename)
}
return(invisible(self))
}
if (!self$concepts$is_empty()) {
extents <- self$concepts$extents()
intents <- self$concepts$intents()
} else {
extents <- NULL
intents <- NULL
}
if (private$is_many_valued) {
L <- list(I = self$I,
many_valued_I = private$many_valued_I,
extents = NULL,
intents = NULL,
attributes = self$attributes,
objects = self$objects,
expanded_grades_set = NULL,
grades_set = NULL,
implications = self$implications)
} else {
L <- list(I = self$I,
extents = extents,
intents = intents,
attributes = self$attributes,
objects = self$objects,
expanded_grades_set = self$expanded_grades_set,
grades_set = self$grades_set,
implications = self$implications)
}
saveRDS(L, file = filename)
return(invisible(self))
},
#' @description
#' Load a \code{FormalContext} from a file
#'
#' @param filename (character) Path of the file to load the \code{FormalContext} from.
#'
#' @details Currently, only RDS, CSV and CXT files are supported.
#'
#' @return The loaded \code{FormalContext}.
#'
#' @export
load = function(filename) {
pattern <- "(?<!^|[.]|/)[.]([^.]+)$"
extension <- filename %>%
stringr::str_extract_all(pattern) %>%
unlist() %>%
tolower()
if (extension == ".rds") {
L <- readRDS(filename)
if ("many_valued_I" %in% names(L)) {
self$initialize(L$many_valued_I)
return()
}
self$I <- L$I
self$attributes <- L$attributes
self$objects <- L$objects
self$expanded_grades_set <- L$expanded_grades_set
self$grades_set <- L$grades_set
self$implications <- ImplicationSet$new(
attributes = L$attributes,
I = L$I,
lhs = L$implications$get_LHS_matrix(),
rhs = L$implications$get_RHS_matrix())
if (!is.null(L$extents)) {
self$concepts <- ConceptLattice$new(
extents = L$extents,
intents = L$intents,
objects = L$objects,
attributes = L$attributes,
I = L$I)
}
}
if (extension == ".csv") {
I <- read.csv(filename)
if (is.character(I[[1]]) || is.factor(I[[1]])) {
objects <- as.character(I[[1]])
I <- I[, -1]
rownames(I) <- objects
}
I <- as.matrix(I)
self$initialize(I)
}
if (extension == ".cxt") {
txt <- readLines(filename)
n_objects <- txt[3] %>% as.numeric()
n_attributes <- txt[4] %>% as.numeric()
obj_idx <- seq(6, 6 + n_objects - 1)
att_idx <- seq(6 + n_objects,
6 + n_objects + n_attributes - 1)
matrix_idx <- seq(6 + n_objects + n_attributes,
6 + 2 * n_objects + n_attributes - 1)
objects <- txt[obj_idx]
attributes <- txt[att_idx]
matrix <- txt[matrix_idx] %>%
stringr::str_replace_all(
pattern = "X",
replacement = "1") %>%
stringr::str_replace_all(
pattern = stringr::fixed("."),
replacement = "0") %>%
as.list() %>%
stringr::str_split(pattern = "") %>%
purrr::map(as.numeric)
I <- do.call(rbind, matrix)
rownames(I) <- objects
colnames(I) <- attributes
self$initialize(I)
}
return(invisible(self))
},
#' @description
#' Dimensions of the formal context
#'
#' @return A vector with (number of objects, number of attributes).
#'
#' @export
dim = function() {
return(c(length(self$objects), length(self$attributes)))
},
#' @description
#' Prints the formal context
#'
#' @return Prints information regarding the formal context.
#' @export
print = function() {
if (self$is_empty()) {
cat("Empty FormalContext.\n")
return(invisible(self))
}
dims <- self$dim()
if (!private$is_many_valued) {
I <- Matrix::as.matrix(Matrix::t(self$I))
if (private$is_binary) {
I <- .print_binary(I, latex = FALSE)
}
objects <- self$objects
if (nrow(I) > 10) {
I <- I[1:10, ]
objects <- objects[1:10]
}
matp <- .print_matrix(I,
objects = objects,
attributes = self$attributes)
M <- matp$mat
ids <- matp$att_id
last_attribute <- max(ids) - 1
str <- paste0("FormalContext with ", dims[1],
" objects and ",
dims[2], " attributes.") %>%
stringr::str_wrap(width = getOption("width"))
cat(str)
cat("\n")
cat(M)
cat("\n")
if (last_attribute < length(self$attributes)) {
remaining <- self$attributes[-seq(last_attribute)]
if (length(remaining) > 6) {
remaining <- c(remaining[1:6], "...")
}
remaining <- remaining %>%
stringr::str_flatten(", ")
str <- paste0("Other attributes are: ", remaining) %>%
stringr::str_wrap(width = getOption("width"))
cat(str, "\n")
}
} else {
str <- paste0("FormalContext with ", dims[1],
" objects and ",
dims[2], " attributes.") %>%
stringr::str_wrap(width = getOption("width"))
cat(str)
cat("\n")
print_many_valued(private$many_valued_I)
# print(tibble::tibble(private$many_valued_I))
}
},
#' @description
#' Write the context in LaTeX format
#'
#' @param table (logical) If \code{TRUE}, surrounds everything between \code{\\begin{table}} and \code{\\end{table}}.
#' @param label (character) The label for the table environment.
#' @param caption (character) The caption of the table.
#' @param fraction (character) If \code{none}, no fractions are produced. Otherwise, if it is \code{frac}, \code{dfrac} or \code{sfrac}, decimal numbers are represented as fractions with the corresponding LaTeX typesetting.
#'
#' @return
#' A table environment in LaTeX.
#'
#' @export
#' @importFrom glue glue
#'
to_latex = function(table = TRUE,
label = "",
caption = "") {
# TODO: export a many-valued context to LaTeX
if (private$is_many_valued) error_many_valued()
fraction <- fcaR_options("latex_fraction")
I <- Matrix::as.matrix(Matrix::t(self$I))
if (private$is_binary) {
I <- .print_binary(I, latex = TRUE)
} else {
if (fraction != "none") {
I <- .to_fraction(I,
latex = TRUE,
type = fraction)
} else {
decimal_places <- fcaR_options("decimal_places")
I[] <- I %>%
formatC(digits = decimal_places) %>%
stringr::str_replace_all("\\s*", "")
}
}
str <- context_to_latex(
I,
objects = self$objects,
attributes = self$attributes)
if (table) {
my_caption <- glue::glue(
"\\caption{{{caption}}}\\label{{{label}}}"
)
# my_caption <- paste0("\\caption{,
# \\label{",
# label, "}",
# caption, "}")
str <- c("\\begin{table}",
my_caption,
"\\centering",
str,
"\\end{table}")
}
cat(str)
return(invisible(str))
},
#' @description
#' Incidence matrix of the formal context
#'
#' @return The incidence matrix of the formal context
#' @export
#'
#' @examples
#' fc <- FormalContext$new(planets)
#' fc$incidence()
incidence = function() {
if (private$is_many_valued) {
return(private$many_valued_I)
} else {
I <- Matrix::as.matrix(Matrix::t(self$I))
dimnames(I) <- list(self$objects, self$attributes)
return(I)
}
},
#' @description
#' Subcontext of the formal context
#'
#' @param objects (character array) Name of the objects to
#' keep.
#' @param attributes (character array) Names of the attributes
#' to keep.
#'
#' @details
#' A warning will be issued if any of the names is not present
#' in the list of objects or attributes of the formal context.
#'
#' If \code{objects} or \code{attributes} is empty, then it is
#' assumed to represent the whole set of objects or attributes
#' of the original formal context.
#'
#' @return Another \code{FormalContext} that is a subcontext
#' of the original one, with only the objects and attributes
#' selected.
#' @export
#'
#' @examples
#' fc <- FormalContext$new(planets)
#' fc$subcontext(attributes = c("moon", "no_moon"))
subcontext = function(objects,
attributes) {
if (missing(objects)) objects <- self$objects
if (missing(attributes)) attributes <- self$attributes
if (is.numeric(objects)) {
final_objects <- self$objects[objects[objects > 0 & objects < length(self$objects)]]
} else {
final_objects <- intersect(objects, self$objects)
}
if (is.numeric(attributes)) {
final_attributes <- self$attributes[attributes[attributes > 0 & attributes < length(self$attributes)]]
} else {
final_attributes <- intersect(attributes, self$attributes)
}
if (length(objects) > length(final_objects)) {
warning("An object you provided was not found in this context.", call. = FALSE, immediate. = TRUE)
}
if (length(attributes) > length(final_attributes)) {
warning("An attribute you provided was not found in this context.", call. = FALSE, immediate. = TRUE)
}
if (length(objects) == 0) objects <- self$objects
if (length(attributes) == 0) attributes <- self$attributes
I <- self$incidence()[final_objects, final_attributes]
I <- matrix(I, nrow = length(final_objects),
ncol = length(final_attributes))
rownames(I) <- final_objects
colnames(I) <- final_attributes
return(FormalContext$new(I))
},
#' @description
#' Subcontext of the formal context
#'
#' @param objects (character array) Name of the objects to
#' keep.
#' @param attributes (character array) Names of the attributes
#' to keep.
#'
#' @details
#' A warning will be issued if any of the names is not present
#' in the list of objects or attributes of the formal context.
#'
#' If \code{objects} or \code{attributes} is empty, then it is
#' assumed to represent the whole set of objects or attributes
#' of the original formal context.
#'
#' @return Another \code{FormalContext} that is a subcontext
#' of the original one, with only the objects and attributes
#' selected.
#' @export
#'
#' @examples
#' fc <- FormalContext$new(planets)
#' fc[, c("moon", "no_moon")]
`[` = function(objects, attributes) {
self$subcontext(objects, attributes)
},
#' @description
#' Plot the formal context table
#'
#' @param to_latex (logical) If \code{TRUE}, export the plot as a \code{tikzpicture} environment that can be included in a \code{LaTeX} file.
#' @param ... Other parameters to be passed to the \code{tikzDevice} that renders the lattice in \code{LaTeX}, or for the figure caption. See \code{Details}.
#'
#' @details
#' Particular parameters that control the size of the \code{tikz} output are: \code{width}, \code{height} (both in inches), and \code{pointsize} (in points), that should be set to the font size used in the \code{documentclass} header in the \code{LaTeX} file where the code is to be inserted.
#'
#' If a \code{caption} is provided, the whole \code{tikz} picture will be wrapped by a \code{figure} environment and the caption set.
#'
#' @return If \code{to_latex} is \code{FALSE}, it returns nothing, just plots the graph of the formal context. Otherwise, this function returns the \code{LaTeX} code to reproduce the formal context plot.
#'
#' @export
plot = function(to_latex = FALSE,
...) {
if (private$is_many_valued) error_many_valued()
private$check_empty()
if (!private$can_plot) {
warning("The R system has not the needed capabilities to plot.",
call. = FALSE)
return(invisible(FALSE))
}
plot_context(self$I, to_latex, ...)
},
#' @description
#' Sets the logic to use
#'
#'
#' @param name The name of the logic to use. To see the available names, run \code{available_logics()}.
#'
#' @export
use_logic = function(name = available_logics()) {
name <- match.arg(name)
if (name %in% available_logics()) {
private$logic <- name
}
},
#' @description
#' Gets the logic used
#'
#' @return A string with the name of the logic.
#'
#' @export
get_logic = function() {
private$logic
},
#' @description
#' Sets the name of the Galois connection to use
#'
#' @param connection The name of the Galois connection. Available connections are "standard" (antitone), "benevolent1" and "benevolent2" (isotone)
#'
#' @export
use_connection = function(connection) {
if (connection %in% c("standard", "benevolent1", "benevolent2")) {
private$connection <- connection
}
},
#' @description
#' Gets the name of the Galois connection
#'
#' @return A string with the name of the Galois connection
#'
#' @export
get_connection = function() {
private$connection
}
),
private = list(
logic = "Zadeh",
connection = "standard",
is_binary = FALSE,
is_many_valued = FALSE,
can_plot = TRUE,
many_valued_I = NULL,
scales = list(),
bg_implications = NULL,
bg_implications_basis = NULL,
check_empty = function() {
if (self$is_empty()) {
stop("The formal context is empty. The only allowed method is 'load' to import from a previously saved RDS file.", call. = FALSE)
}
return(invisible(NULL))
}
)
)
Try the fcaR package in your browser
Any scripts or data that you put into this service are public.
fcaR documentation built on April 28, 2023, 1:11 a.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 formal context
#'
#' @description
#' This class implements the data structure and methods for formal contexts.
#'
#' @examples
#' # Build and print the formal context
#' fc_planets <- FormalContext$new(planets)
#' print(fc_planets)
#'
#' # Define a set of attributes
#' S <- Set$new(attributes = fc_planets$attributes)
#' S$assign(moon = 1, large = 1)
#'
#' # Compute the closure of S
#' Sc <- fc_planets$closure(S)
#' # Is Sc a closed set?
#' fc_planets$is_closed(Sc)
#'
#' # Clarify and reduce the formal context
#' fc2 <- fc_planets$reduce(TRUE)
#'
#' # Find implications
#' fc_planets$find_implications()
#'
#' # Read a formal context from CSV
#' filename <- system.file("contexts", "airlines.csv", package = "fcaR")
#' fc <- FormalContext$new(filename)
#'
#' # Read a formal context from a CXT file
#' filename <- system.file("contexts", "lives_in_water.cxt", package = "fcaR")
#' fc <- FormalContext$new(filename)
#'
#' @references
#'
#' Guigues J, Duquenne V (1986). “Familles minimales d'implications informatives résultant d'un tableau de données binaires.” _Mathématiques et Sciences humaines_, *95*, 5-18.
#'
#' Ganter B, Wille R (1999). _Formal concept analysis : mathematical foundations_. Springer. ISBN 3540627715.
#'
#' Belohlavek R (2002). “Algorithms for fuzzy concept lattices.” In _Proc. Fourth Int. Conf. on Recent Advances in Soft Computing_. Nottingham, United Kingdom, 200-205.
#'
#' Hahsler M, Grun B, Hornik K (2005). “arules - a computational environment for mining association rules and frequent item sets.” _J Stat Softw_, *14*, 1-25.
#'
#' @export
FormalContext <- R6::R6Class(
classname = "FormalContext",
public = list(
#' @field I The table of the formal context as a matrix.
I = NULL,
#' @field attributes The attributes of the formal context.
attributes = NULL,
#' @field objects The objects of the formal context.
objects = NULL,
#' @field grades_set The set of degrees (in \[0, 1\]) the whole set of attributes can take.
grades_set = NULL,
#' @field expanded_grades_set The set of degrees (in \[0, 1\]) each attribute can take.
expanded_grades_set = NULL,
#' @field concepts The concept lattice associated to the formal context as a \code{\link{ConceptLattice}}.
concepts = NULL,
#' @field implications A set of implications on the formal context as an \code{\link{ImplicationSet}}.
implications = NULL,
#' @description
#' Creator for the Formal Context class
#'
#' @param I (numeric matrix) The table of the formal context.
#' @param filename (character) Path of a file to import.
#' @param remove_const (logical) If \code{TRUE}, remove constant columns. The default is \code{FALSE}.
#'
#' @details
#' Columns of \code{I} should be named, since they are the names of the attributes of the formal context.
#'
#' If no \code{I} is used, the resulting \code{FormalContext} will be empty and not usable unless for loading a previously saved one. In this case, one can provide a \code{filename} to import. Only RDS, CSV and CXT files are currently supported.
#'
#' @return An object of the \code{FormalContext} class.
#' @export
#'
initialize = function(I, filename,
remove_const = FALSE) {
if (missing(I)) {
if (!missing(filename) && file.exists(filename)) {
self$load(filename)
}
return(invisible(self))
}
if ((length(I) == 1) && is.character(I) && file.exists(I)) {
self$load(I)
return(invisible(self))
}
version
if (!capabilities()["long.double"] & getRversion() < "4.1.0") {
private$can_plot <- FALSE
}
# Transform the formal context to sparse
if (inherits(I, "transactions")) {
# If it comes from the arules package
attributes <- I@itemInfo$labels
I <- convert_to_sparse(I@data)
objects <- paste0(seq(ncol(I)))
dimnames(I) <- list(attributes, objects)
} else {
# Or if it comes from a numeric table
if (length(colnames(I)) > 0) {
attributes <- colnames(I)
} else {
attributes <- paste0("A", seq(ncol(I)))
}
if (length(rownames(I)) > 0) {
objects <- rownames(I)
} else {
objects <- paste0("O", seq(nrow(I)))
}
private$is_many_valued <- check_many_valued(I)
if (!private$is_many_valued) {
I <- as.matrix(I)
# Remove the constant columns
if (remove_const) {
constant_cols <- which(apply(I, 2, max) == apply(I, 2, min))
if (length(constant_cols) > 0) {
str <- paste0("Removed constant columns: ", stringr::str_flatten(attributes[constant_cols], collapse = ", "))
message(stringr::str_wrap(str,
exdent = 2,
width = 75))
I <- I[, -constant_cols]
attributes <- attributes[-constant_cols]
}
}
# # TODO: save tI???
# tI <- new_spm(I)
# I <- new_spm(t(I))
I <- convert_to_sparse(
Matrix::Matrix(t(I), sparse = TRUE))
}
}
self$objects <- objects
self$attributes <- attributes
if (!private$is_many_valued) {
# Assign everything to its corresponding field
expanded_grades_set <- compute_grades(Matrix::t(I))
grades_set <- sort(unique(unlist(expanded_grades_set)))
self$I <- I
self$grades_set <- unique(c(0, grades_set, 1))
self$expanded_grades_set <- expanded_grades_set
colnames(self$I) <- self$objects
rownames(self$I) <- self$attributes
# Is the FormalContext binary?
private$is_binary <- length(self$grades_set) == 2
} else {
# browser()
private$many_valued_I <- I
# colnames(private$many_valued_I) <- self$objects
# rownames(private$many_valued_I) <- self$attributes
}
# Create a new empty implication set inside
self$implications <- ImplicationSet$new(attributes = attributes,
I = self$I)
# Create a new empty ConceptLattice inside
self$concepts <- ConceptLattice$new(extents = NULL,
intents = NULL,
objects = self$objects,
attributes = self$attributes,
I = self$I)
},
#' @description
#' Check if the \code{FormalContext} is empty
#'
#' @return \code{TRUE} if the \code{FormalContext} is empty, that is, has not been provided with a matrix, and \code{FALSE} otherwise.
#'
#' @export
is_empty = function() {
return(is.null(self$I) && is.null(private$many_valued_I))
},
#' @description
#' Scale the context
#'
#' @param attributes The attributes to scale
#' @param type Type of scaling.
#' @param ...
#'
#' @details
#' The types of scaling are implemented in a registry,
#' so that \code{scalingRegistry$get_entries()} returns
#' all types.
#'
#' @return The scaled formal context
#' @export
#' @examples
#' filename <- system.file("contexts", "aromatic.csv", package = "fcaR")
#' fc <- FormalContext$new(filename)
#' fc$scale("nitro", "ordinal", comparison = `>=`, values = 1:3)
#' fc$scale("OS", "nominal", c("O", "S"))
#' fc$scale(attributes = "ring", type = "nominal")
scale = function(attributes, type, ...) {
# TODO: Check that the attributes are in self$attributes
I <- self$incidence()
for (att in attributes) {
scaled <-
scale_context(I, column = att,
type = type,
...)
I <- scaled$derived
private$scales <- c(private$scales,
scaled$scale)
names(private$scales)[length(private$scales)] <- att
# Add implications to the bg_implications
private$bg_implications <- combine_implications(
private$bg_implications,
scaled$bg_implications)
# if (scaled$bg_implications$cardinality() > 0) {
#
# private$bg_implications$to_basis()
#
# }
}
self$initialize(I)
},
#' @description
#' Scales applied to the formal context
#'
#' @param attributes (character) Name of the attributes for which scales
#' (if applied) are returned.
#'
#' @return The scales that have been applied to the specified attributes
#' of the formal context. If no \code{attributes} are passed,
#' then all applied scales are returned.
#'
#' @export
#' @examples
#' filename <- system.file("contexts", "aromatic.csv", package = "fcaR")
#' fc <- FormalContext$new(filename)
#' fc$scale("nitro", "ordinal", comparison = `>=`, values = 1:3)
#' fc$scale("OS", "nominal", c("O", "S"))
#' fc$scale(attributes = "ring", type = "nominal")
#' fc$get_scales()
get_scales = function(attributes = names(private$scales)) {
# TODO: Get the scales applied to only one or some
# of the self$attributes.
attributes <- attributes[attributes %in% names(private$scales)]
res <- private$scales[attributes]
if (length(res) > 0) {
if (length(res) > 1) {
return(res)
} else {
return(res[[1]])
}
} else {
message("No scaling has been performed on these attributes.")
}
},
#' @description
#' Background knowledge of a scaled formal context
#'
#' @return
#' An \code{ImplicationSet} with the implications
#' extracted from the application of scales.
#'
#' @export
#'
#' @examples
#' filename <- system.file("contexts", "aromatic.csv", package = "fcaR")
#' fc <- FormalContext$new(filename)
#' fc$scale("nitro", "ordinal", comparison = `>=`, values = 1:3)
#' fc$scale("OS", "nominal", c("O", "S"))
#' fc$scale(attributes = "ring", type = "nominal")
#' fc$background_knowledge()
background_knowledge = function() {
if (!is.null(private$bg_implications)) {
if (is.null(private$bg_implications_basis)) {
private$bg_implications_basis <- private$bg_implications$clone()
# private$bg_implications_basis$to_basis()
suppressMessages(private$bg_implications_basis$apply_rules(c("comp", "simp", "rsimp")))
}
private$bg_implications_basis$clone()
# private$bg_implications$clone()
} else {
ImplicationSet$new(attributes = self$attributes)
}
},
#' @description
#' Get the dual formal context
#'
#' @return A \code{FormalContext} where objects and attributes have interchanged their roles.
#'
#' @export
dual = function() {
if (private$is_many_valued) {
return(FormalContext$new(t(private$many_valued_I)))
} else {
I <- Matrix::as.matrix(self$I)
colnames(I) <- self$objects
rownames(I) <- self$attributes
return(FormalContext$new(I))
}
},
#' @description
#' Get the intent of a fuzzy set of objects
#'
#' @param S (\code{Set}) The set of objects to compute the intent for.
#'
#' @return A \code{Set} with the intent.
#'
#' @export
intent = function(S) {
if (private$is_many_valued) error_many_valued()
if (inherits(S, "Set")) {
if (all(S$get_attributes() == self$objects)) {
S <- S$get_vector()
} else {
S <- match_attributes(S, self$objects)
S <- S$get_vector()
warn <- c("The attributes in the input set are not the same",
" that in the formal context. Attempting to match",
" attribute names gives ",
.set_to_string(S, self$objects)) %>%
stringr::str_flatten()
warning(warn, call. = FALSE, immediate. = TRUE)
# stop("It is not a set of the required type (set of objects).", call. = FALSE)
}
}
if (length(S) == length(self$objects)) {
R <- compute_intent(
S,
Matrix::as.matrix(Matrix::t(self$I)),
connection = private$connection,
name = private$logic)
if (length(R@i) > 0) {
# Non-empty set:
R <- Matrix::sparseMatrix(i = R@i + 1,
j = rep(1, length(R@i)),
x = R@x,
dims = c(length(self$attributes), 1))
R <- Set$new(attributes = self$attributes,
M = R)
} else {
# Empty intent
R <- Set$new(attributes = self$attributes)
}
return(R)
} else {
stop("It is not a set of the required type (set of objects).", call. = FALSE)
}
},
#' @description
#' Get the intent of a fuzzy set of objects
#'
#' @param S (\code{Set}) The set of objects to compute the intent for.
#'
#' @return A \code{Set} with the intent.
#'
#' @export
uparrow = function(S) {
self$intent(S)
},
#' @description
#' Get the extent of a fuzzy set of attributes
#'
#' @param S (\code{Set}) The set of attributes to compute the extent for.
#'
#' @return A \code{Set} with the intent.
#'
#' @export
extent = function(S) {
# TODO: Apply scales to Sets.
if (private$is_many_valued) error_many_valued()
if (inherits(S, "Set")) {
if (all(S$get_attributes() == self$attributes)) {
S <- S$get_vector()
} else {
S <- match_attributes(S, self$attributes)
S <- S$get_vector()
warn <- c("The attributes in the input set are not the same",
" that in the formal context. Attempting to match",
" attribute names gives ",
.set_to_string(S, self$attributes)) %>%
stringr::str_flatten()
warning(warn, call. = FALSE, immediate. = TRUE)
# stop("It is not a set of the required type (set of attributes).", call. = FALSE)
}
}
if (length(S) == length(self$attributes)) {
R <- compute_extent(
S,
Matrix::as.matrix(Matrix::t(self$I)),
connection = private$connection,
name = private$logic)
if (length(R@i) > 0) {
# Non-empty set:
R <- Matrix::sparseMatrix(i = R@i + 1,
j = rep(1, length(R@i)),
x = R@x,
dims = c(length(self$objects), 1))
R <- Set$new(attributes = self$objects,
M = R)
} else {
# Empty extent
R <- Set$new(attributes = self$objects)
}
return(R)
} else {
stop("It is not a set of the required type (set of objects).", call. = FALSE)
}
},
#' @description
#' Get the extent of a fuzzy set of attributes
#'
#' @param S (\code{Set}) The set of attributes to compute the extent for.
#'
#' @return A \code{Set} with the intent.
#'
#' @export
downarrow = function(S) {
self$extent(S)
},
#' @description
#' Get the closure of a fuzzy set of attributes
#'
#' @param S (\code{Set}) The set of attributes to compute the closure for.
#'
#' @return A \code{Set} with the closure.
#'
#' @export
closure = function(S) {
if (private$is_many_valued) error_many_valued()
if (inherits(S, "Set")) {
if (all(S$get_attributes() == self$attributes)) {
S <- S$get_vector()
} else {
S <- match_attributes(S, self$attributes)
S <- S$get_vector()
warn <- c("The attributes in the input set are not the same",
" that in the formal context. Attempting to match",
" attribute names gives ",
.set_to_string(S, self$attributes)) %>%
stringr::str_flatten()
warning(warn, call. = FALSE, immediate. = TRUE)
# stop("It is not a set of the required type (set of attributes).", call. = FALSE)
}
}
if (length(S) == length(self$attributes)) {
R <- compute_closure(
S,
Matrix::as.matrix(Matrix::t(self$I)),
connection = private$connection,
name = private$logic)
if (length(R@i) > 0) {
# Non-empty set:
R <- Matrix::sparseMatrix(i = R@i + 1,
j = rep(1, length(R@i)),
x = R@x,
dims = c(length(self$attributes), 1))
R <- Set$new(attributes = self$attributes,
M = R)
} else {
# Empty closure
R <- Set$new(attributes = self$attributes)
}
return(R)
} else {
stop("It is not a set of the required type (set of objects).", call. = FALSE)
}
},
#' @description
#' Object Concept
#'
#' @param object (character) Name of the object to compute its associated concept
#'
#' @return
#' The object concept associated to the object given.
#'
#' @export
obj_concept = function(object) {
if (private$is_many_valued) error_many_valued()
S <- Set$new(attributes = self$objects)
S$assign(attributes = object, values = 1)
B <- self$intent(S)
A <- self$extent(B)
C <- Concept$new(extent = A, intent = B)
return(C)
},
#' @description
#' Attribute Concept
#'
#' @param attribute (character) Name of the attribute to compute its associated concept
#'
#' @return
#' The attribute concept associated to the attribute given.
#'
#' @export
att_concept = function(attribute) {
if (private$is_many_valued) error_many_valued()
S <- Set$new(attributes = self$attributes)
S$assign(attributes = attribute, values = 1)
A <- self$extent(S)
B <- self$intent(A)
C <- Concept$new(extent = A, intent = B)
return(C)
},
#' @description
#' Is a Concept?
#'
#' @param C A \code{Concept} object
#'
#' @return
#' \code{TRUE} if \code{C} is a concept.
#'
#' @export
is_concept = function(C) {
O <- C$get_extent()
A <- C$get_intent()
# O should be the extent of A, and A should be intent of O
return((self$extent(A) %==% O) && (self$intent(O) %==% A))
},
#' @description
#' Testing closure of attribute sets
#'
#' @param S A \code{Set} of attributes
#'
#' @return
#' \code{TRUE} if the set \code{S} is closed in this formal context.
#' @export
is_closed = function(S) {
Sc <- self$closure(S)
return(S %==% Sc)
},
#' @description
#' Clarify a formal context
#'
#' @param copy (logical) If \code{TRUE}, a new \code{FormalContext} object is created with the clarified context, otherwise the current one is overwritten.
#'
#' @return The clarified \code{FormalContext}.
#'
#' @export
clarify = function(copy = FALSE) {
if (private$is_many_valued) error_many_valued()
# Redundant attributes
my_I <- .clarify_matrix(Matrix::t(self$I),
rows = self$objects,
cols = self$attributes)
# And redundant objects
my_I <- .clarify_matrix(Matrix::t(my_I),
rows = colnames(my_I),
cols = self$objects)
my_I <- Matrix::as.matrix(Matrix::t(my_I))
if (copy) {
fc2 <- FormalContext$new(my_I)
return(fc2)
} else {
self$initialize(my_I)
return(invisible(self))
}
},
#' @description
#' Reduce a formal context
#'
#' @param copy (logical) If \code{TRUE}, a new \code{FormalContext} object is created with the clarified and reduced context, otherwise the current one is overwritten.
#'
#' @return The clarified and reduced \code{FormalContext}.
#'
#' @export
reduce = function(copy = FALSE) {
if (!private$is_binary) {
stop("This FormalContext is not binary. Reduction is not implemented for fuzzy contexts.", call. = FALSE)
}
# Make a copy with the clarified context
fc2 <- self$clarify(TRUE)
my_I <- Matrix::as.matrix(Matrix::t(fc2$I))
att <- fc2$attributes
Z <- Set$new(attributes = att)
for (y in att) {
R <- Set$new(attributes = fc2$objects)
R$assign(attributes = fc2$objects,
values = rep(1, length(fc2$objects)))
R <- R$get_vector()
yv <- Set$new(attributes = att)
yv$assign(attributes = y, values = 1)
y_down <- fc2$extent(yv)
for (yp in setdiff(att, y)) {
ypv <- Set$new(attributes = att)
ypv$assign(attributes = yp, values = 1)
yp_down <- fc2$extent(ypv)
S <- .subset(y_down$get_vector(),
yp_down$get_vector())
if (S[1]) {
R[Matrix::which(yp_down$get_vector() < R)] <- yp_down$get_vector()[Matrix::which(yp_down$get_vector() < R)]
}
}
if (!.equal_sets(R, y_down$get_vector())[1]) {
Z$assign(attributes = y, values = 1)
}
}
new_att <- Z$get_attributes()[Matrix::which(Z$get_vector() > 0)]
idx <- match(new_att, att)
# if (length(idx) == 1) {
#
# my_I <- .extract_column(my_I, idx)
#
# } else {
#
# my_I <- my_I[, idx]
#
# }
my_I <- matrix(my_I[, idx], ncol = length(idx))
colnames(my_I) <- new_att
rownames(my_I) <- fc2$objects
if (copy) {
fc3 <- FormalContext$new(my_I)
return(fc3)
} else {
self$initialize(my_I)
return(invisible(self))
}
},
#' @description
#' Build the Standard Context
#'
#' @details
#' All concepts must be previously computed.
#'
#' @return
#' The standard context using the join- and meet- irreducible elements.
#' @export
standardize = function() {
if (private$is_many_valued) error_many_valued()
if (self$concepts$is_empty()) {
stop("Concepts must be computed beforehand.\n", call. = FALSE)
}
join_irr <- self$concepts$join_irreducibles()$to_list()
meet_irr <- self$concepts$meet_irreducibles()$to_list()
nj <- length(join_irr)
nm <- length(meet_irr)
I <- matrix(0, nrow = nj, ncol = nm)
for (i in seq(nj)) {
for (j in seq(nm)) {
I[i, j] <- ifelse(join_irr[[i]] %<=% meet_irr[[j]], 1, 0)
}
}
colnames(I) <- paste0("M", seq(nm))
rownames(I) <- paste0("J", seq(nj))
return(FormalContext$new(I))
},
#' @description
#' Use Ganter Algorithm to compute concepts
#'
#' @param verbose (logical) TRUE will provide a verbose output.
#'
#' @return A list with all the concepts in the formal context.
#'
#' @export
find_concepts = function(verbose = FALSE) {
private$check_empty()
if (private$is_many_valued) error_many_valued()
my_I <- Matrix::as.matrix(Matrix::t(self$I))
# my_I <- unique(my_I)
grades_set <- rep(list(self$grades_set), length(self$attributes))
# grades_set <- self$expanded_grades_set
attrs <- self$attributes
L <- next_closure_concepts(
I = my_I,
grades_set = grades_set,
attrs = attrs,
connection = private$connection,
name = private$logic,
verbose = verbose)
# Since the previous function gives the list of intents of
# the computed concepts, now we will compute the corresponding
# extents.
if (length(self$attributes) == 1) {
my_intents <- Matrix::Matrix(t(as.vector(L$intents)), sparse = TRUE)
my_extents <- Matrix::Matrix(t(as.vector(L$extents)), sparse = TRUE)
} else {
my_intents <- L$intents
my_extents <- L$extents
}
self$concepts <- ConceptLattice$new(
extents = my_extents,
intents = my_intents,
objects = self$objects,
attributes = self$attributes,
I = self$I)
if (verbose) {
cat("Number of closures", L$closure_count, "\n")
}
# return(invisible(self$concepts))
return(invisible(self))
},
#' @description
#' Use modified Ganter algorithm to compute both concepts and implications
#'
#' @param save_concepts (logical) \code{TRUE} will also compute and save the concept lattice. \code{FALSE} is usually faster, since it only computes implications.
#' @param verbose (logical) \code{TRUE} will provide a verbose output.
#'
#' @return Nothing, just updates the internal fields \code{concepts} and \code{implications}.
#'
#'
#' @export
find_implications = function(save_concepts = TRUE,
verbose = FALSE) {
private$check_empty()
if (private$is_many_valued) error_many_valued()
my_I <- Matrix::as.matrix(Matrix::t(self$I))
my_I <- unique(my_I)
grades_set <- rep(list(self$grades_set), length(self$attributes))
# grades_set <- self$expanded_grades_set
attrs <- self$attributes
# if (is.null(private$bg_implications)) {
L <- next_closure_implications(
I = my_I,
grades_set = grades_set,
attrs = attrs,
save_concepts = save_concepts,
connection = private$connection,
name = private$logic,
verbose = verbose)
# }
if (!is.null(private$bg_implications) && private$bg_implications$cardinality() > 0) {
private$bg_implications <- reorder_attributes(
private$bg_implications,
self$attributes
)
# n_bg <- private$bg_implications$cardinality()
#
# L <- next_closure_implications_bg2(I = my_I,
# grades_set = grades_set,
# attrs = attrs,
# lhs_bg = private$bg_implications$get_LHS_matrix(),
# rhs_bg = private$bg_implications$get_RHS_matrix(),
# n_bg = n_bg,
# save_concepts = save_concepts,
# verbose = verbose)
bg <- private$bg_implications$clone()
suppressMessages(bg$apply_rules(c("simp", "rsimp")))
# print(private$bg_implications %~% bg)
lhs_bg <- bg$get_LHS_matrix()
rhs_bg <- bg$get_RHS_matrix()
L1 <- complete_rhs(LHS = lhs_bg, RHS = rhs_bg)
lhs_bg <- L1$lhs
rhs_bg <- L1$rhs
L2 <- .imp_to_basis_bg(
lhs_bg = lhs_bg,
rhs_bg = rhs_bg,
LHS = L$LHS,
RHS = L$RHS,
attributes = self$attributes)
L3 <- .clean(L2$lhs, L2$rhs)
L$LHS <- L3$lhs
L$RHS <- L3$rhs
}
# Since the previous function gives the list of intents of
# the computed concepts, now we will compute the corresponding
# extents.
if (save_concepts) {
my_intents <- L$concepts
my_extents <- L$extents
}
if (save_concepts) {
self$concepts <- ConceptLattice$new(
extents = my_extents,
intents = my_intents,
objects = self$objects,
attributes = self$attributes,
I = self$I)
}
# Now, add the computed implications
# TODO: check what happens with only 1 implication.
if (ncol(L$LHS) > 0) {
# There are implications (the first one is dummy
# emptyset -> emptyset )
my_LHS <- convert_to_sparse(L$LHS)
my_RHS <- convert_to_sparse(L$RHS)
extracted_implications <- ImplicationSet$new(
attributes = self$attributes,
lhs = my_LHS,
rhs = my_RHS,
I = self$I)
} else {
extracted_implications <- ImplicationSet$new(
attributes = self$attributes,
I = self$I)
}
self$implications <- extracted_implications
return(invisible(self))
},
#' @description
#' Convert the formal context to object of class \code{transactions} from the \code{arules} package
#'
#' @return A \code{transactions} object.
#'
#' @export
to_transactions = function() {
private$check_empty()
if (private$is_many_valued) error_many_valued()
return(methods::as(methods::as(self$I, "nMatrix"), "transactions"))
# return(to_transactions.SpM(self$I))
},
#' @description
#' Save a \code{FormalContext} to RDS or CXT format
#'
#' @param filename (character) Path of the file where to store the \code{FormalContext}.
#'
#' @return Invisibly the current \code{FormalContext}.
#'
#' @details The format is inferred from the extension of the filename.
#'
#' @export
save = function(filename = tempfile(fileext = ".rds")) {
private$check_empty()
pattern <- "(?<!^|[.]|/)[.]([^.]+)$"
extension <- filename %>%
stringr::str_extract_all(pattern) %>%
unlist() %>%
tolower()
if (extension == ".cxt") {
if (!private$is_many_valued) {
to_cxt(I = self$incidence(),
objects = self$objects,
attributes = self$attributes,
filename)
}
return(invisible(self))
}
if (!self$concepts$is_empty()) {
extents <- self$concepts$extents()
intents <- self$concepts$intents()
} else {
extents <- NULL
intents <- NULL
}
if (private$is_many_valued) {
L <- list(I = self$I,
many_valued_I = private$many_valued_I,
extents = NULL,
intents = NULL,
attributes = self$attributes,
objects = self$objects,
expanded_grades_set = NULL,
grades_set = NULL,
implications = self$implications)
} else {
L <- list(I = self$I,
extents = extents,
intents = intents,
attributes = self$attributes,
objects = self$objects,
expanded_grades_set = self$expanded_grades_set,
grades_set = self$grades_set,
implications = self$implications)
}
saveRDS(L, file = filename)
return(invisible(self))
},
#' @description
#' Load a \code{FormalContext} from a file
#'
#' @param filename (character) Path of the file to load the \code{FormalContext} from.
#'
#' @details Currently, only RDS, CSV and CXT files are supported.
#'
#' @return The loaded \code{FormalContext}.
#'
#' @export
load = function(filename) {
pattern <- "(?<!^|[.]|/)[.]([^.]+)$"
extension <- filename %>%
stringr::str_extract_all(pattern) %>%
unlist() %>%
tolower()
if (extension == ".rds") {
L <- readRDS(filename)
if ("many_valued_I" %in% names(L)) {
self$initialize(L$many_valued_I)
return()
}
self$I <- L$I
self$attributes <- L$attributes
self$objects <- L$objects
self$expanded_grades_set <- L$expanded_grades_set
self$grades_set <- L$grades_set
self$implications <- ImplicationSet$new(
attributes = L$attributes,
I = L$I,
lhs = L$implications$get_LHS_matrix(),
rhs = L$implications$get_RHS_matrix())
if (!is.null(L$extents)) {
self$concepts <- ConceptLattice$new(
extents = L$extents,
intents = L$intents,
objects = L$objects,
attributes = L$attributes,
I = L$I)
}
}
if (extension == ".csv") {
I <- read.csv(filename)
if (is.character(I[[1]]) || is.factor(I[[1]])) {
objects <- as.character(I[[1]])
I <- I[, -1]
rownames(I) <- objects
}
I <- as.matrix(I)
self$initialize(I)
}
if (extension == ".cxt") {
txt <- readLines(filename)
n_objects <- txt[3] %>% as.numeric()
n_attributes <- txt[4] %>% as.numeric()
obj_idx <- seq(6, 6 + n_objects - 1)
att_idx <- seq(6 + n_objects,
6 + n_objects + n_attributes - 1)
matrix_idx <- seq(6 + n_objects + n_attributes,
6 + 2 * n_objects + n_attributes - 1)
objects <- txt[obj_idx]
attributes <- txt[att_idx]
matrix <- txt[matrix_idx] %>%
stringr::str_replace_all(
pattern = "X",
replacement = "1") %>%
stringr::str_replace_all(
pattern = stringr::fixed("."),
replacement = "0") %>%
as.list() %>%
stringr::str_split(pattern = "") %>%
purrr::map(as.numeric)
I <- do.call(rbind, matrix)
rownames(I) <- objects
colnames(I) <- attributes
self$initialize(I)
}
return(invisible(self))
},
#' @description
#' Dimensions of the formal context
#'
#' @return A vector with (number of objects, number of attributes).
#'
#' @export
dim = function() {
return(c(length(self$objects), length(self$attributes)))
},
#' @description
#' Prints the formal context
#'
#' @return Prints information regarding the formal context.
#' @export
print = function() {
if (self$is_empty()) {
cat("Empty FormalContext.\n")
return(invisible(self))
}
dims <- self$dim()
if (!private$is_many_valued) {
I <- Matrix::as.matrix(Matrix::t(self$I))
if (private$is_binary) {
I <- .print_binary(I, latex = FALSE)
}
objects <- self$objects
if (nrow(I) > 10) {
I <- I[1:10, ]
objects <- objects[1:10]
}
matp <- .print_matrix(I,
objects = objects,
attributes = self$attributes)
M <- matp$mat
ids <- matp$att_id
last_attribute <- max(ids) - 1
str <- paste0("FormalContext with ", dims[1],
" objects and ",
dims[2], " attributes.") %>%
stringr::str_wrap(width = getOption("width"))
cat(str)
cat("\n")
cat(M)
cat("\n")
if (last_attribute < length(self$attributes)) {
remaining <- self$attributes[-seq(last_attribute)]
if (length(remaining) > 6) {
remaining <- c(remaining[1:6], "...")
}
remaining <- remaining %>%
stringr::str_flatten(", ")
str <- paste0("Other attributes are: ", remaining) %>%
stringr::str_wrap(width = getOption("width"))
cat(str, "\n")
}
} else {
str <- paste0("FormalContext with ", dims[1],
" objects and ",
dims[2], " attributes.") %>%
stringr::str_wrap(width = getOption("width"))
cat(str)
cat("\n")
print_many_valued(private$many_valued_I)
# print(tibble::tibble(private$many_valued_I))
}
},
#' @description
#' Write the context in LaTeX format
#'
#' @param table (logical) If \code{TRUE}, surrounds everything between \code{\\begin{table}} and \code{\\end{table}}.
#' @param label (character) The label for the table environment.
#' @param caption (character) The caption of the table.
#' @param fraction (character) If \code{none}, no fractions are produced. Otherwise, if it is \code{frac}, \code{dfrac} or \code{sfrac}, decimal numbers are represented as fractions with the corresponding LaTeX typesetting.
#'
#' @return
#' A table environment in LaTeX.
#'
#' @export
#' @importFrom glue glue
#'
to_latex = function(table = TRUE,
label = "",
caption = "") {
# TODO: export a many-valued context to LaTeX
if (private$is_many_valued) error_many_valued()
fraction <- fcaR_options("latex_fraction")
I <- Matrix::as.matrix(Matrix::t(self$I))
if (private$is_binary) {
I <- .print_binary(I, latex = TRUE)
} else {
if (fraction != "none") {
I <- .to_fraction(I,
latex = TRUE,
type = fraction)
} else {
decimal_places <- fcaR_options("decimal_places")
I[] <- I %>%
formatC(digits = decimal_places) %>%
stringr::str_replace_all("\\s*", "")
}
}
str <- context_to_latex(
I,
objects = self$objects,
attributes = self$attributes)
if (table) {
my_caption <- glue::glue(
"\\caption{{{caption}}}\\label{{{label}}}"
)
# my_caption <- paste0("\\caption{,
# \\label{",
# label, "}",
# caption, "}")
str <- c("\\begin{table}",
my_caption,
"\\centering",
str,
"\\end{table}")
}
cat(str)
return(invisible(str))
},
#' @description
#' Incidence matrix of the formal context
#'
#' @return The incidence matrix of the formal context
#' @export
#'
#' @examples
#' fc <- FormalContext$new(planets)
#' fc$incidence()
incidence = function() {
if (private$is_many_valued) {
return(private$many_valued_I)
} else {
I <- Matrix::as.matrix(Matrix::t(self$I))
dimnames(I) <- list(self$objects, self$attributes)
return(I)
}
},
#' @description
#' Subcontext of the formal context
#'
#' @param objects (character array) Name of the objects to
#' keep.
#' @param attributes (character array) Names of the attributes
#' to keep.
#'
#' @details
#' A warning will be issued if any of the names is not present
#' in the list of objects or attributes of the formal context.
#'
#' If \code{objects} or \code{attributes} is empty, then it is
#' assumed to represent the whole set of objects or attributes
#' of the original formal context.
#'
#' @return Another \code{FormalContext} that is a subcontext
#' of the original one, with only the objects and attributes
#' selected.
#' @export
#'
#' @examples
#' fc <- FormalContext$new(planets)
#' fc$subcontext(attributes = c("moon", "no_moon"))
subcontext = function(objects,
attributes) {
if (missing(objects)) objects <- self$objects
if (missing(attributes)) attributes <- self$attributes
if (is.numeric(objects)) {
final_objects <- self$objects[objects[objects > 0 & objects < length(self$objects)]]
} else {
final_objects <- intersect(objects, self$objects)
}
if (is.numeric(attributes)) {
final_attributes <- self$attributes[attributes[attributes > 0 & attributes < length(self$attributes)]]
} else {
final_attributes <- intersect(attributes, self$attributes)
}
if (length(objects) > length(final_objects)) {
warning("An object you provided was not found in this context.", call. = FALSE, immediate. = TRUE)
}
if (length(attributes) > length(final_attributes)) {
warning("An attribute you provided was not found in this context.", call. = FALSE, immediate. = TRUE)
}
if (length(objects) == 0) objects <- self$objects
if (length(attributes) == 0) attributes <- self$attributes
I <- self$incidence()[final_objects, final_attributes]
I <- matrix(I, nrow = length(final_objects),
ncol = length(final_attributes))
rownames(I) <- final_objects
colnames(I) <- final_attributes
return(FormalContext$new(I))
},
#' @description
#' Subcontext of the formal context
#'
#' @param objects (character array) Name of the objects to
#' keep.
#' @param attributes (character array) Names of the attributes
#' to keep.
#'
#' @details
#' A warning will be issued if any of the names is not present
#' in the list of objects or attributes of the formal context.
#'
#' If \code{objects} or \code{attributes} is empty, then it is
#' assumed to represent the whole set of objects or attributes
#' of the original formal context.
#'
#' @return Another \code{FormalContext} that is a subcontext
#' of the original one, with only the objects and attributes
#' selected.
#' @export
#'
#' @examples
#' fc <- FormalContext$new(planets)
#' fc[, c("moon", "no_moon")]
`[` = function(objects, attributes) {
self$subcontext(objects, attributes)
},
#' @description
#' Plot the formal context table
#'
#' @param to_latex (logical) If \code{TRUE}, export the plot as a \code{tikzpicture} environment that can be included in a \code{LaTeX} file.
#' @param ... Other parameters to be passed to the \code{tikzDevice} that renders the lattice in \code{LaTeX}, or for the figure caption. See \code{Details}.
#'
#' @details
#' Particular parameters that control the size of the \code{tikz} output are: \code{width}, \code{height} (both in inches), and \code{pointsize} (in points), that should be set to the font size used in the \code{documentclass} header in the \code{LaTeX} file where the code is to be inserted.
#'
#' If a \code{caption} is provided, the whole \code{tikz} picture will be wrapped by a \code{figure} environment and the caption set.
#'
#' @return If \code{to_latex} is \code{FALSE}, it returns nothing, just plots the graph of the formal context. Otherwise, this function returns the \code{LaTeX} code to reproduce the formal context plot.
#'
#' @export
plot = function(to_latex = FALSE,
...) {
if (private$is_many_valued) error_many_valued()
private$check_empty()
if (!private$can_plot) {
warning("The R system has not the needed capabilities to plot.",
call. = FALSE)
return(invisible(FALSE))
}
plot_context(self$I, to_latex, ...)
},
#' @description
#' Sets the logic to use
#'
#'
#' @param name The name of the logic to use. To see the available names, run \code{available_logics()}.
#'
#' @export
use_logic = function(name = available_logics()) {
name <- match.arg(name)
if (name %in% available_logics()) {
private$logic <- name
}
},
#' @description
#' Gets the logic used
#'
#' @return A string with the name of the logic.
#'
#' @export
get_logic = function() {
private$logic
},
#' @description
#' Sets the name of the Galois connection to use
#'
#' @param connection The name of the Galois connection. Available connections are "standard" (antitone), "benevolent1" and "benevolent2" (isotone)
#'
#' @export
use_connection = function(connection) {
if (connection %in% c("standard", "benevolent1", "benevolent2")) {
private$connection <- connection
}
},
#' @description
#' Gets the name of the Galois connection
#'
#' @return A string with the name of the Galois connection
#'
#' @export
get_connection = function() {
private$connection
}
),
private = list(
logic = "Zadeh",
connection = "standard",
is_binary = FALSE,
is_many_valued = FALSE,
can_plot = TRUE,
many_valued_I = NULL,
scales = list(),
bg_implications = NULL,
bg_implications_basis = NULL,
check_empty = function() {
if (self$is_empty()) {
stop("The formal context is empty. The only allowed method is 'load' to import from a previously saved RDS file.", call. = FALSE)
}
return(invisible(NULL))
}
)
)
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.