Add tests raising test coverage to over 90%

Author: markheckmann

NEWS.Rmd

@@ -14,11 +14,9 @@ output: html_document
     might be a bit confusing for someone who is exploring the app and maybe doesn't have their own
     data yet
 
--   The tests seemed a bit incomplete to me, it doesn't look like all functions are being tested,
-    just the app function and the file format. Is this enough to test the whole code?
-
 ## v0.6.1
 
+-   Additional test raising test coverage to over 90%
 -   Button to load sample data and get started right away without uploading any data
 -   Update icon names using Font Awesome 6
 -   All code comments are in English now

R/01-utils.R

@@ -87,6 +87,7 @@ make_names_vec <- function(x)
   nms <- stringr::str_replace_all(nms, "\\.|-|/|\\(|\\)|&|\\?", "_")  # replace . - \ ? to _ (underscore)
   nms <- stringr::str_replace_all(nms, "[_]+", "_")               # replace multiple underscores by one
   nms <- stringr::str_replace_all(nms, "[_]+$", "")               # remove trailing underscores
+  nms <- stringr::str_replace_all(nms, "ß", "ss")               
   nms <- stringr::str_replace_all(nms, "\u00E4", "ae")            # replace German umlauts by their two letter ASCII version
   nms <- stringr::str_replace_all(nms, "\u00FC", "ue") 
   nms <- stringr::str_replace_all(nms, "\u00F6", "oe") 

R/02-calculate.R

@@ -66,7 +66,7 @@ calculate_similarity <- function(x, min_matches = 6, align_poles = TRUE) #, use_
   if (align_poles) {
     x <- align_positive_poles(x)
   }
-    
+  
   s <- x[, i_ratings]   # remove construct poles
   S <- as.matrix(s)
   pole_left <- x[, i_left]
@@ -98,7 +98,7 @@ calculate_similarity <- function(x, min_matches = 6, align_poles = TRUE) #, use_
   Mi_vec <- as.vector(Mi)
   R[, ] <- ifelse(M_vec > Mi_vec, M_vec, Mi_vec)
   diag(R) <- NA
-
+  
   diag(M) <- NA   # exlude match to self
   diag(Mi) <- NA  # exlude match to self
 
@@ -130,8 +130,8 @@ calculate_similarity <- function(x, min_matches = 6, align_poles = TRUE) #, use_
   names(pole_right) <- labels
   names(valence_left) <- labels
   names(valence_right) <- labels
-
-  list(R = R,    # no of matches (indlucing optional construct reversal, i.e. only high no. of matches relevant
+  
+  list(R = R,    # no of matches (inclucing optional construct reversal, i.e. only high no. of matches relevant
        M = M,    # matrix of matches without optional construct reversal, as described in paper, i.e. a very low and very high number of matches relevant
        MM = MM,  # relatedness 0/1
        D = D,    # direction of relation -1/1
@@ -192,7 +192,7 @@ clique_color_pals <- function(n, name = "Dark2", alpha = .1)
     )
     return(l)
   }
-    
+  
   pals <- RColorBrewer::brewer.pal.info
   n_max <- pals[name, ]$maxcolors  # max umber of avaiabke colors in palette
   cols <- RColorBrewer::brewer.pal(n_max, name)  # build palette
@@ -214,7 +214,7 @@ clique_color_pals <- function(n, name = "Dark2", alpha = .1)
 add_image_border <- function(color = NA) 
 {
   if ( is.null(color) || is.na(color) )
-      return(NULL)
+    return(NULL)
   graphics::box(which = "outer", lty = "solid", col = color)
 }
 
@@ -327,7 +327,7 @@ network_graph_images <- function(x,
 
   nms_keep <- clique_lists %>% unlist %>% unique
   MM2 <- MM[nms_keep, nms_keep]
-
+  
   # colorize edges by direction
   edges <- ends(g, E(g))   # edge from to as rowwise matrix
   edge_directions <- D[edges]
@@ -336,7 +336,7 @@ network_graph_images <- function(x,
   } else {
     edge_labels <- NULL
   }
-    
+  
   if (colorize_direction) {
     edge_colors <- recode(edge_directions, `1` = "darkgreen", `-1` = "red", .default = "grey")
     edge_label_colors <- edge_colors
@@ -345,8 +345,8 @@ network_graph_images <- function(x,
     edge_label_colors <- grey(.2)
   }
   E(g)$color <- edge_colors
-
-
+  
+  
   ##__ all - abbreviated   ----------------------------------------------
 
   vertex.labels <- NULL
@@ -380,7 +380,7 @@ network_graph_images <- function(x,
   })
   add_image_border(image_border_color)
   dev.off()
-
+  
 
   # __ all - full labels ----------------------------------------------
 
@@ -420,19 +420,19 @@ network_graph_images <- function(x,
                         vertex.label.family = "sans",
                         vertex.color = grey(.9),
                         vertex.frame.color = grey(.5))
-
+    
   })
   add_image_border(image_border_color)
   dev.off()
 
