tests/testthat/helper_expectation.R

In iheatmapr: Interactive, Complex Heatmaps

remove_text <- function(x) {
  # Colors are problematic because a slight change in color will lead to test 
  # failing -- this helper function removes them.
  x$colorscale <- x$colorscale[[1]]
  # Text is problematic because it is sensitive to precision because has numbers in it
  x$text <- length(x$text)

  x
}

replace_text <- function(x) {
  x$data <- lapply(x$data, remove_text)
  x
}


# modified from testhat expect_equal_to_reference
expect_ihm_equal_to_reference <- function(object, file, ..., exclude = NULL, info = NULL) {
  
  lab_exp <- paste0("reference from `", file, "`")
    
  if (!file.exists(file)) {
    # first time always succeeds
    saveRDS(object, file)
    succeed()
  } else {
    reference <- readRDS(file)
    
    objectsub <- replace_text(object$x[c("data","layout")])
    referencesub <- replace_text(reference$x[c("data","layout")])
    
    objectsub <- lapply(objectsub, function(x) setdiff(names(x), exclude))
    referencesub <- lapply(referencesub, function(x) setdiff(names(x), exclude))

    comp <- testthat::compare(objectsub, referencesub, tolerance = 0.1, ...)
    expect(
      comp$equal,
      sprintf("Not equal to %s.\n%s", lab_exp, comp$message),
      info = info
    )
  }
  
  invisible(object)
}



expect_iheatmap <- function(test_plot, ref_name, 
                            orientation = c("horizontal","vertical"), ...){
  test_widget <- test_plot %>% to_widget()
  orientation <- match.arg(orientation)
  if (orientation == "horizontal"){
    expect_is(test_plot,"IheatmapHorizontal")
  } else{
    expect_is(test_plot,"IheatmapVertical")
  }
  expect_is(test_widget,"htmlwidget")
  expect_is(test_widget,"iheatmapr")
  expect_ihm_equal_to_reference(test_widget, paste0("reference/",
                                                    ref_name,".rds"), ...)
}