From bf407a732684210308219fd4fbfe23c34d2d7bfa Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Mon, 25 May 2015 09:43:09 +0200 Subject: [PATCH] Improve package testing. Fix a bug in rule_fill_discrete. --- NAMESPACE | 1 - R/condformat_render.R | 24 +----------- R/rule_fill_discrete.R | 2 +- R/show_columns.R | 13 +++++-- R/show_rows.R | 9 ++++- man/show_columns.Rd | 12 ++++-- man/show_rows.Rd | 8 +++- tests/testthat/test_rendering.R | 42 +++++++++++++++++++++ tests/testthat/test_rule_fill_discrete.R | 27 ++++++++++++++ tests/testthat/test_show.R | 47 ++++++++++++++++++++++++ tests/testthat/test_suite.R | 10 ----- 11 files changed, 153 insertions(+), 42 deletions(-) create mode 100644 tests/testthat/test_rendering.R create mode 100644 tests/testthat/test_rule_fill_discrete.R create mode 100644 tests/testthat/test_show.R delete mode 100644 tests/testthat/test_suite.R diff --git a/NAMESPACE b/NAMESPACE index 3f52d8d..d7fbefb 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/condformat_render.R b/R/condformat_render.R index 080f081..a7961f8 100644 --- a/R/condformat_render.R +++ b/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 diff --git a/R/rule_fill_discrete.R b/R/rule_fill_discrete.R index 15ea621..e7ba2da 100644 --- a/R/rule_fill_discrete.R +++ b/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, diff --git a/R/show_columns.R b/R/show_columns.R index 2b1ef94..831e840 100644 --- a/R/show_columns.R +++ b/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)) { diff --git a/R/show_rows.R b/R/show_rows.R index dbf51e5..d24a0ec 100644 --- a/R/show_rows.R +++ b/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)) { diff --git a/man/show_columns.Rd b/man/show_columns.Rd index 4088b7f..e32fa30 100644 --- a/man/show_columns.Rd +++ b/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}} diff --git a/man/show_rows.Rd b/man/show_rows.Rd index e658e44..db13f3d 100644 --- a/man/show_rows.Rd +++ b/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}} diff --git a/tests/testthat/test_rendering.R b/tests/testthat/test_rendering.R new file mode 100644 index 0000000..d7d7db0 --- /dev/null +++ b/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("^$")) +}) + + +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)) +}) + + diff --git a/tests/testthat/test_rule_fill_discrete.R b/tests/testthat/test_rule_fill_discrete.R new file mode 100644 index 0000000..40a3da9 --- /dev/null +++ b/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("^$")) +}) + + diff --git a/tests/testthat/test_show.R b/tests/testthat/test_show.R new file mode 100644 index 0000000..f82e161 --- /dev/null +++ b/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"))) +}) diff --git a/tests/testthat/test_suite.R b/tests/testthat/test_suite.R deleted file mode 100644 index 209a1c3..0000000 --- a/tests/testthat/test_suite.R +++ /dev/null @@ -1,10 +0,0 @@ -# Tests: -library(condformat) -library(dplyr) - -context("printing condformat") - -test_that("print works", { - data(iris) - print(condformat(iris)) -})