tests/testthat/test_add_css_conditional_column.R

In tableHTML: A Tool to Create HTML Tables

context("add_css_conditional_column testing")

test_that("Function fails for wrong inputs", {

  # no tableHTML
  expect_error(add_css_conditional_column(mtcars, 1),
               'tableHTML needs to be')

  #deprecated levels
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(columns = 1, levels = "13"),
               "levels is deprecated")

  # no columns specified
  expect_error(tableHTML(mtcars) %>% add_css_conditional_column(conditional = "==", value = 1,
                                                                css = list('background-color', 'lightgray')),
               'argument "columns" is missing, with no default')

  # wrong conditional argument
  expect_error(tableHTML(mtcars) %>% add_css_conditional_column(columns = 1,
                                                                conditional = "blubb"),
               "arg' should be one of ")

  # no css provided
  expect_error(tableHTML(mtcars) %>% add_css_conditional_column(conditional = "==", value = 1, column = 1),
               'css needs to be provided')



  # typeof columns numeric and character
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(conditional = "==", value = 1,
                                            columns = c("rownames", 1),
                                            css = list('background-color', 'lightgray')),
               'columns must either be numeric or text')

  # no rownames in tableHTML, but css to be applied
  expect_error(tableHTML(mtcars, rownames = FALSE) %>%
                 add_css_conditional_column(conditional = "==", value = 1,
                                            columns = c("rownames"),
                                            css = list('background-color', 'lightgray')),
               'tableHTML does not have rownames')

  # no rowgroups in tableHTML, but css to be applied
  expect_error(tableHTML(mtcars, rownames = FALSE) %>%
                 add_css_conditional_column(conditional = "==", value = 1,
                                            columns = c("row_groups"),
                                            css = list('background-color', 'lightgray')),
               'tableHTML does not have row_groups')

  #begin and end values missing
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(conditional = "between",
                                            columns = c(1),
                                            css = list('background-color', 'lightgray')),
               'begin and end values for between need to be provided')

  # length of between not 2
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(conditional = "between", between = 1,
                                            columns = c(1),
                                            css = list('background-color', 'lightgray')),
               'between needs to be a vector')

  # between not a numeric vector
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(conditional = "between", between = list(1, 2),
                                            columns = c(1),
                                            css = list('background-color', 'lightgray')),
               'between needs to be a vector')

  # begin ! <= end
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(conditional = "between", between = c(2, 1),
                                            columns = c(1),
                                            css = list('background-color', 'lightgray')),
               'begin must be smaller than end in between')

  # top_n warning
  expect_warning(tableHTML(mtcars) %>%
                   add_css_conditional_column(conditional = "top_n",
                                              columns = c(1),
                                              css = list('background-color', 'lightgray')),
                 'n not provided')

  # bottom_n warning
  expect_warning(tableHTML(mtcars) %>%
                   add_css_conditional_column(conditional = "bottom_n",
                                              columns = c(1),
                                              css = list('background-color', 'lightgray')),
                 'n not provided')

  # n greater than number of rows
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(conditional = "top_n",
                                            columns = c(1),
                                            css = list('background-color', 'lightgray'),
                                            n = 33),
               "n cannot exceed")

  # n equal to number of rows
  expect_warning(tableHTML(mtcars) %>%
                   add_css_conditional_column(conditional = "top_n",
                                              columns = c(1),
                                              css = list('background-color', 'lightgray'),
                                              n = 32),
                 "all rows selected")

  # comparison value not provided
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(conditional = "==",
                                            columns = c(1),
                                            css = list('background-color', 'lightgray')),
               "comparison value needed")

  # begin values not numeric
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(conditional = "between",
                                            columns = c(1),
                                            css = list('background-color', 'lightgray'),
                                            between = c("a", 1)),
               "begin and end values of begin")

  # custom colour rank theme selected with default colour rank theme
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(conditional = "color_rank",
                                            columns = c(1),
                                            color_rank_theme = "Custom"),
               "color_rank_css needs to be provided")

  # wrong format of custom css
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(conditional = "color_rank",
                                            columns = c(1),
                                            color_rank_theme = "Custom",
                                            color_rank_css = list(mpg = list(list(rep("red", 32))))),
               "color_rank_css must be a list of 2")

  # unnamed list
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(conditional = "color_rank",
                                            columns = c(1),
                                            color_rank_theme = "Custom",
                                            color_rank_css = list(list("background-color", list(rep("red", 32))))),
               "color_rank_css must be a named list")

  # logical without a logical_condition
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(conditional = "logical",
                                            columns = c(1)),
               "logical_conditions should be provided")

  # logical_condition has the wrong nmber of vectors
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(
                   conditional = "logical",
                   columns = c(1, 2),
                   logical_condition=list(mtcars$mpg>30,
                                          mtcars$mpg>25,
                                          mtcars$mpg>20)),
               "logical_conditions should have the same length")

  # vectors in logical_condition have the wrong length
  expect_error(tableHTML(mtcars) %>%
                 add_css_conditional_column(
                   conditional = "logical",
                   columns = c(1, 2),
                   logical_condition=list(c(TRUE, FALSE))),
               "each vector in logical_conditions should have")

})

