Improve package testing. Fix a bug in rule_fill_discrete.

NAMESPACE

@@ -16,7 +16,6 @@ export(show_columns_)
 export(show_rows)
 export(show_rows_)
 importFrom(assertthat,are_equal)
-importFrom(assertthat,assert_that)
 importFrom(dplyr,filter_)
 importFrom(dplyr,select_vars_)
 importFrom(dplyr,tbl_df)

R/condformat_render.R

@@ -9,7 +9,8 @@
 #' @export
 print.condformat_tbl <- function(x, ...) {
   thetable <- condformat2html(x)
-  invisible(print(thetable))
+  print(thetable)
+  invisible(x)
 }
 
 
@@ -80,27 +81,6 @@ merge_css_conditions <- function(initial_value, css_fields) {
   return(output)
 }
 
-#' @importFrom assertthat assert_that
-test_merge_css_conditions <- function() {
-  css_fields <- list("background" = matrix(c("red", "red",
-                                           "blue", "green",
-                                           "yellow", "orange"),
-                                         nrow = 3, ncol = 2, byrow = TRUE),
-                     "text-align" = matrix(c("left", "right",
-                                             "left", "center",
-                                             "right", "left"),
-                                           nrow = 3, ncol = 2, byrow = TRUE))
-  output <- merge_css_conditions(matrix("", nrow = 3, ncol = 2),
-                                 css_fields)
-  expected_output <- matrix(c("; background: red; text-align: left", "; background: red; text-align: right",
-                              "; background: blue; text-align: left", "; background: green; text-align: center",
-                              "; background: yellow; text-align: right", "; background: orange; text-align: left"),
-                            nrow = 3, ncol = 2, byrow = TRUE)
-  assertthat::assert_that(nrow(output) == 3)
-  assertthat::assert_that(ncol(output) == 2)
-  assertthat::assert_that(all(output == expected_output))
-}
-
 #' Renders the css matrix to format the xview table
 #'
 #' @param rules List of rules to be applied

R/rule_fill_discrete.R

