context("fapply Tests") options("logr.output" = FALSE) test_that("fapply1: fapply() function works as expected with vectors.", { t <- c("A", "B", "B", "UNK", "A") n <- c(1L, 2L, 3L, 10L, 11838L) f <- c(1.2, 2, 3.377, 10.388, 1138.3) d <- c("2020-05-02", "2020-08", "2020-10-17") d <- as.Date(d) l <- c(A = "Var A", B = "Var B", UNK = "Unknown") expect_equal(fapply(t, width = 5), c("A ","B ", "B ","UNK ","A ")) expect_equal(fapply(n, width = 5), c(" 1"," 2"," 3"," 10","11838")) expect_equal(fapply(f, width = 9), c(" 1.200", " 2.000", " 3.377"," 10.388"," 1138.300")) expect_equal(fapply(t, l), c("Var A", "Var B", "Var B", "Unknown", "Var A")) fapply(d, width = 15) format(f, width = 9) fapply(t, justify = "right") fapply(n, justify = "center") fapply(f, justify = "left") fapply(d, justify = "center") fapply(t, width = 10, justify = "right") fapply(n, width = 10, justify = "center") fapply(f, width = 10, justify = "left") fapply(d, width = 15, justify = "left") fapply(t, format = "My Stuff: %s") fapply(n, format = "%+6d") fapply(f, format = "%6.1f%%") fapply(d, format = "%d%b%Y") fapply(t, width = 10, justify = "right", format = "My Stuff: %s") fapply(n, width = 10, justify = "center", format = "%+d") fapply(f, width = 10, justify = "left", format = "%.1f%%") fapply(d, width = 15, justify = "right", format = "%d%b%Y") }) test_that("fapply2: fapply() function works as expected with vector input formats.", { d <- c("A", "B", "B", "UNK", "A") f <- c("A"= "Abba", "B" = "Babba") # lookup(d, f) # expect_equal(fapply(d, f), c("Abba", "Babba", "Babba", "UNK", "Abba")) expect_equal(lkup(d, f), c("Abba", "Babba", "Babba", "UNK", "Abba")) }) test_that("fapply3: fapply() function works as expected with flist", { ## Formatting List - Row Type ## v1 <- list(2841.258, "H", as.Date("2020-06-19"), 1382.8865, "L", as.Date("2020-04-24")) # Create formatting list lst <- flist(type = "row", type1 = function(x) format(x, digits = 2, nsmall = 1, big.mark=","), type2 = value(condition(x == "H", "High"), condition(x == "L", "Low"), condition(TRUE, "NA")), type3 = "%d%b%Y") # Apply formatting list to vector fmtd <- fapply(v1, lst) res <- c("2,841.3", "High", "19Jun2020", "1,382.9", "Low", "24Apr2020") expect_equal(fmtd, res) ## Formatting List - Row Type with lookup ## v2 <- list(2841.258, "H", as.Date("2020-06-19"), "L", as.Date("2020-04-24"), 1382.8865) v3 <- c("type1", "type2", "type3", "type2", "type3", "type1") # Create formatting list lst <- flist(type = "row", lookup = v3, type1 = function(x) format(x, digits = 2, nsmall = 1, big.mark=","), type2 = value(condition(x == "H", "High"), condition(x == "L", "Low"), condition(TRUE, "NA")), type3 = "%d%b%Y") # Apply formatting list to vector fmtd <- fapply(v2, lst) res <- c("2,841.3", "High", "19Jun2020", "Low", "24Apr2020", "1,382.9") expect_equal(fmtd, res) ## Formatting List - Column Type ## v3 <- as.Date(c("2020-08-23", "2020-09-15", "2020-10-05")) # Create formatting list lst <- flist("%B", "Month: %s", type="column") # Apply formatting list to vector fmtd2 <- fapply(v3, lst) res <- c("Month: August", "Month: September", "Month: October") expect_equal(fmtd2, res) }) test_that("fapply4: fapply() with vector formats work as expected.", { catc = c("A", "B", "C", "B") catn = c(1, 2, 3, 2) v1 <- c(A= "Alpha", B = "Bravo", C = "Charlie") res1 <- fapply(catc, v1) expect_equal(class(res1), "character") v2 <- c(A= 1, B = 2, C = 3) res2 <- fapply(catc, v2) expect_equal(class(res2), "numeric") v3 <- c(A= 1L, B = 2L, C = 3L) res3 <- fapply(catc, v3) expect_equal(class(res3), "integer") }) test_that("fapply5: fapply() returns a character vector instead of a factor", { # Create vector a <- c(1.3243, 5.9783, 2.3848) # Assign format attributes a <- fattr(a, format = "%.1f", width = 10, justify = "center") # Apply format attributes f1 <- fapply(a) expect_equal(class(f1), "character") }) test_that("fapply6: fapply() parameter checks work as expected", { v <- c(1, 2, 3) expect_error(fapply(v, format = Sys.Date())) expect_error(fapply(v, width = "5")) expect_error(fapply(v, width = -1)) expect_error(fapply(v, justify = "fork")) expect_error(fapply(v, v)) }) test_that("fapply7: fapply2() works as expected.", { # Create vector a <- c(1.3243, 5.9783, 2.3848) b <- c(4.284, 3.383, 1.848) # Check basic fapply2 f1 <- fapply2(a, b, "%1.1f", "(%1.2f)", sep = " ") expect_equal(f1[1], "1.3 (4.28)") # Check width f2 <- fapply2(a, b, "%1.1f", "(%1.2f)", sep = " ", width = 13) expect_equal(f2[1], "1.3 (4.28) ") # Check width and justify f3 <- fapply2(a, b, "%1.1f", "(%1.2f)", sep = " ", width = 13, justify = "right") expect_equal(f3[1], " 1.3 (4.28)") # Check if formatting attributes work fattr(a) <- list(format = "%1.1f") fattr(b) <- list(format = "(%1.2f)") f4 <- fapply2(a, b, sep = " ") expect_equal(f4[1], "1.3 (4.28)") }) test_that("fapply8: fapply() works with numeric formats in label.", { v1 <- c(1.3948234, 2.393745, 3.33775, .000001, NA) fmt <- value(condition(x < .0001, "<.0001"), condition(TRUE, "%.4f")) res <- fapply(v1, fmt) res expect_equal(res, c("1.3948", "2.3937", "3.3378", "<.0001", NA)) }) test_that("fapply9: fapply() works with date formats in label.", { v1 <- c(as.Date("2000-01-01"), as.Date("1999-01-01"), as.Date("2000-02-23"), NA) fmt <- value(condition(as.integer(format(x, "%Y")) < 2000, "Too old"), condition(TRUE, "%B %m %Y")) res <- fapply(v1, fmt) res expect_equal(res, c("January 01 2000", "Too old", "February 02 2000", NA)) }) test_that("fapply10: fapply() works as expected with single item vector lookup.", { t <- c("A", "B", "B", NA, "A") fmt <- c("A" = "Group A") re <- c("Group A","B", "B", NA,"Group A") res <- fapply(t, fmt) expect_equal(res, re) })