test_that("data is added", {
  expect_error(tableHTML(mtcars, add_data = FALSE) %>%
                 add_css_conditional_column(),
               "tableHTML object does not have data in attributes.")
})

test_that("equations and inequations work", {

  #test that css is applied to column 1, row 4 + 32
  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "==", value = 21.4, css = list('background-color', "green"), columns = c("mpg"))

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]

      which(vapply(seq_along(starts), function(i) {
        grepl('style="background-color:green;"', substr(tableHTML, starts[i], ends[i] + 4))
      }, FUN.VALUE = logical(1)))
    },
    expected = c(38, 374)
  )
  #test that css is NOT applied to column 1, row 4 + 32
  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "!=", value = 21.4, css = list('background-color', "green"), columns = c("mpg"))

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]

      which(vapply(seq_along(starts), function(i) {
        grepl('style="background-color:green;"', substr(tableHTML, starts[i], ends[i] + 4))
      }, FUN.VALUE = logical(1)))
    },
    expected = c(2, 14, 26, 50, 62, 74, 86, 98, 110, 122, 134, 146, 158, 170, 182, 194,
                 206, 218, 230, 242, 254, 266, 278, 290, 302, 314, 326, 338, 350, 362)
  )

  #test inequations
  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "<", value = 14.7, css = list('background-color', "green"), columns = c("mpg")) %>%
        add_css_conditional_column(conditional = "<=", value = 75.7, css = list('background-color', "blue"), columns = c("disp")) %>%
        add_css_conditional_column(conditional = ">", value = 4, css = list('background-color', "red"), columns = c("gear")) %>%
        add_css_conditional_column(conditional = ">=", value = 6, css = list('background-color', "orange"), columns = c("carb"))

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]
      c(
        which(vapply(seq_along(starts), function(i) {
          grepl('style="background-color:green;"', substr(tableHTML, starts[i], ends[i] + 4))
        }, FUN.VALUE = logical(1))),
        which(vapply(seq_along(starts), function(i) {
          grepl('style="background-color:blue;"', substr(tableHTML, starts[i], ends[i] + 4))
        }, FUN.VALUE = logical(1))),
        which(vapply(seq_along(starts), function(i) {
          grepl('style="background-color:red;"', substr(tableHTML, starts[i], ends[i] + 4))
        }, FUN.VALUE = logical(1))),
        which(vapply(seq_along(starts), function(i) {
          grepl('style="background-color:orange;"', substr(tableHTML, starts[i], ends[i] + 4))
        }, FUN.VALUE = logical(1)))
      )
    },
    expected = c(74, 170, 182, 278, 220, 232, 323, 335, 347, 359, 371, 360, 372)
  )

  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = ">", value = 4.43, css = list('background-color', "orange"), columns = c("drat", "wt"))


      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]
      which(vapply(seq_along(starts), function(i) {
        grepl('style="background-color:orange;"', substr(tableHTML, starts[i], ends[i] + 4))
      }, FUN.VALUE = logical(1)))
    },
    expected = c(175, 187, 199, 222)
  )

})

