tests/testthat/test_tabulate.R

In amp.dm: Data Management Tools for Pharmacometrics

#--------------------------
# Test general_tbl function
test_that("general_tbl correctly creates generic latex table, file or passes data frame",{
  tbl <- capture.output(general_tbl(Theoph))
  
  expect_true(any(grepl("longtable",tbl)))
  expect_true(any(grepl("toprule",tbl)))
  expect_true(any(grepl("midrule",tbl)))
  expect_true(any(grepl("endhead",tbl)))
  
  th2 <- general_tbl(Theoph, ret="dfrm")
  expect_equal(Theoph,th2)
  
  tmpf1 <- tempfile(fileext = ".tex")
  general_tbl(Theoph, outnm=tmpf1, ret="file", show=FALSE)
  ret2  <- readLines(tmpf1)
  expect_true(any(grepl("begin\\{document\\}",ret2)))
  expect_true(any(grepl("11 & 65.0 & 4.92 &  0.00 &  0.00 \\\\\\\\",ret2)))
})

#----------------------
# Test define_tbl function
test_that("define_tbl correctly tabulates attributes",{
  expect_error(define_tbl(),"Make sure attr is provided")
  attrl <- attr_xls(system.file("example","Attr.Template.xlsx",package = "amp.dm"))
  
  ret <- define_tbl(attrl)
  expect_equal(ret$Description[ret$Data.Item=="ID"],"Unique subject identifier")
  expect_equal(ret$Unit[ret$Data.Item=="AMT"],"mg")
  expect_equal(trimws(ret$Remark[ret$Data.Item=="SEX"]),"0 = Male, 1 = Female")
  
  tbl  <- capture.output(define_tbl(attrl,ret="tbl"))
  expect_true(any(grepl("begin\\{longtable\\}",tbl)))
  
  tmpf1 <- tempfile(fileext = ".tex")
  define_tbl(attrl, outnm=tmpf1, ret="file", show=FALSE)
  ret2  <- readLines(tmpf1)
  expect_true(any(grepl("begin\\{document\\}",ret2)))
  expect_match(ret2[grep("^TIME ",ret2)],"TIME & Time & h & - \\\\\\\\")
  
  define_tbl(attrl, outnm=tmpf1, ret="file", show=FALSE, 
             template = system.file("listing.tex",package = "R3port"))
  ret3  <- readLines(tmpf1)
  expect_true(any(grepl("ttdefault",ret3)))
  
  
  srce(BMI,c(wt.WEIGHT,ht.HEIGHT),'d')
  ret  <- define_tbl(attrl)
  expect_match(ret$Remark[ret$Data.Item=="BMI"],"source.*wt.WEIGHT.*ht.HEIGHT.*derived")
  ret2 <- define_tbl(attrl, src=get_log()$srce_nfo)
  expect_equal(ret,ret2)
})


#----------------------
# Test contents_df function
test_that("contents_df correctly tabulates records",{
  Theoph2 <- subset(Theoph,Subject==1)
  assign("Theoph",Theoph,envir=.GlobalEnv)   # Make sure data frames are in global environment
  assign("Theoph2",Theoph2,envir=.GlobalEnv) # Make sure data frames are in global environment
  
  expect_error(contents_df(c('dummy')),"Not all data frames could be found")
  res     <- contents_df(c('Theoph','Theoph2'),subject='Subject',ret='dfrm')
  
  expect_equal(res$records[1],nrow(Theoph))
  expect_equal(res$records[2],nrow(Theoph2))
  expect_equal(res$subjects[2],length(unique(Theoph2$Subject)))

  res     <- contents_df(c('Theoph','Theoph2'),ret='dfrm')
  expect_true(!"subject"%in%names(res))
})

#----------------------
# Test counts_df function
test_that("counts_df correctly tabulates counts and frequencies",{
  
  data("Theoph")
  Theoph$trt <- ifelse(as.numeric(Theoph$Subject)<6,1,2)
  Theoph$sex <- ifelse(as.numeric(Theoph$Subject)<4,1,0)
  
  res   <- counts_df(data=Theoph, by=c("trt","sex"),id="Subject", ret="dfrm")
  resm1 <- table(Theoph$trt,Theoph$sex)
  resm2 <- prop.table(resm1)
  expect_equal(dim(res),c(4,6))
  expect_equal(res$Nobs[nrow(res)],nrow(Theoph))
  expect_equal(res$Nobs[res$trt=="1" & res$sex=="0"],resm1[1,1])
  expect_equal(res$PERCobs[res$trt=="1" & res$sex=="0"],resm2[1,1]*100)
  
  res <- counts_df(data=Theoph, by=c("trt","sex"),id="Subject", style=2, ret="dfrm")
  expect_equal(dim(res),c(4,4))
  
  res <- capture.output(counts_df(data=Theoph, by=c("trt","sex"),id="Subject", style=2, ret="tbl"))
  expect_true(any(grepl("begin\\{longtable\\}",res)))
})

