tests/testthat/testfit.R

# CGGPfit is used in many other tests, so not as many here

context("testfit")

test_that("CGGPfit works with Laplace approx", {
  d <- 3
  SG <- CGGPcreate(d=d, batchsize=30, corr = "m52")
  f <- function(x){x[1]+x[2]^2}
  y <- apply(SG$design, 1, f)
  # Check some fit input options
  expect_error(CGGPfit(SG, Y=as.matrix(y)), NA)
  expect_error(CGGPfit(SG, Ynew=as.matrix(y)), NA)
  expect_error(CGGPfit(SG, Y=c(y, 1.2)))
  # Set theta
  expect_error(CGGPfit(SG, Y=y, set_thetaMAP_to = SG$thetaMAP+.1), NA)
  # Give theta0
  expect_error(CGGPfit(SG, Y=y, theta0 = SG$thetaMAP+.1), NA)
  # Change correlation function
  expect_error(SG <- CGGPfit(SG, Y=y, corr = "cauchysqt"), NA)
  
  # Check that samples from Laplace are near max
  if (F) {
    stripchart(as.data.frame(t(SG$thetaPostSamples)))
    stripchart(as.data.frame(t(SG$thetaMAP)), add=T, col=2, pch=19)
  }
  expect_true(all(abs(rowMeans(SG$thetaPostSamples)- SG$thetaMAP) < apply(SG$thetaPostSamples, 1, sd)))
  
  # Check errors in neglogpost
  expect_error(CGGP_internal_neglogpost(rep(.5,length(SG$thetaMAP)), SG, y, HandlingSuppData="notanoption"))
  expect_error(CGGP_internal_neglogpost(rep(.5,length(SG$thetaMAP)), SG))
  expect_error(CGGP_internal_gneglogpost(rep(.5,length(SG$thetaMAP)), SG, y, HandlingSuppData="notanoption"))
  expect_error(CGGP_internal_gneglogpost(rep(.5,length(SG$thetaMAP)), SG))
  
  
  expect_error(neglogpost <- CGGP_internal_gneglogpost(rep(.5,length(SG$thetaMAP)), SG, y), NA)
  expect_is(neglogpost, "matrix")
  expect_length(neglogpost, length(SG$thetaMAP))
  
  
  expect_error(neglogpost2 <- CGGP_internal_gneglogpost(rep(.5,length(SG$thetaMAP)), SG, y, return_lik = T), NA)
  expect_is(neglogpost2, "list")
  expect_length(neglogpost2[[1]], 1)
  expect_length(neglogpost2[[2]], length(SG$thetaMAP))
  
  # Check neglogpost grad matches gneglogpost
  theta <- SG$thetaMAP / 2 # Don't want values near -1 or +1
  epsval <- 1e-4
  thetagrad <- CGGP_internal_gneglogpost(theta, SG, SG$y)
  for (i in 1:length(SG$thetaMAP)) {
    eps <- rep(0, length(SG$thetaMAP))
    eps[i] = eps[i] + epsval
    numgrad <- (CGGP_internal_neglogpost(theta + eps, SG, SG$y) - 
                  CGGP_internal_neglogpost(theta - eps, SG, SG$y)) / (2*epsval)
    expect_equal(thetagrad[i], numgrad, tol=1e-4)
  }
  
  if (F) {
    # expect_equal(
    #   c(CGGP_internal_gneglogpost(theta, SG, SG$y)),
    #   numDeriv::grad(CGGP_internal_neglogpost, theta, CGGP=SG, y=SG$y)
    # )
  }
  
  # Works with supplementary data
  nsup <- 30
  xsup <- matrix(runif(nsup*3), nsup, 3)
  ysup <- apply(xsup, 1, f)
  SG <- CGGPappend(SG, 20)
  ynew <- apply(SG$design_unevaluated, 1, f)
  expect_error(SG <- CGGPfit(SG, Ynew=ynew, Xs=xsup, Ys=ysup), NA)
  
  # Check neglogpost grad matches gneglogpost for all HandlingSuppData options
  theta <- SG$thetaMAP / 2 # Don't want values near -1 or +1
  epsval <- 1e-4
  for (handling in c("Correct", "Only", "Ignore")) {
    thetagrad <- CGGP_internal_gneglogpost(theta, SG, SG$y, Xs=xsup, ys=SG$ys, HandlingSuppData = handling)
    numgrad <- rep(0, length(SG$thetaMAP))
    for (i in 1:length(SG$thetaMAP)) {
      eps <- rep(0, length(SG$thetaMAP))
      eps[i] = eps[i] + epsval
      # numgrad <- (CGGP_internal_neglogpost(theta + eps, SG, SG$y, Xs=xsup, ys=SG$ys, HandlingSuppData = handling) - 
      #               CGGP_internal_neglogpost(theta - eps, SG, SG$y, Xs=xsup, ys=SG$ys, HandlingSuppData = handling)) / (2*epsval)
      numgrad[i] <- (-CGGP_internal_neglogpost(theta + 2*eps, SG, SG$y, Xs=xsup, ys=SG$ys, HandlingSuppData = handling) + 
                       8*CGGP_internal_neglogpost(theta + eps, SG, SG$y, Xs=xsup, ys=SG$ys, HandlingSuppData = handling) - 
                       8*CGGP_internal_neglogpost(theta - eps, SG, SG$y, Xs=xsup, ys=SG$ys, HandlingSuppData = handling) + 
                       CGGP_internal_neglogpost(theta - 2*eps, SG, SG$y, Xs=xsup, ys=SG$ys, HandlingSuppData = handling)) / (12*epsval)
      # 
      # print(numgrad)
    }
    expect_equal(c(thetagrad), numgrad, tol=1e-2, info = handling)
  }
  if (F) {
    # numDeriv::grad(function(th) {CGGP_internal_neglogpost(th, SG, SG$y, Xs=xsup, ys=SG$ys, HandlingSuppData = handling)}, theta)
  }
})

