Updated some tests

neuroimaginador · Apr 26, 2023 · aae1e29 · aae1e29
1 parent f96fb5b
commit aae1e29
Show file tree

Hide file tree

Showing 6 changed files with 196 additions and 84 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -67,4 +67,4 @@ VignetteBuilder:
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.1
+RoxygenNote: 7.2.3
diff --git a/R/context_to_latex.R b/R/context_to_latex.R
@@ -1,85 +1,84 @@
-context_to_latex_old <- function(I,
-                                 objects = rownames(I),
-                                 attributes = colnames(I)) {
-
-  objects <- format_label(objects)
-  attributes <- format_label(attributes)
-
-  if (fcaR_options("use_tabulary")) {
-
-    first_time_message(
-      option = "fcaR.tabulary_message",
-      txt = paste0(
-        "Note: You must include the following command in you LaTeX document:\n",
-        "\\usepackage{tabulary}"
-      ))
-
-    format <- c("L",
-                rep("C", length(attributes))) %>%
-      stringr::str_flatten()
-
-  } else {
-
-    format <- c("l",
-                rep("c", length(attributes))) %>%
-      stringr::str_flatten()
-
-  }
-
-
-  objects <- objects %>%
-    stringr::str_replace_all(pattern = stringr::fixed("["),
-                             replacement = "{}[")
-
-  header <- c("", attributes) %>%
-    stringr::str_flatten(" & ")
-  header <- paste0(header, "\\\\")
-
-  rows <- c()
-  for (i in seq_along(objects)) {
-
-    this_row <- c(objects[i], I[i, ]) %>%
-      stringr::str_flatten(" & ")
-
-    rows <- c(rows, this_row)
-
-  }
-
-  rows <- rows %>%
-    stringr::str_flatten("\\\\ \n")
-  rows <- paste0(rows, "\\\\")
-
-  body <- c("\\toprule",
-            header,
-            "\\midrule",
-            rows,
-            "\\bottomrule") %>%
-    stringr::str_flatten("\n")
-
-  if (fcaR_options("use_tabulary")) {
-
-    tabular <- c(
-      paste0("\\begin{tabulary}{0.9\\textwidth}{",
-             format, "}"),
-      body,
-      "\\end{tabulary}") %>%
-      stringr::str_flatten("\n")
-
-  } else {
-
-    tabular <- c(
-      paste0("\\begin{tabular}{",
-             format, "}"),
-      body,
-      "\\end{tabular}") %>%
-      stringr::str_flatten("\n")
-
-  }
-
-  return(tabular)
-
-}
-
+# context_to_latex_old <- function(I,
+#                                  objects = rownames(I),
+#                                  attributes = colnames(I)) {
+#
+#   objects <- format_label(objects)
+#   attributes <- format_label(attributes)
+#
+#   if (fcaR_options("use_tabulary")) {
+#
+#     first_time_message(
+#       option = "fcaR.tabulary_message",
+#       txt = paste0(
+#         "Note: You must include the following command in you LaTeX document:\n",
+#         "\\usepackage{tabulary}"
+#       ))
+#
+#     format <- c("L",
+#                 rep("C", length(attributes))) %>%
+#       stringr::str_flatten()
+#
+#   } else {
+#
+#     format <- c("l",
+#                 rep("c", length(attributes))) %>%
+#       stringr::str_flatten()
+#
+#   }
+#
+#
+#   objects <- objects %>%
+#     stringr::str_replace_all(pattern = stringr::fixed("["),
+#                              replacement = "{}[")
+#
+#   header <- c("", attributes) %>%
+#     stringr::str_flatten(" & ")
+#   header <- paste0(header, "\\\\")
+#
+#   rows <- c()
+#   for (i in seq_along(objects)) {
+#
+#     this_row <- c(objects[i], I[i, ]) %>%
+#       stringr::str_flatten(" & ")
+#
+#     rows <- c(rows, this_row)
+#
+#   }
+#
+#   rows <- rows %>%
+#     stringr::str_flatten("\\\\ \n")
+#   rows <- paste0(rows, "\\\\")
+#
+#   body <- c("\\toprule",
+#             header,
+#             "\\midrule",
+#             rows,
+#             "\\bottomrule") %>%
+#     stringr::str_flatten("\n")
+#
+#   if (fcaR_options("use_tabulary")) {
+#
+#     tabular <- c(
+#       paste0("\\begin{tabulary}{0.9\\textwidth}{",
+#              format, "}"),
+#       body,
+#       "\\end{tabulary}") %>%
+#       stringr::str_flatten("\n")
+#
+#   } else {
+#
+#     tabular <- c(
+#       paste0("\\begin{tabular}{",
+#              format, "}"),
+#       body,
+#       "\\end{tabular}") %>%
+#       stringr::str_flatten("\n")
+#
+#   }
+#
+#   return(tabular)
+#
+# }
 
 context_to_latex <- function(I,
                              objects = rownames(I),

diff --git a/tests/testthat/test-concept_lattice.R b/tests/testthat/test-concept_lattice.R
@@ -40,8 +40,14 @@ test_that("fcaR plots a ConceptLattice", {
   skip_on_cran()
   skip_if_not_installed("hasseDiagram")
   expect_error(fc$concepts$plot(), NA)
+  fcaR_options("escape_" = FALSE)
   expect_error(fc$concepts$plot(object_names = FALSE), NA)
 
+  fcaR_options("reduced_lattice" = FALSE)
+  expect_error(fc$concepts$plot(), NA)
+  expect_error(fc$concepts$plot(object_names = FALSE), NA)
+
+
   # expect_error(fc$concepts$plot(to_latex = TRUE), NA)
   # expect_error(fc$concepts$plot(to_latex = TRUE,
   #                               filename = "./test.tex",
@@ -83,6 +89,8 @@ test_that("fcaR extracts concepts from a ConceptLattice", {
   expect_is(L, "ConceptSet")
   expect_is(L$to_list()[[1]], "Concept")
   expect_error(fc$concepts[fc$concepts$support() > 0.5], NA)
+  expect_error(fc$concepts$top(), NA)
+  expect_error(fc$concepts$bottom(), NA)
 
 })
 
@@ -110,6 +118,8 @@ test_that("fcaR computes the sublattice of a ConceptLattice", {
   expect_error(cl <- fc$concepts$sublattice(fc$concepts$support() > 0.1), NA)
   expect_is(cl, "ConceptLattice")
 
+  expect_error(fc$concepts$sublattice(as.list(fc$concepts)), NA)
+
 })
 
 test_that("fcaR computes the join- and meet- irreducibles of a ConceptLattice", {

diff --git a/tests/testthat/test-formal_context.R b/tests/testthat/test-formal_context.R
@@ -160,7 +160,10 @@ test_that("fcaR exports FormalContexts to LaTeX", {
   fc <- FormalContext$new(I)
 
   expect_error(fc$to_latex(), NA)
+  expect_error(context_to_latex(fc$incidence()), NA)
 
+  fcaR_options("use_tabulary" = TRUE)
+  expect_error(context_to_latex(fc$incidence(), rotated = TRUE), NA)
   fc2 <- FormalContext$new(planets)
 
   expect_error(fc2$to_latex(), NA)
@@ -189,11 +192,25 @@ test_that("fcaR extracts concepts", {
   rownames(I) <- objects
 
   fc <- FormalContext$new(I = I)
+  fc$use_logic("Product")
 
   fc$find_concepts(verbose = FALSE)
 
   expect_is(fc$concepts, "ConceptLattice")
 
+  # Different Galois connections and logics
+  fc <- FormalContext$new(I = I[1:3, 1:3])
+  # fc$use_connection("benevolent1")
+  fc$use_logic("Godel")
+  fc$find_concepts(verbose = FALSE)
+  expect_is(fc$concepts, "ConceptLattice")
+
+  fc <- FormalContext$new(I = I)
+  fc$use_connection("benevolent2")
+  fc$use_connection("Lukasiewicz")
+  fc$find_concepts(verbose = FALSE)
+  expect_is(fc$concepts, "ConceptLattice")
+
 })
 
 test_that("fcaR extracts implications", {
@@ -222,6 +239,19 @@ test_that("fcaR extracts implications", {
 
   expect_is(fc$implications, "ImplicationSet")
 
+  # Different Galois connections and logics
+  fc <- FormalContext$new(I = I)
+  fc$use_connection("benevolent1")
+  fc$use_logic("Product")
+  fc$find_implications(verbose = TRUE)
+  expect_is(fc$implications, "ImplicationSet")
+
+  fc <- FormalContext$new(I = I)
+  fc$use_connection("benevolent2")
+  fc$use_connection("Lukasiewicz")
+  fc$find_implications(verbose = TRUE)
+  expect_is(fc$implications, "ImplicationSet")
+
 })
 
 test_that("fcaR generate plots", {
@@ -265,6 +295,16 @@ test_that("fcaR generate plots", {
 
 })
 
+test_that("fcaR subsets formal contexts", {
+
+  fc <- FormalContext$new(planets)
+  expect_is(fc[, c("large", "moon")], "FormalContext")
+  expect_is(fc[c("Earth", "Mars"), ], "FormalContext")
+
+  expect_is(fc[c("Earth", "Mars"), c("large", "moon")], "FormalContext")
+
+})
+
 test_that("fcaR imports formal contexts from arules", {
 
   skip_if_not_installed("arules")
@@ -334,6 +374,20 @@ test_that("fcaR saves and loads formal contexts", {
 
   expect_error(fc2 <- FormalContext$new(filename), NA)
 
+  filename <- tempfile(fileext = ".CXT")
+
+  fc <- FormalContext$new(I = I)
+
+  expect_error(fc$save(filename = filename), NA)
+  fc$find_implications()
+
+  expect_error(fc$save(filename = filename), NA)
+
+  expect_error(fc2 <- FormalContext$new(), NA)
+  expect_error(fc2$load(filename), NA)
+
+  expect_error(fc2 <- FormalContext$new(filename), NA)
+
 
 })
 

diff --git a/tests/testthat/test-implication_set.R b/tests/testthat/test-implication_set.R
@@ -667,3 +667,34 @@ test_that(desc = "fcaR can use equivalence rules", {
   }
 
 })
+
+test_that("fcaR combines implications", {
+
+  objects <- paste0("O", 1:6)
+  n_objects <- length(objects)
+
+  attributes <- paste0("P", 1:6)
+  n_attributes <- length(attributes)
+
+  I <- matrix(data = c(0, 1, 0.5, 0, 0, 0.5,
+                       1, 1, 0.5, 0, 0, 0,
+                       0.5, 1, 0, 0, 1, 0,
+                       0.5, 0, 0, 1, 0.5, 0,
+                       1, 0, 0, 0.5, 0, 0,
+                       0, 0, 1, 0, 0, 0),
+              nrow = n_objects,
+              byrow = FALSE)
+
+  colnames(I) <- attributes
+  rownames(I) <- objects
+
+  fc <- FormalContext$new(I = I)
+
+  fc$find_implications()
+  expect_error(new_imps <- combine_implications(fc$implications[1:3], fc$implications[4:7]), NA)
+  expect_equal(new_imps$cardinality(), 7)
+  expect_error(new_imps <- combine_implications(fc$implications[0], fc$implications[0]), NA)
+  expect_equal(new_imps$cardinality(), 0)
+
+
+})
diff --git a/tests/testthat/test-sparse_set.R b/tests/testthat/test-sparse_set.R
@@ -63,7 +63,7 @@ test_that("fcaR uses class Set", {
 
 })
 
-test_that("fcaR computes differences of Sets", {
+test_that("fcaR computes operations of Sets", {
 
   attributes <- paste0("P", 1:6)
 
@@ -76,4 +76,22 @@ test_that("fcaR computes differences of Sets", {
   expect_error(A %-% B, NA)
   expect_error(B %-% A, NA)
 
+  # Build two sparse sets
+  S <- Set$new(attributes = c("A", "B", "C"))
+  S$assign(A = 1, B = 1)
+  T <- Set$new(attributes = c("A", "B", "C"))
+  T$assign(A = 1, C = 1)
+
+  # Intersection
+  expect_error(S %&% T, NA)
+
+  # Build two sparse sets
+  S <- Set$new(attributes = c("A", "B", "C"))
+  S$assign(A = 1, B = 1)
+  T <- Set$new(attributes = c("A", "B", "C"))
+  T$assign(C = 1)
+
+  # Union
+  expect_error(S %|% T, NA)
+
 })