test_that("min max work", {

  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "min", css = list('background-color', "orange"), columns = c("qsec"))

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]

      which(vapply(seq_along(starts), function(i) {
        grepl('style="background-color:orange;"', substr(tableHTML, starts[i], ends[i] + 4))
      }, FUN.VALUE = logical(1)))
    },
    expected = 344
  )

  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "max", css = list('background-color', "orange"), columns = c("qsec"))

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]

      which(vapply(seq_along(starts), function(i) {
        grepl('style="background-color:orange;"', substr(tableHTML, starts[i], ends[i] + 4))
      }, FUN.VALUE = logical(1)))
    },
    expected = 104
  )

  #test that only 1 highlighted
  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "min",css = list('background-color', "orange"),
                                   columns = c("gear", "carb"), same_scale = TRUE)

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]

      which(vapply(seq_along(starts), function(i) {
        grepl('style="background-color:orange;"', substr(tableHTML, starts[i], ends[i] + 4))
      }, FUN.VALUE = logical(1)))
    },
    expected = c(36, 48, 72, 216, 240, 252, 312)
  )

  #test 1 in carb and 3 in gear highlighted
  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "min",css = list('background-color', "orange"),
                                   columns = c("gear", "carb"), same_scale = FALSE)

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]

      which(vapply(seq_along(starts), function(i) {
        grepl('style="background-color:orange;"', substr(tableHTML, starts[i], ends[i] + 4))
      }, FUN.VALUE = logical(1)))
    },
    expected = c(36, 47, 48, 59, 71, 72, 83, 143, 155, 167, 179, 191, 203, 216, 240, 251, 252, 263, 275, 287, 299, 312)
  )

})

test_that("top_n and bottom_n work", {

  #top 5 in drat, top in wt
  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "top_n", n = 5, css = list('background-color', "orange"),
                                   columns = c("drat", "wt"), same_scale = FALSE)

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]

      which(vapply(seq_along(starts), function(i) {
        grepl('style="background-color:orange;"', substr(tableHTML, starts[i], ends[i] + 4))
      }, FUN.VALUE = logical(1)))
    },
    expected = c(139, 175, 187, 199, 222, 234, 295, 318, 342, 378)
  )

  #top 5 in drat AND wt
  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "top_n", n = 5, css = list('background-color', "orange"),
                                   columns = c("drat", "wt"), same_scale = TRUE)

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]

      which(vapply(seq_along(starts), function(i) {
        grepl('style="background-color:orange;"', substr(tableHTML, starts[i], ends[i] + 4))
      }, FUN.VALUE = logical(1)))
    },
    expected = c(175, 187, 199, 222, 318)
  )

  #bottom_1 == min
  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "bottom_n", n = 1, css = list('background-color', "orange"),
                                   columns = c("drat", "wt"), same_scale = TRUE)

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]

      which(vapply(seq_along(starts), function(i) {
        grepl('style="background-color:orange;"', substr(tableHTML, starts[i], ends[i] + 4))
      }, FUN.VALUE = logical(1)))
    },
    expected = {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "min", css = list('background-color', "orange"),
                                   columns = c("drat", "wt"), same_scale = TRUE)

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]

      which(vapply(seq_along(starts), function(i) {
        grepl('style="background-color:orange;"', substr(tableHTML, starts[i], ends[i] + 4))
      }, FUN.VALUE = logical(1)))
    }
  )

})

test_that("between works", {

  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "between", between = c(3.5, 3.7), css = list('background-color', "orange"),
                                   columns = c("drat"))

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]

      which(vapply(seq_along(starts), function(i) {
        grepl('style="background-color:orange;"', substr(tableHTML, starts[i], ends[i] + 4))
      }, FUN.VALUE = logical(1)))
    },
    expected = c(90, 246, 354, 366)
  )



})