test_that("CGGPfit works with Ynew - scalar output", {
  
  
  SG <- CGGPcreate(d=3, batchsize=20)
  f <- function(x){x[1]+x[2]^2}
  y <- apply(SG$design, 1, f)
  # Can't give in Y and Ynew
  expect_error(SG <- CGGPfit(SG, Y=y, Ynew=y))
  # Works with just Ynew
  SG <- CGGPfit(SG, Ynew=y)
  expect_true(all(!is.na(SG$thetaPostSamples)))
  
  # After append, only give in Ynew
  SG <- CGGPappend(SG, 50)
  ynew <- apply(SG$design_unevaluated, 1, f)
  # Again error if give in Y and Ynew
  expect_error(CGGPfit(SG, Y=c(y, ynew), Ynew=ynew))
  # Get error when Ynew is wrong size
  expect_error(CGGPfit(SG, Ynew=ynew[1:(length(ynew)-1)]))
  # Works fine
  expect_is(SG <- CGGPfit(SG, Ynew = ynew), "CGGP")
})

test_that("CGGPfit works with Ynew - vector output", {
  
  
  SG <- CGGPcreate(d=3, batchsize=20)
  f1 <- function(x){x[1]+x[2]^2}
  f2 <- function(x){x[2]^1.3+sin(2*pi*x[3])}
  y1 <- apply(SG$design, 1, f1)
  y2 <- apply(SG$design, 1, f2)
  y <- cbind(y1, y2)
  # Can't give in Y and Ynew
  expect_error(SG <- CGGPfit(SG, Y=y, Ynew=y))
  # Other errors when giving ynew and wrong number of rows
  expect_error(CGGPfit(SG, Ynew=y[1:5,]))
  expect_error(CGGPfit(SG, Ynew=y1[1:5]))
  # Errors for bad theta0
  expect_error(CGGPfit(SG, Y=y, theta0 = matrix(0, ncol=3, nrow=SG$numpara), separateoutputparameterdimensions = T))
  expect_error(CGGPfit(SG, Y=y, theta0 = matrix(0, ncol=1, nrow=SG$numpara), separateoutputparameterdimensions = T))
  
  # Works with just Ynew
  SG <- CGGPfit(SG, Ynew=y)
  
  # After append, only give in Ynew
  SG <- CGGPappend(SG, 50)
  ynew1 <- apply(SG$design_unevaluated, 1, f1)
  ynew2 <- apply(SG$design_unevaluated, 1, f2)
  ynew <- cbind(ynew1, ynew2)
  # Again error if give in Y and Ynew
  expect_error(CGGPfit(SG, Y=rbind(y, ynew), Ynew=ynew))
  # Get error when Ynew is wrong size
  expect_error(CGGPfit(SG, Ynew=ynew[1:(nrow(ynew)-1),]))
  # Get error if you give in vector
  expect_error(CGGPfit(SG, Ynew=ynew1))
  # Works fine
  expect_is(SG <- CGGPfit(SG, Ynew = ynew), "CGGP")
  
  
})

# test_that("postvarmatcalc", {
#   # These don't work unless x1 and x2 have same length.
#   # Maybe only makes sense when x1 == x2?
#   x1 <- runif(5)
#   x2 <- x1
#   o1 <- CGGP_internal_postvarmatcalc(x1, x2,
#                                xo=c(.11), theta=c(.1,.2,.3),
#                                CorrMat=CGGP_internal_CorrMatCauchySQT,
#                                returndPVMC=F, returndiagonly=F)
#   o2 <- CGGP_internal_postvarmatcalc(x1, x2,
#                                      xo=c(.11), theta=c(.1,.2,.3),
#                                      CorrMat=CGGP_internal_CorrMatCauchySQT,
#                                      returndPVMC=F, returndiagonly=T)
#   o3 <- CGGP_internal_postvarmatcalc(x1, x2,
#                                      xo=c(.11), theta=c(.1,.2,.3),
#                                      CorrMat=CGGP_internal_CorrMatCauchySQT,
#                                      returndPVMC=T, returndiagonly=F)
#   o4 <- CGGP_internal_postvarmatcalc(x1, x2,
#                                      xo=c(.11), theta=c(.1,.2,.3),
#                                      CorrMat=CGGP_internal_CorrMatCauchySQT,
#                                      returndPVMC=T, returndiagonly=T)
#   expect_equal(o1, o3$Sigma_mat)
#   expect_equal(diag(o1), o2)
#   expect_equal(o4$Sigma_mat, diag(o3$Sigma_mat))
#   expect_equal(o4$dSigma_mat[,1], diag(o3$dSigma_mat[,1:5]))
#   expect_equal(o4$dSigma_mat[,2], diag(o3$dSigma_mat[,6:10]))
#   expect_equal(o4$dSigma_mat[,3], diag(o3$dSigma_mat[,11:15]))
# })

# test_that("", {
#   
# })

Try the CGGP package in your browser

Any scripts or data that you put into this service are public.

CGGP documentation built on May 8, 2021, 5:06 p.m.