#----------------------------
# Test session_table function
test_that("session_table correctly gets the session information",{
  ret <- session_tbl("dfrm")
  pks <- sapply(utils::sessionInfo()$otherPkgs,function(x) paste0(x$Package," (",x$Version,")"))
  
  expect_equal(as.character(ret$value[ret$parameter=="R version"]),utils::sessionInfo()$R.version$version.string)
  expect_equal(as.character(ret$value[ret$parameter=="System"]),utils::sessionInfo()$platform)
  expect_equal(as.character(ret$value[ret$parameter=="OS"]),utils::sessionInfo()$running)
  expect_equal(as.character(ret$value[ret$parameter=="Base packages"]),paste(utils::sessionInfo()$basePkgs,collapse=", "))
  expect_equal(as.character(ret$value[ret$parameter=="Other packages"]),paste(pks,collapse=", "))
  expect_equal(as.character(ret$value[ret$parameter=="Logged in User"]),as.character(Sys.info()["user"]))
  ret2 <- capture.output(session_tbl("tbl"))
  expect_match(paste(ret2,collapse=" "),regexp=as.character(Sys.info()["user"]))
})

#-----------------------
# Test stats_df function
test_that("stats_df provides correct stats",{
  Theoph$conc[nrow(Theoph)] <- NA
  Theoph$trt                <- "NA"
  Theoph$trt[nrow(Theoph)]  <- "B"
  Theoph$sex <- ifelse(as.numeric(Theoph$Subject)<4,1,NA)
  
  ret <- stats_df(Theoph,ret="dfrm")
  
  expect_equal(as.numeric(ret$Min[ret$Variable=="Subject"]),min(as.numeric(Theoph$Subject)))
  expect_equal(as.numeric(ret$Max[ret$Variable=="Wt"]),max(as.numeric(Theoph$Wt)))
  expect_equal(as.character(ret$Categories[ret$Variable=="Dose"]),paste(unique(Theoph$Dose),collapse=" / "))
  expect_equal(as.character(ret$Categories[ret$Variable=="Time"]),paste0("More than 10 cats (",length(unique(Theoph$Time)),")"))
  expect_equal(sub(" .*","",as.character(ret$Nna[ret$Variable=="conc"])), paste(sum(is.na(Theoph$conc))))
  ret2 <- capture.output(stats_df(Theoph,ret="tbl"))
  expect_match(paste(ret2,collapse=" "),regexp="begin\\{longtable\\}")
})

#---------------------------
# Test check_nmdata function
test_that("check_nmdata correctly checks a NONMEM dataset", {
  nm   <- data.frame(ID=1,TIME=0:5,DV=c(NA,rnorm(5)),MDV=c(1,1,0,0,0,0))
  tmpf <- tempfile(fileext = ".csv")
  utils::write.csv(nm,tmpf,row.names = FALSE, na=".",quote=FALSE)
  res  <- check_nmdata(tmpf,ret="dfrm")
  tbl  <- capture.output(check_nmdata(tmpf,ret="tbl"))

  expect_true(all(res$result=="Yes"))
  expect_true(any(grepl("begin\\{longtable\\}",tbl)))

  utils::write.csv(nm[1,1,drop=FALSE],tmpf,row.names = FALSE, na=".",quote=FALSE)
  res    <- check_nmdata(tmpf,ret="dfrm")
  varin1 <- c("More than 1 line of data","More than 1 data item","Variables ID, TIME and DV present in data")
  varin2 <- "Data ordered on ID and TIME"
  expect_equal(unique(res$result[res$Check%in%varin1]),"No")
  expect_equal(unique(res$result[res$Check%in%varin2]),"-")

  res  <- check_nmdata(tmpf,ret="dfrm",type=2)
  expect_equal(nrow(res),10)
  res2 <- check_nmdata(nm[1,1,drop=FALSE],ret="dfrm",type=2)
  expect_equal(res,res2)
  
  res3 <- check_nmdata("tmpf",ret="dfrm",type=2)
  expect_equal(res3$result[1],"No")
  res4 <- check_nmdata(nm,ret="dfrm",type=1)
  expect_equal(res4$result[1],"-")
  nm$EVID <- ifelse(nm$TIME==0,1,0)
  nm$AMT  <- ifelse(nm$TIME==0,10,0)
  res5 <- check_nmdata(nm,ret="dfrm",type=2)
  expect_equal(nrow(res5),nrow(res))
})