tests/testthat/test_other.R

In amp.dm: Data Management Tools for Pharmacometrics

#------------------------
# Test plot_vars function
test_that("plot_vars, Create different kind of plots for variables)", {
  Theoph$AMT  <- ifelse(duplicated(Theoph$Subject),NA,Theoph$Dose)
  Theoph$ADDL <- ifelse(duplicated(Theoph$Subject),NA,c(1:4))
  Theoph$ADDL <- as.factor(Theoph$ADDL)

  pl <- plot_vars(Theoph)
  expect_equal(class(pl),"list")
  pl <- plot_vars(Theoph,ppp=4)
  expect_equal(length(as.list(pl)),2)

  expect_equal(names(pl$`1`[[1]]$data), c("Var1","count"))
  expect_equal(names(pl$`1`[[2]]$data), c("plvar"))
  expect_equal(nrow(pl$`1`[[2]]$data), nrow(Theoph))
})

#----------------------------
# Test flag_outliers function
test_that("flag_outliers will indicate outliers", {
  dat <- data.frame(a = 1:10, b = c(1:9,50))
  expect_equal(unique(flag_outliers(dat$a)), 0)
  expect_equal(tail(flag_outliers(dat$b),1), 1)
})

#----------------------------
# Test impute_covar function
test_that("impute_covar imputes values", {
  data1      <- data.frame(num1 = 1:10, cat1 = c(letters[1:5],rep("f",5)),id=c(1:9,9))
  data1$fct1 <- factor(data1$cat1)
  data1$num1[5] <- NA
  data1$cat1[4] <- NA
  data1$fct1[3] <- NA
  
  expect_equal(median(c(1:4,6:10)), impute_covar(data1$num1,type="median")[5])
  expect_message(impute_covar(data1$num1,type="median", verbose = TRUE))
  
  expect_equal(sd(c(1:4,6:10)), impute_covar(data1$num1,type="sd")[5])
  expect_equal(mean(c(1:4,6:9)), impute_covar(data1$num1,uniques = data1$id, type="mean")[5])
  
  expect_message(impute_covar(data1$num1,type="largest", verbose = TRUE),"Multiple")
  
  expect_equal("f", impute_covar(data1$cat1,type="largest")[4])
  expect_s3_class(impute_covar(data1$fct1,type="largest"), "factor")
})

#-----------------------
# Test num_lump function
test_that("num_lump performs correct lumping", {
  
  dfrm <- data.frame(id = 1:30, cat = c(rep(1,8),rep(2,13), rep(3,4),rep(4,5)))
  
  ret  <- num_lump(x=dfrm$cat, lumpcat=99, prop=0.15)
  expect_true(length(ret[ret==99])==4)
  ret  <- num_lump(x=dfrm$cat, lumpcat=99, prop=0.17)
  expect_true(length(ret[ret==99])==9)
  ret  <- num_lump(x=dfrm$cat, lumpcat=99, min=1) 
  expect_identical(ret,dfrm$cat)
  expect_message(num_lump(x=dfrm$cat, lumpcat=99, min=5),"still.*categories.*<.*min")
  ret  <- num_lump(x=dfrm$cat, lumpcat=99, min=6)
  expect_true(length(ret[ret==99])==9)
  ret  <- num_lump(x=dfrm$cat, lumpcat=99, prop=0.2, min=1) # either prop or min is used for condition!
  expect_true(length(ret[ret==99])==9)
  
  ret  <- num_lump(x=dfrm$cat, lumpcat=2, min=5)
  expect_true(length(ret[ret==2])==17)
  ret  <- num_lump(x=dfrm$cat, lumpcat="largest", min=5)
  expect_true(length(ret[ret==2])==17)
  ret  <- num_lump(x=dfrm$cat, lumpcat=c('3'=1,'4'=2), min=6)
  expect_true(length(ret[ret==1])==12)
  expect_true(length(ret[ret==2])==18)
  expect_message(num_lump(x=dfrm$cat, lumpcat=c('3'=1,'4'=2, '1'=2), min=6),"Circular.*assignment")
})