tests/testthat/test-recolor.R

In greatgray/scorecard: GGCM Model Performance Scorecard

context("Recolor rank")

suppressPackageStartupMessages(library(gridExtra))
suppressPackageStartupMessages(library(gtable))

load_data <- function() {
  # create mock scorecard
  md <- matrix(data = 1:4, nrow=4, ncol=5, byrow = FALSE)
  sdf <- data.frame(md)
  colnames(sdf) <- c("Index","CAGR","MDD","Calmar","Sortino")
  tg <- gridExtra::tableGrob(sdf)

  textg <- grid::textGrob("Test", gp = grid::gpar(fontsize = 24))
  dfg <- gridExtra::tableGrob(sdf, rows = NULL)

  # table body, title, border
  table <-
    gtable::gtable_add_rows(dfg,
                            heights = grid::grobHeight(textg),
                            pos = 0)
  table <-
    gtable::gtable_add_grob(table,
                            textg,
                            1,
                            1,
                            1,
                            ncol(table))
  table <-
    gtable::gtable_add_grob(table,
                            grobs = grid::rectGrob(gp = grid::gpar(fill = NA,
                                                                   lwd = 2)),
                            t = 2,
                            b = nrow(table),
                            l = 1,
                            r = ncol(table))

  return(list(md=md,sdf=sdf,tg=tg,table=table))
}

test_that("rank accepts defaults missing grob rows", {
  data <- load_data()
  fc <- "yellow"
  rv <- recolor_rank(data$tg,data$sdf,fc)
  expect_false(rv$grobs[[42]][[9]]$fill == data$tg$grobs[[42]][[9]]$fill)
  expect_false(rv$grobs[[46]][[9]]$fill == data$tg$grobs[[46]][[9]]$fill)
  expect_equal(rv$grobs[[42]][[9]]$fill,fc)
  expect_equal(rv$grobs[[42]][[9]]$alpha,1)
})

test_that("rank accepts empty indices", {
  data <- load_data()
  data$sdf <- data.frame(matrix(data=2,nrow=4,ncol=5))
  rv <- recolor_rank(data$tg,data$sdf,"yellow")
  expect_equal(rv,data$tg)
  expect_true(rv$grobs[[42]][[9]]$fill == data$tg$grobs[[42]][[9]]$fill)
  expect_true(rv$grobs[[46]][[9]]$fill == data$tg$grobs[[46]][[9]]$fill)
  expect_equal(rv$grobs[[42]][[9]]$fill,data$tg$grobs[[42]][[9]]$fill)
})


test_that("rank accepts defaults with grob rows", {
  data <- load_data()
  fc <- "red"
  rv <- recolor_rank(data$table,data$sdf,fc)
  expect_true(rv$grobs[[42]][[9]]$fill == data$tg$grobs[[42]][[9]]$fill)
  expect_true(rv$grobs[[46]][[9]]$fill == data$tg$grobs[[46]][[9]]$fill)
  expect_false(rv$grobs[[42]][[9]]$fill == fc)
})

test_that("status accepts defaults missing grob rows", {
  data <- load_data()
  fc <- "yellow"
  expect_error(recolor_status(data$tg,data$sdf,fc))
})

test_that("status accepts empty indices", {
  data <- load_data()
  data$sdf <- data.frame(matrix(data=2,nrow=4,ncol=5))
  colnames(data$sdf) <- c("Index","CAGR","MDD","Calmar","Sortino")
  rv <- recolor_status(data$tg,data$sdf,"yellow")
  expect_false(rv$grobs[[43]][[9]]$fill == data$tg$grobs[[43]][[9]]$fill)
  expect_false(rv$grobs[[43]][[9]]$fill == data$tg$grobs[[43]][[9]]$fill)
})


test_that("status accepts defaults with grob rows", {
  data <- load_data()
  fc <- "red"
  rv <- recolor_status(data$table,data$sdf,fc)
  expect_true(rv$grobs[[42]][[9]]$fill == data$tg$grobs[[42]][[9]]$fill)
  expect_true(rv$grobs[[46]][[9]]$fill == data$tg$grobs[[46]][[9]]$fill)
  expect_false(rv$grobs[[42]][[9]]$fill == fc)
})