@@ -112,7 +112,7 @@ applyrule.rule_fill_discrete_ <- function(rule, finalformat, xfiltered, xview, .
 rule_fill_discrete_common <- function(rule, finalformat, xfiltered, xview,
                                       columns, values_determining_color) {
   colours_for_values <- NA
-  if (is.na(rule$colours)) {
+  if (identical(rule$colours, NA)) {
     number_colours <- length(levels(values_determining_color))
     col_scale <- scales::hue_pal(h = rule$h, c = rule$c, l = rule$l,
                                  h.start = rule$h.start,

R/show_columns.R

@@ -10,9 +10,10 @@
 #' @return A condformat_show_columns object, usually to be added to a condformat_tbl object
 #' @examples
 #' data(iris)
-#' condformat(iris) + show_columns(Sepal.Length, Sepal.Width, Species)
-#' condformat(iris) + show_columns(-Petal.Length, -Petal.Width)
-#' condformat(iris) + show_columns(starts_with("Petal"), Species)
+#' x <- head(iris)
+#' condformat(x) + show_columns(Sepal.Length, Sepal.Width, Species)
+#' condformat(x) + show_columns(-Petal.Length, -Petal.Width)
+#' condformat(x) + show_columns(starts_with("Petal"), Species)
 #' @importFrom lazyeval lazy_dots
 #' @export
 #' @seealso \code{\link[dplyr]{select}}
@@ -27,6 +28,12 @@ show_columns <- function(..., col_names) {
 #' @inheritParams dplyr::select
 #' @importFrom lazyeval all_dots
 #' @export
+#' @examples
+#' data(iris)
+#' x <- head(iris)
+#' condformat(x) + show_columns_(.dots = c("Sepal.Length", "Species"))
+#' condformat(x) + show_columns_(.dots = c("Sepal.Length", "Species"),
+#'                               col_names = c("Sepal Length", "Species"))
 show_columns_ <- function(..., .dots, col_names) {
   dots <- lazyeval::all_dots(.dots, ...)
   if (missing(col_names)) {

R/show_rows.R

@@ -9,8 +9,10 @@
 #' @return A condformat_show_rows object, usually to be added to a condformat_tbl object
 #'         as shown in the examples
 #' @examples
+#' library(condformat)
 #' data(iris)
-#' condformat(iris) + show_rows(Sepal.Length > 4.5, Species == "setosa")
+#' x <- head(iris)
+#' condformat(x) + show_rows(Sepal.Length > 4.5, Species == "setosa")
 #' @importFrom lazyeval lazy_dots
 #' @export
 #' @seealso \code{\link[dplyr]{filter}}
@@ -26,6 +28,11 @@ show_rows <- function(...) {
 #' @importFrom lazyeval all_dots
 #' @aliases show_rows
 #' @export
+#' @examples
+#' library(condformat)
+#' data(iris)
+#' x <- head(iris)
+#' condformat(x) + show_rows_(.docts = c("Sepal.Length > 4.5", "Species == 'setosa'"))
 show_rows_ <- function(..., .dots) {
   dots <- lazyeval::all_dots(.dots, ...)
 #   if (missing(row_names)) {

man/show_columns.Rd

@@ -28,9 +28,15 @@ on them.
 }
 \examples{
 data(iris)
-condformat(iris) + show_columns(Sepal.Length, Sepal.Width, Species)
-condformat(iris) + show_columns(-Petal.Length, -Petal.Width)
-condformat(iris) + show_columns(starts_with("Petal"), Species)
+x <- head(iris)
+condformat(x) + show_columns(Sepal.Length, Sepal.Width, Species)
+condformat(x) + show_columns(-Petal.Length, -Petal.Width)
+condformat(x) + show_columns(starts_with("Petal"), Species)
+data(iris)
+x <- head(iris)
+condformat(x) + show_columns_(.dots = c("Sepal.Length", "Species"))
+condformat(x) + show_columns_(.dots = c("Sepal.Length", "Species"),
+                              col_names = c("Sepal Length", "Species"))
 }
 \seealso{
 \code{\link[dplyr]{select}}

man/show_rows.Rd

@@ -25,8 +25,14 @@ Compared to \code{\link[dplyr]{filter}}, show_rows does not remove the
 rows from the actual data frame, they are removed only for printing.
 }
 \examples{
+library(condformat)
 data(iris)
-condformat(iris) + show_rows(Sepal.Length > 4.5, Species == "setosa")
+x <- head(iris)
+condformat(x) + show_rows(Sepal.Length > 4.5, Species == "setosa")
+library(condformat)
+data(iris)
+x <- head(iris)
+condformat(x) + show_rows_(.docts = c("Sepal.Length > 4.5", "Species == 'setosa'"))
 }
 \seealso{
 \code{\link[dplyr]{filter}}

tests/testthat/test_rendering.R

@@ -0,0 +1,42 @@
+# Tests:
+library(condformat)
+library(dplyr)
+library(testthat)
+context("rendering")
+
+test_that("print.condformat_tbl returns its input", {
+  data(iris)
+  x <- condformat(head(iris))
+  out <- print(x)
+  expect_that(out,is_identical_to(x))
+})
+
+test_that("knitr returns an HTML table", {
+  data(iris)
+  library(knitr)
+  out <- knit_print(condformat(head(iris)))
+  expect_that(out, matches("^<table.*</table>$"))
+})
+
+
+test_that("merge_css_conditions returns the expected", {
+  css_fields <- list("background" = matrix(c("red", "red",
+                                             "blue", "green",
+                                             "yellow", "orange"),
+                                           nrow = 3, ncol = 2, byrow = TRUE),
+                     "text-align" = matrix(c("left", "right",
+                                             "left", "center",
+                                             "right", "left"),
+                                           nrow = 3, ncol = 2, byrow = TRUE))
+
+  output <- merge_css_conditions(matrix("", nrow = 3, ncol = 2), css_fields)
+  expected_output <- matrix(c("; background: red; text-align: left", "; background: red; text-align: right",
+                              "; background: blue; text-align: left", "; background: green; text-align: center",
+                              "; background: yellow; text-align: right", "; background: orange; text-align: left"),
+                            nrow = 3, ncol = 2, byrow = TRUE)
+  expect_that(nrow(output), equals(3))
+  expect_that(ncol(output), equals(2))
+  expect_that(output, equals(expected_output))
+})
+
+

tests/testthat/test_rule_fill_discrete.R

@@ -0,0 +1,27 @@
+# Tests:
+library(condformat)
+library(dplyr)
+library(testthat)
+context("show")
+
+test_that("rule_fill_discrete works", {
+  data(iris)
+  x <- condformat(iris[c(1:10, 51:60, 101:110),])
+  y <- x + rule_fill_discrete(Species,
+                              expression  = Sepal.Length > max(Sepal.Length),
+                              colours = c("TRUE" = "red", "FALSE" = "blue"))
+  out <- condformat2html(y)
+  expect_that(out[1], not(matches("red")))
+
+  y <- x + rule_fill_discrete(Species,
+                              expression  = Sepal.Length >= min(Sepal.Length),
+                              colours = c("TRUE" = "red", "FALSE" = "blue"))
+  out <- condformat2html(y)
+  expect_that(out[1], not(matches("blue")))
+
+  y <- x + rule_fill_discrete(Species)
+  out <- condformat2html(y)
+  expect_that(out[1], matches("^<table.*</table>$"))
+})
+
+

tests/testthat/test_show.R

@@ -0,0 +1,47 @@
+# Tests:
+library(condformat)
+library(dplyr)
+library(testthat)
+context("show")
+
+test_that("show_column works", {
+  data(iris)
+  x <- condformat(head(iris)) + show_columns(-Sepal.Length)
+  expect_true("Sepal.Length" %in% colnames(x))
+  out <- condformat2html(x)
+  expect_that(out[1], not(matches("Sepal.Length")))
+  expect_that(out[1], matches("Sepal.Width"))
+  expect_that(out[1], matches("Petal.Length"))
+  expect_that(out[1], matches("Petal.Width"))
+  expect_that(out[1], matches("Species"))
+})
+
+test_that("show_column works with custom names", {
+  data(iris)
+  x <- condformat(head(iris)) + show_columns(Sepal.Length, Petal.Width, Species,
+                                             col_names = c("MySepLen", "MyPetWi", "MySpe"))
+  expect_true("Sepal.Length" %in% colnames(x))
+  expect_true("Petal.Length" %in% colnames(x))
+  out <- condformat2html(x)
+  expect_that(out[1], not(matches("Sepal.Length")))
+  expect_that(out[1], not(matches("Sepal.Width")))
+  expect_that(out[1], not(matches("Petal.Length")))
+  expect_that(out[1], not(matches("Petal.Width")))
+  expect_that(out[1], not(matches("Species")))
+  expect_that(out[1], matches("MySepLen"))
+  expect_that(out[1], matches("MyPetWi"))
+  expect_that(out[1], matches("MySpe"))
+})
+
+
+test_that("show_row works", {
+  data(iris)
+  x <- condformat(head(iris, n = 10)) +
+    show_rows(Sepal.Length == 5.1, Sepal.Width == 3.5,
+              Petal.Length == 1.4, Petal.Width == 0.2)
+  # in the data frame nothing is filtered
+  expect_that(nrow(x), equals(10))
+  out <- condformat2html(x)
+  # the html code only shows one row (that does not have any 8 digit)
+  expect_that(out[1], not(matches("8")))
+})