tests/testthat/test-predict.optim_fit.R

In OptimModel: Perform Nonlinear Regression Using 'optim' as the Optimization Engine

test_that("predict.optim_fit", {


  ## With an without gradient
  f1 = f2 = function(theta, x){ theta[1] + (theta[2]-theta[1])/(1 + (x/theta[3])^theta[4]) }
  theta = c(-50, 100, 0.5, 2)
  sigma = 4.1
  phi = 0.1  ## Variance parameter
  
  V = rbind( c(3.1, 0.4, -0.7, -0.1),
             c(0.4, 2.3, 0.0, -1.7),
             c(-0.7, 0, 0.9, -0.2),
             c(-0.1, -1.7, -0.2, 2.3)
             )   
  
  x = c(0, 4, 8, 10)  
  
  f.grad = f2djac(f1, theta, x=x)
  attr(f2, "gradient") = function(theta, x){
                cbind(1 - 1/(1 + (x/theta[3])^theta[4]),
                      1/(1 + (x/theta[3])^theta[4]),
                      (theta[2]-theta[1])*theta[4]*x^theta[4]/(theta[3]^(theta[4]+1) *(1 + (x/theta[3])^theta[4])^2),
                      ifelse(x==0, 0, -(theta[2]-theta[1])*(x/theta[3])^theta[4]*log(x/theta[3])/(1 + (x/theta[3])^theta[4])^2)
                      )                      
                }
  
  
  mu = f1(theta, x)
  
  sig.with.varpower = sigma*weights_varPower(phi, mu)

  obj1 = list( coefficients=theta, sigma=sigma, call=list(f.model=f1), fitted=mu, varBeta=V, df=10 )  ## Without gradient function
  attr(obj1, "w.func") = weights_varIdent
  obj2 = list( coefficients=theta, sigma=sigma, call=list(f.model=f2), fitted=mu, varBeta=V, df=10 )  ## With gradient function
  attr(obj2, "w.func") = weights_varPower
  attr(obj2, "var.param") = phi
  
  class(obj1) = class(obj2) = c("optim_fit", "list")

    ## Default returns fitted(obj)
  expect_equal( predict(obj1), mu, tolerance=1e-3 ) 
   
    ## Ask for SE fit
  pred2a = try(predict(obj1, se.fit=TRUE), silent=TRUE)   ## Fails
  expect_true( class(pred2a)[1]=="try-error" )
  
  pred2b = predict(obj1, x=x, se.fit=TRUE)  ## Without gradient
  se1 = sqrt(apply(f.grad, 1, function(g){ g%*%V%*%g })) 
  expect_equal( pred2b, cbind(x=x, y.hat=mu, se.fit=se1), tolerance=1e-3 ) 

  pred2b = predict(obj2, x=x, se.fit=TRUE)  ## With gradient
  se2 = sqrt(apply(attr(f2, "gradient")(theta, x), 1, function(g){ g%*%V%*%g })) 
  expect_equal( pred2b, cbind(x=x, y.hat=mu, se.fit=se2), tolerance=1e-3 ) 


    ## Ask for confidence interval  
  pred3 = predict(obj1, x=x, se.fit=TRUE, interval="confidence", level=0.95)  
  expect_equal( pred3, cbind(x=x, y.hat=mu, se.fit=se1, lower=mu-qt(0.975, obj1$df)*se1, upper=mu+qt(0.975, obj1$df)*se1), tolerance=1e-3 )   

    ## With weights_varPower()
  pred3 = predict(obj2, x=x, se.fit=TRUE, interval="confidence", level=0.95)  
  expect_equal( pred3, cbind(x=x, y.hat=mu, se.fit=se2, lower=mu-qt(0.975, obj1$df)*se2, upper=mu+qt(0.975, obj1$df)*se2), tolerance=1e-3 )   
    

    ## Ask for prediction interval  of next mean with K=2
  pred4 = predict(obj1, x=x, se.fit=TRUE, interval="prediction", K=2, level=0.95)  
  expect_equal( pred4, cbind(x=x, y.hat=mu, se.fit=se1, 
                             lower=mu-qt(0.975, obj2$df)*sqrt(sigma^2/2+se1^2), 
                             upper=mu+qt(0.975, obj2$df)*sqrt(sigma^2/2 + se1^2)), tolerance=1e-3 )   
    
    
  pred4 = predict(obj2, x=x, se.fit=TRUE, interval="prediction", K=2, level=0.95)  
  expect_equal( pred4, cbind(x=x, y.hat=mu, se.fit=se2, 
                             lower=mu-qt(0.975, obj2$df)*sqrt(sig.with.varpower^2/2+se2^2), 
                             upper=mu+qt(0.975, obj2$df)*sqrt(sig.with.varpower^2/2 + se2^2)), tolerance=1e-3 )   


  
})