tests/testthat/test-set.dendrogram.R

In dendextend: Extending 'dendrogram' Functionality in R

# library(testthat)

# we don't need the warning now... https://stackoverflow.com/questions/16194212/how-to-supress-warnings-globally-in-an-r-script
old_warn_opt <- options()$warn
options(warn = -1)


context("Checknig set.dendrogram")


test_that("labels options works", {
  suppressWarnings(RNGversion("3.5.0"))
  #    library(magrittr)
  set.seed(23235)
  ss <- sample(1:150, 10)
  dend <- iris[ss, -5] %>%
    dist() %>%
    hclust() %>%
    as.dendrogram()

  expect_equal(
    dend %>% set("labels", 1:10) %>% labels(),
    1:10
  )

  expect_equal(
    dend %>% set("labels", as.character(1:10)) %>% labels(),
    as.character(1:10)
  )

  dendextend_options("warn", TRUE)
  expect_warning(set(dend, "labels_color"))
  dendextend_options("warn", FALSE)


  # before doing anything, we have NULL labels colors:
  expect_null(dend %>% labels_colors())

  # piping is the same as not (just MUCH more readable)
  expect_equal(
    set(dend, "labels_color"),
    dend %>% set("labels_color")
  )

  # here we update the colors, and then try to see them:
  expect_equal(
    labels_colors(set(dend, "labels_color")),
    dend %>% set("labels_color") %>% labels_colors()
  )


  new_col_labels <- structure(c(
    "#CC476B", "#B76100", "#917600", "#518600", "#009232",
    "#009681", "#008FB7", "#1678D5", "#A352D1", "#CB39AA"
  ), .Names = c(
    "123",
    "145", "126", "109", "23", "29", "94", "59", "67", "97"
  ))
  #    dend %>% set("labels_color") %>% plot
  expect_equal(
    dend %>% set("labels_color") %>% labels_colors(),
    new_col_labels
  )
  #    dend %>% set("labels_color", new_col_labels) %>% plot


  # we get the correct attribue set...
  tmp <- dend %>%
    set("labels_col", 2) %>%
    set("labels_cex", 1.2)
  tmp <- tmp[[1]][[1]]
  #   unclass(tmp)
  expect_equal(
    attr(tmp, "nodePar")$lab.col,
    2
  )
  expect_equal(
    attr(tmp, "nodePar")$lab.cex,
    1.2
  )
  
  # if 'what' parameter not specified in set() then it should create a warning and return the same dendrogram
  dendextend_options("warn", TRUE)
  expect_warning(
     result <- dend %>% set()
  )
  dendextend_options("warn", FALSE)
  expect_identical(
     result,
     dend
  )
  
  # if order_value parameter used
  tmp <- dend %>%
     set("labels_col", 2, order_value = T)
  tmp <- tmp[[2]][[1]][[1]]
  expect_equal(
     attr(tmp, "nodePar")$lab.col,
     2
  )

})


test_that("leaves options works", {
  #    library(magrittr)
  suppressWarnings(RNGversion("3.5.0"))
  set.seed(23235)
  ss <- sample(1:150, 10)
  dend <- iris[ss, -5] %>%
    dist() %>%
    hclust() %>%
    as.dendrogram()

  tmp <- dend
  tmp <- tmp %>%
    set("leaves_pch", 2) %>%
    set("leaves_cex", 1.5) %>%
    set("leaves_col", c(3:1)) %>%
    set("hang")
  tmp <- tmp[[1]][[1]]
  #    unclass(tmp)
  expect_equal(
    attr(tmp, "nodePar")[["pch"]],
    2
  )
  expect_equal(
    attr(tmp, "nodePar")[["cex"]],
    1.5
  )
  expect_equal(
    attr(tmp, "nodePar")[["col"]],
    3
  )
  expect_equal(
    attr(tmp, "height"),
    0.9030533
  )

  #    tmp  %>% plot
})


test_that("branches options works", {
  #    library(magrittr)
  suppressWarnings(RNGversion("3.5.0"))
  set.seed(23235)
  ss <- sample(1:150, 10)
  dend <- iris[ss, -5] %>%
    dist() %>%
    hclust() %>%
    as.dendrogram()

  tmp <- dend %>%
    set("branches_k_col", c(3, 1, 2), k = 3)
  #    tmp %>% plot

  expect_equal(
    unname(unlist(get_nodes_attr(tmp, "edgePar"))[1:3]),
    c(NA, 3, 3)
  )

  #    as.data.frame(get_nodes_attr(tmp, "edgePar"))
  #    unclass(tmp)

  tmp <- dend
  tmp <- tmp %>%
    set("branches_col", c(1, 2, 1, 2, Inf)) %>%
    set("branches_lwd", c(2, 1, 2)) %>%
    set("branches_lty", c(1, 2, 1)) # %>% plot

  # checking we got a nice list:
  # dput(attr(tmp,"edgePar"))
  should_be <- structure(list(col = 1, lwd = 2, lty = 1), .Names = c(
    "col",
    "lwd", "lty"
  ))
  expect_equal(attr(tmp, "edgePar"), should_be)
})



test_that("clearing options works", {
  #    library(magrittr)
  suppressWarnings(RNGversion("3.5.0"))
  set.seed(23235)
  ss <- sample(1:150, 10)
  # Getting the dend object onces
  dend <- iris[ss, -5] %>%
    dist() %>%
    hclust() %>%
    as.dendrogram()

  tmp <- dend
  tmp <- tmp %>%
    set("leaves_pch", c(19, 19, Inf)) %>%
    set("labels_color", c(19, 19, Inf)) # %>%
  # 	   set("clear_leaves") %>% plot
  expect_identical(dend, set(tmp, "clear_leaves"))

  tmp <- dend
  tmp <- tmp %>%
    set("branches_col", c(1, 2, 1, 2, Inf)) %>%
    set("branches_lwd", c(2, 1, 2)) %>%
    set("branches_lty", c(1, 2, 1)) # %>% plot
  # We can remove all the branch attributes
  expect_false(identical(dend, tmp))
  expect_identical(dend, set(tmp, "clear_branches"))
})


test_that("set.dendlist works", {
   suppressWarnings(RNGversion("3.5.0"))
   set.seed(23235)
   
   ss <- sample(1:150, 10)
   dend1 <- iris[ss, -5] %>%
      dist() %>%
      hclust() %>%
      as.dendrogram()
   dend2 <- shuffle(dend1)
   dend12 <- dendlist(dend1, dend2)
   
   # without 'what' parameter specified, nothing is changed
   result <- set.dendlist(dend12)
   expect_identical(
      dend12,
      result
   )
})


test_that("set.data.table works", {
   
   # expect warning as dendextend::set.data.table overwrites data.table::set
   dt <- data.table::data.table(id = 1:5, value = c(10, 20, 30, 40, 50))
   expect_warning(
      set.data.table(dt, j = 1L, value = 1)
   )
   
})

options(warn = old_warn_opt)