-
+  
   ##__ all - separate poles  ----------------------------------------------
 
   label_wrap_width <- 14
   cnames <- paste( prep_label(l$pole_left, label_max_length = label_max_length), "@", 
                    prep_label(l$pole_right, label_max_length = label_max_length))
   names(cnames) <- names(l$constructs)
-
+  
   cns <- V(g)$name
   ii_keep <- match(cns, names(cnames))
   vertex.labels <-
@@ -441,7 +441,7 @@ network_graph_images <- function(x,
   vertex.size <- 22
   vertex.label.cex <- .5
   edge_labels <- NULL
-
+  
   # find vertexes with negative relations only => we need to separate by direction
   D2 <- D[ii_keep, ii_keep]
   vertex_relations <- apply(D2, 2, function(x) {
@@ -457,10 +457,10 @@ network_graph_images <- function(x,
   names(vertex_relations) <- cns
   vertex_font_pole_1 <- 1 # recode(vertex_relations, "neg" = 2, .default = 1)
   vertex_font_pole_2 <- 1 # recode(vertex_relations, "neg" = 1, .default = 2)
-
+  
   vertex.labels1 <- replace_all(vertex.labels, first = TRUE)
   vertex.labels2 <- replace_all(vertex.labels, first = FALSE)
-
+  
   # colorize edges by direction
   edges <- ends(g, E(g))   # edge from to as rowwise matrix
   edge_directions <- D[edges]
@@ -514,7 +514,7 @@ network_graph_images <- function(x,
                         vertex.label.font = vertex_font_pole_1,
                         vertex.color = grey(.9),
                         vertex.frame.color = grey(.5))
-  
+    
     set.seed(seed)
     igraph::plot.igraph(g, add = TRUE,
                         mark.groups = NULL,
@@ -568,7 +568,7 @@ network_graph_images <- function(x,
     cnames[cns] %>%
     str_sub(start = 1, end = label_max_length) %>%
     str_wrap(width = label_wrap_width)
-
+  
   # abbreviated construct labels
   vertex.labels <- NULL
   vertex.size = 30
@@ -622,7 +622,7 @@ network_graph_images <- function(x,
   vertex.label.cex <- .6
 
   img_cliques_only_full_labels <- tempfile(fileext = ".png")
-
+  
   png(img_cliques_only_full_labels, width = 20, height = 20, units = "cm", res = 300)
   with_par(img_par, {
     set.seed(seed)

R/03-excel.R

@@ -120,16 +120,18 @@ check_excel_input_test <- function(x)
 #' 
 check_excel_input <- function(x) 
 {
-  tests <- tryCatch(
-    check_excel_input_test(x), 
-    error = function(e) {
-      data.frame(
-        assert = "Excel file tests can be executed without error.", 
-        passed = FALSE, 
-        error = "When testing your Excel file format for correctness, the program crashed. The reason is unknown. Most likely, there is a problem in the Excel file you uploaded. Please check the Excel grid format for correctness."
-      )  
-    }
-  )
+  suppressWarnings({  # so that NA coercions do not raise unwanted warnings
+    tests <- tryCatch(
+      check_excel_input_test(x), 
+      error = function(e) {
+        data.frame(
+          assert = "Excel file tests can be executed without error.", 
+          passed = FALSE, 
+          error = "When testing your Excel file format for correctness, the program crashed. The reason is unknown. Most likely, there is a problem in the Excel file you uploaded. Please check the Excel grid format for correctness."
+        )  
+      }
+    )
+  })
   tests
 }
 

codecov.yml

@@ -3,4 +3,4 @@ language: R
 sudo: false
 cache: packages
 after_success:
-- Rscript -e 'covr::codecov()'
+- Rscript -e 'covr::codecov()'

tests/testthat/Rplots.pdf

@@ -0,0 +1,74 @@
+
+
+
+test_that("calculation functions work as expected", {
+  
+  # count_matches --------------------
+  
+  ci = matrix(c(1, 1, 0, 0), 2, 2, byrow = TRUE)
+  cj = matrix(c(0, 1, 0, 1), 2, 2, byrow = TRUE)
+  expect_equal(count_matches(ci, ci), 4)
+  expect_equal(count_matches(ci, ci, inverse = TRUE), 0)
+  
+  expect_equal(count_matches(cj, cj), 4)
+  expect_equal(count_matches(cj, cj, inverse = TRUE), 0)
+  
+  expect_equal(count_matches(cj, ci), 2)
+  expect_equal(count_matches(cj, ci, inverse = TRUE), 2)
+  
+  
+  # align_positive_poles --------------------
+  
+  df <- data.frame(
+    left = c("l1","l2","l3"), 
+    e1 = c(0, 1, NA), 
+    e2 = c(0, 1, 1), 
+    right = c("r1","r2","r3"),
+    preferred = c(1, 1, 1))
+  expect_equal(align_positive_poles(df), df)
+
+  df2 <- data.frame(
+    left = c("r1","r2","r3"), 
+    e1 = c(1, 0, NA), 
+    e2 = c(1, 0, 0), 
+    right = c("l1","l2","l3"),
+    preferred = c(0, 0, 0))
+  expect_equal(align_positive_poles(df2), df)
+  
+  
+  # calculate_similarity --------------------  
+  
+  # (these results are the input for the graph algortihm)
+  file <- system.file("extdata", "sylvia.xlsx", package = "OpenRepGrid.ic")
+  x <- read.xlsx(file)
+  x_subset <- x[c(3, 7, 10), ]  # only use three constructs for testing
+  l <- calculate_similarity(x_subset)
+  
+  # => no of matches (inclucing optional construct reversal)
+  R = matrix(c(NA,  5,  6, 
+                5, NA,  6, 
+                6,  6, NA), nrow = 3, byrow=TRUE)
+  expect_equal(l$R, R, check.attributes = FALSE)
+  
+  # => # matrix of matches without optional construct reversal)
+  M = matrix(c(NA, 2,  6,
+               2, NA,  1,
+               6,  1, NA), nrow = 3, byrow=TRUE)
+  expect_equal(l$M, M, check.attributes = FALSE)
+  
+  # relatedness 0/1
+  MM = matrix(c(0,  0,  1,
+                0,  0,  1,
+                1,  1,  0), nrow = 3, byrow=TRUE)
+  expect_equal(l$MM, MM, check.attributes = FALSE)
+  
+  # direction of relation -1/1
+  D = matrix(c(NA, NA,  1,
+               NA, NA, -1,
+               1, -1, NA), nrow = 3, byrow=TRUE)
+  expect_equal(l$D, D, check.attributes = FALSE)
+})
+
+
+
+

tests/testthat/test-calculate.R

@@ -45,8 +45,19 @@ test_that("input file format is checked correctly", {
   tests <- check_excel_input(x)  
   expect_false(all(tests$passed)) 
 
-  x <- read.xlsx(file, sheet = "format-empty")
+  suppressWarnings({  # suppress read.xlsx empty sheet warning
+    x <- read.xlsx(file, sheet = "format-empty")  
+  })
   tests <- check_excel_input(x)  
   expect_false(all(tests$passed)) 
 
 })
+
+
+test_that("Excel output file gets created", {
+  file <- system.file("extdata", "sylvia.xlsx", package = "OpenRepGrid.ic")
+  x <- openxlsx::read.xlsx(file)
+  l <- network_graph_images(x, min_clique_size = 3, show_edges = TRUE, min_matches = 6) 
+  file_tmp <- create_excel_output(file, l)
+  expect_true(file.exists(file_tmp))
+})

tests/testthat/test-file-format.R renamed to tests/testthat/test-excel.R

@@ -0,0 +1,45 @@
+
+
+
+test_that("utility functions work as expected", {
+  
+  # emptify_object
+  expect_equal(emptify_object(mtcars), mtcars[integer(0), ])
+  expect_equal(
+    emptify_object(list(a = 1, b = 1:10)), 
+    list(a = list(), b = list()) 
+  )
+  
+  # dt_default
+  dt = dt_default()
+  expect_true(inherits(dt, "datatables"))
+  
+  # cell_text_split
+  res <- list(c("10","20","30"))
+  expect_equal(cell_text_split("10, 20,30"), res)
+  expect_equal( cell_text_split("; ,  10  ,,,  20;30,," ), res)
+  
+  # make_names_vec
+  a <- c("ä", "ü", "ö", "Ä", "Ü", "Ö", "ß")
+  b <- c("ae", "ue", "oe", "ae", "ue", "oe", "ss")
+  expect_equal(make_names_vec(a), b)
+  
+  a <- c("___", "_a_", "a___b", "a  b  c", " _ _ _A")
+  b <-c("", "_a", "a_b", "a_b_c", "_a")
+  expect_equal(make_names_vec(a), b)
+  
+  # make_names
+  df <- as.data.frame(matrix(NA, 0, 5))
+  names(df) <- a
+  expect_equal(names(make_names(df)), b)
+  
+  # fnum
+  expect_equal(fnum(0.1), "0.10")
+  expect_equal(fnum(11), "11.00")
+  expect_equal(fnum(1, 3), "1.000")
+
+})
+
+
+
+