test_that("color rank works", {
  #check colors are correct
  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(conditional = "color_rank", color_rank_theme = "RAG",
                                   columns = c("carb"))

      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]
      colors <-
        vapply(seq_along(starts), function(i) {
          td <- substr(tableHTML, starts[i], ends[i] + 4)
          ifelse(grepl('style="', td), substr(td, gregexpr("#", td)[[1]], gregexpr("#", td)[[1]] + 6), NA_character_)
        }, FUN.VALUE = character(1))
      colors <- colors[!is.na(colors)]
    },
    expected = c('#E8E58F', '#E8E58F', '#86C183', '#86C183', '#A3CB87', '#86C183', '#E8E58F', '#A3CB87',
                 '#A3CB87', '#E8E58F', '#E8E58F', '#C2D78B', '#C2D78B', '#C2D78B', '#E8E58F', '#E8E58F',
                 '#E8E58F', '#86C183', '#A3CB87', '#86C183', '#86C183', '#A3CB87', '#A3CB87', '#E8E58F',
                 '#A3CB87', '#86C183', '#A3CB87', '#A3CB87', '#E8E58F', '#F0B681', '#F8696B', '#A3CB87')
  )

  # check colors on same scale
  expect_equal(
    {
      tableHTML <- tableHTML(data.frame(a = 1:10, b = rep(1:5, 2)), rownames = FALSE) %>%
        add_css_conditional_column(conditional = "color_rank", color_rank_theme = "RAG",
                                   columns = c("a", "b"), same_scale = TRUE)
      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]
      colors <-
        vapply(seq_along(starts), function(i) {
          td <- substr(tableHTML, starts[i], ends[i] + 4)
          ifelse(grepl('style="', td), substr(td, gregexpr("#", td)[[1]], gregexpr("#", td)[[1]] + 6), NA_character_)
        }, FUN.VALUE = character(1))

    },
    expected = c('#86C183', '#86C183', '#9CC986', '#9CC986', '#B3D189',
                 '#B3D189', '#CFDC8C', '#CFDC8C', '#EDE690', '#EDE690',
                 '#F9DE8D', '#86C183', '#F3C285', '#9CC986', '#F0A67C',
                 '#B3D189', '#F38773', '#CFDC8C', '#F8696B', '#EDE690')
  )

  #check independent scales
  expect_equal(
    {
      tableHTML <- tableHTML(data.frame(a = 1:10, b = rep(1:5, 2)), rownames = FALSE) %>%
        add_css_conditional_column(conditional = "color_rank", color_rank_theme = "RAG",
                                   columns = c("a", "b"), same_scale = FALSE)
      starts <- gregexpr("<td", tableHTML)[[1]]

      ends <- gregexpr("</td>", tableHTML)[[1]]
      colors <-
        vapply(seq_along(starts), function(i) {
          td <- substr(tableHTML, starts[i], ends[i] + 4)
          ifelse(grepl('style="', td), substr(td, gregexpr("#", td)[[1]], gregexpr("#", td)[[1]] + 6), NA_character_)
        }, FUN.VALUE = character(1))

    },
    expected = c('#86C183', '#86C183', '#9CC986', '#B9D48A', '#B3D189',
                 '#FCEC92', '#CFDC8C', '#EFAE7F', '#EDE690', '#F8696B',
                 '#F9DE8D', '#86C183', '#F3C285', '#B9D48A', '#F0A67C',
                 '#FCEC92', '#F38773', '#EFAE7F', '#F8696B', '#F8696B')
  )

})

test_that("logical works", {

  # one column, one logical vector
  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(
          conditional = "logical",
          logical_conditions = list(mtcars$hp==110),
          css = list('background-color', "orange"),
          columns = c("drat"))

      strsplit(tableHTML, '<td') %>%
        unlist() %>%
        grep('style="background-color:orange;"', . )
    },
    expected = c(7, 19, 43)
  )

  # multiple columns, one logical vector
  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(
          conditional = "logical",
          logical_conditions = list(mtcars$hp==110),
          css = list('background-color', "orange"),
          columns = c(1, 3, 4))

      strsplit(tableHTML, '<td') %>%
        unlist() %>%
        grep('style="background-color:orange;"', . )
    },
    expected = c(3, 5, 6, 15, 17, 18, 39, 41, 42)
  )

  # multiple columns, multiple logical vectors
  expect_equal(
    {
      tableHTML <- tableHTML(mtcars) %>%
        add_css_conditional_column(
          conditional = "logical",
          logical_conditions =
            list(mtcars$hp==110,
                 mtcars$wt==3.44,
                 mtcars$drat==3.92),
          css = list('background-color', "orange"),
          columns = c('mpg', 'qsec', 'gear'))

      strsplit(tableHTML, '<td') %>%
        unlist() %>%
        grep('style="background-color:orange;"', . )
    },
    expected = c(3, 15, 39, 57, 108, 117, 120, 129, 132)
  )
})