tests/testthat/test_funDataMethods.R

context("Test funData methods")

f1 <- funData(argvals = 1:5, X = matrix(1:20, nrow = 4))
f2 <- funData(argvals = list(1:5, 1:6), X = array(1:120, c(4,5,6)))
f3 <- funData(argvals = list(1:5, 1:6, 1:4), X = array(1:480, c(4, 5, 6, 4)))
m1 <- multiFunData(f1, f2)
i1 <- irregFunData(argvals = list(1:5, 2:4, 3:5), X = list(1:5, 2:4, -(3:1)))
fi <- as.irregFunData(f1)

# special case for data with only one observation
f1.1 <- funData(argvals = 1:5, X = matrix(1:5, nrow = 1))
f2.1 <- funData(argvals = list(1:5, 1:6), X = array(1:30,c(1,5,6)))
m1.1 <- multiFunData(list(f1.1,f2.1))

test_that("print",{
  expect_known_output(print(f1), file = "outputs/print_funData.out")
  expect_known_output(print(m1), file = "outputs/print_multiFunData.out")
  expect_known_output(print(i1), file = "outputs/print_irregFunData.out")
})

test_that("str",{
  m2 <- m1
  names(m2) <- letters[1:length(m2)]
  expect_known_output(str(f1), file = "outputs/str_funData.out")
  expect_known_output(str(m1), file = "outputs/str_multiFunData.out")
  expect_known_output(str(m2), file = "outputs/str_multiFunData_2.out")
  expect_known_output(str(i1), file = "outputs/str_irregFunData.out")
  expect_known_output(str(i1, list.len = 1), file = "outputs/str_irregFunData_len1.out")
})

test_that("summary",{
  # Check errors:
  expect_error(funData:::print.summary.funData(summary(m1)), 
               "Argument is not of class 'summary.funData'.")
  expect_error(funData:::print.summary.multiFunData(summary(f1)), 
               "Argument is not of class 'summary.multiFunData'.")
  expect_error(funData:::print.summary.irregFunData(summary(f1)), 
               "Argument is not of class 'summary.irregFunData'.")
  
  # Check functionality:
  fName <- f1
  names(fName) <- letters[1:nObs(fName)]
  expect_known_output(print(summary(f1)), file = "outputs/summary_funData.out")
  expect_known_output(print(summary(fName)), file = "outputs/summary_funData_names.out")
  expect_known_output(print(summary(m1)), file = "outputs/summary_multiFunData.out")
  expect_known_output(print(summary(i1)), file = "outputs/summary_irregFunData.out")
  expect_known_output(print(summary(as.irregFunData(fName))), file = "outputs/summary_irregFunData_names.out")
})

test_that("names",{
  # Check errors:
  expect_error(names(f1) <- letters[1:3], "Names must have the same length as funData object.")
  expect_error(names(m1) <- letters[1:3], "Names must have the same length as multiFunData object.")
  expect_error(names(i1) <- letters[1:5], "Names must have the same length as irregFunData object.")
  
  # Check functionality:
  # funData (1D)
  names1 <- paste("Obs", 1:4)
  expect_equal({names(f1) <- names1}, names1) 
  expect_equal(names(f1), names1)
  # multiFunData
  namesM <- paste("Element", 1:2)
  expect_equal({names(m1) <- namesM}, namesM) 
  expect_equal(names(m1), namesM)
  # irregFunData
  namesI <- paste("Obs", 1:3)
  expect_equal({names(i1) <- namesI}, namesI)
  expect_equal(names(i1), names(i1@argvals))
  expect_equal(names(i1), names(i1@X))
})

test_that("dimSupp", {
  # Check functionality:
  # univariate FD object (one-dim)
  expect_equal(dimSupp(f1), 1)
  # univariate FDobject (two-dim)
  expect_equal(dimSupp(f2), 2)
  # multivariate FD object
  expect_equal(dimSupp(m1), c(1, 2))
  # irreg FD object
  expect_equal(dimSupp(i1), 1)
})

test_that("nObs", {
  # Check functionality:
  # univariate FD object (one-dim)
  expect_equal(nObs(f1), 4)
  # univariate FD object (two-dim)
  expect_equal(nObs(f2), 4)
  # multivariate FD object
  expect_equal(nObs(m1), 4)
  # irreg FD object
  expect_equal(nObs(i1),3)
})


test_that("nObsPoints", {
  # Check functionality:
  # univariate FD object (one-dim)
  expect_equal(nObsPoints(f1), 5)
  # univariate FD object (two-dim)
  expect_equal(nObsPoints(f2), c(5,6))
  # multivariate FD object
  expect_equal(nObsPoints(m1), list(5,c(5,6)))
  # irreg FD object
  expect_equal(nObsPoints(i1), c(5,3,3))  
})

test_that("extractObs", {
  # Check errors:
  # univariate FD object (one-dim)
  expect_error(extractObs(f1, obs = "5"), 
               "Supply observations as numeric vector") # observation does not exist
  expect_error(extractObs(f1, obs = 5), 
               "Trying to extract observations that do not exist!") # observation does not exist
  expect_error(extractObs(f1, argvals = list(4:6)), 
               "Trying to extract x-values that do not exist!") # argvals do not exist
  expect_error(extractObs(f1, argvals = "a"), # wrong data type
               "Supply argvals for extracted observations either as list or as numeric vector (only if support is one-dimensional)", fixed = TRUE) # fixed, as '(...)' is interpreted as regexp
  # univariate FD object (two-dim)
  expect_error(extractObs(f2, argvals = 1:5),
               "Supply argvals for extracted observations either as list or as numeric vector (only if support is one-dimensional", fixed = TRUE) # fixed, as '(...)' is interpreted as regexp
  # univariate FD object (> 3-dim)
  expect_error(extractObs(funData(argvals = list(1:2,2:3,3:4,4:5), X = (1:5) %o% (1:2) %o% (2:3) %o% (3:4) %o% (4:5))),
               "extracting observations is not implemented yet for functional data of dimension > 3")
  # multi FD object
  expect_error(extractObs(m1, argvals = "1"), "extractObs for multiFunData: argvals must be supplied as list (or missing).", fixed = TRUE) # fixed, as '(...)' is interpreted as regexp
  # irreg FD object
  expect_error(extractObs(i1, obs = list(1:3)), 
               "Supply observations as numeric vector")
  expect_error(extractObs(i1, obs = 4),
               "Trying to extract observations that do not exist!")
  expect_error(extractObs(extractObs(i1, argvals = "1")),
               "Supply argvals for extracted observations either as list or as numeric vector")
  expect_error(extractObs(i1, argvals = 6),
               "Trying to extract x-values that do not exist!")
  expect_warning(extractObs(i1, argvals = c(1,5)),
                 "Some functions were not observed on the given argvals and therefore removed.")
  
  # Check functionality:
  # univariate FD object (one-dim)
  expect_equal(extractObs(f1, obs = 1:2), funData(argvals = 1:5, matrix(1:20, nrow = 4)[1:2, ]))
  expect_equal(extractObs(f1, argvals = 1:2), funData(argvals = 1:2, matrix(1:20, nrow = 4)[, 1:2]))
  expect_equal(extractObs(f1, argvals = 1:2), extractObs(f1, argvals = list(1:2)))
  # univariate FDobject (two-dim)
  expect_equal(extractObs(f2, obs = 2),  funData(argvals = list(1:5, 1:6), X = array(1:120, c(4, 5, 6))[2, , , drop = FALSE]))
  expect_equal(extractObs(f2, argvals = list(1:3, 4:6)), funData(argvals = list(1:3, 4:6), X = array(1:120, c(4, 5, 6))[, 1:3, 4:6]))
  # univariate FDobject (three-dim)
  expect_equal(extractObs(f3, obs = 4),  funData(argvals = f3@argvals, X = f3@X[4, , , , drop = FALSE]))
  expect_equal(extractObs(f3, argvals = list(1:3, 4:6, 2:4)), funData(argvals = list(1:3, 4:6, 2:4), X = f3@X[, 1:3, 4:6, 2:4]))
  # multivariate FD object
  expect_equal(extractObs(m1, obs = 2), multiFunData(extractObs(m1[[1]], obs = 2), extractObs(m1[[2]], obs = 2)))
  expect_equal(extractObs(m1, obs = list(2,3)), multiFunData(extractObs(m1[[1]], obs = 2), extractObs(m1[[2]], obs = 3)))  
  # irreg FD object
  expect_equal(extractObs(i1, argvals = list(3:4)), extractObs(i1, argvals = 3:4))
  expect_equal(extractObs(i1, obs = 1), irregFunData(argvals = list(1:5), X = list(1:5)))
  expect_equal(extractObs(i1, argvals = 2:3), irregFunData(argvals = list(2:3, 2:3, 3), X = list(2:3, 2:3, -3)))
  
  # alternative via []
  expect_equal(extractObs(f1, obs = 1:2), f1[1:2])
  expect_equal(extractObs(f1, argvals = 1:2), f1[argvals = 1:2])
  expect_equal(f1, f1[]) # default: select all observations
  expect_equal(extractObs(f2, obs = 2), f2[2])
  expect_equal(extractObs(f2, argvals = list(1:3, 4:6)), f2[argvals = list(1:3, 4:6)])
  expect_equal(extractObs(f3, obs = 4),f3[4])
  expect_equal(extractObs(f3, argvals = list(1:3, 4:6, 2:4)), f3[argvals = list(1:3, 4:6, 2:4)])
  expect_equal(extractObs(m1, obs = 2), m1[2])
  expect_equal(extractObs(i1, obs = 1), i1[1])
  expect_equal(extractObs(i1, argvals = 2:3), i1[argvals = 2:3])
  
  # alias: subset
  expect_equal(extractObs(f1, obs = 1:2), subset(f1, obs = 1:2))
  expect_equal(extractObs(f1, argvals = 1:2), subset(f1, argvals = 1:2))
  expect_equal(extractObs(f2, obs = 2), subset(f2, obs = 2))
  expect_equal(extractObs(f2, argvals = list(1:3, 4:6)), subset(f2, argvals = list(1:3, 4:6)))
  expect_equal(extractObs(f3, obs = 4), subset(f3, obs = 4))
  expect_equal(extractObs(f3, argvals = list(1:3, 4:6, 2:4)), subset(f3, argvals = list(1:3, 4:6, 2:4)))
  expect_equal(extractObs(m1, obs = 2), subset(m1, obs = 2))  
  expect_equal(extractObs(i1, obs = 1), subset(i1, obs = 1))
  expect_equal(extractObs(i1, argvals = 2:3), subset(i1, argvals = 2:3))
})

test_that("Arith", {
  # Check errors:
  # univariateFD, univariate FD
  expect_error(f1 + extractObs(f1,1:2), 
               "nObs of funData objects is neither equal nor one.")
  expect_error(f1 -  extractObs(f1, argvals = 1:2),
               "Functions must be defined on the same domain!")
  
  #multivaraite FD
  expect_error(m1 - as.multiFunData(f1),
               "Multivariate functional data must have same length!")
  
  # irreg & irreg
  expect_error(extractObs(i1, obs = 2) + i1,
               "Multiple functions must be defined on subdomain of single function.")
  expect_error(i1 + extractObs(i1, obs = 2),
               "Multiple functions must be defined on subdomain of single function.")
  expect_error(i1 + extractObs(i1, obs = 1:2),
               "IrregFunData objects must have either the same number of observations or just one.")
  expect_error(i1 +  irregFunData(argvals = lapply(i1@argvals, function(l){l+1}), X = i1@X),
               "Arithmetics for two irregular functional data objects are defined only for functions on the same domain.")
  
  # irreg & reg
  expect_error(i1 + extractObs(f1, argvals = 3:4, obs = 1:3),
               "irregFunData object must be defined on a subdomain of the funData object!")
  expect_error(i1+f1,
               "funData object must have either one observation or the same number of observations as the irregFunData object")
  expect_error(extractObs(f1, argvals = 3:4, obs = 1:3) + i1,
               "irregFunData object must be defined on a subdomain of the funData object!")
  expect_error(f1 + i1,
               "funData object must have either one observation or the same number of observations as the irregFunData object")
  
  
  # Check functionality:
  # univariate & univariate
  expect_equal(f1+f1, funData(f1@argvals,f1@X+f1@X))
  expect_equal(f1-f1, funData(f1@argvals,f1@X-f1@X))
  expect_equal(f1*f1, funData(f1@argvals,f1@X*f1@X))
  expect_equal(f1/f1, funData(f1@argvals,f1@X/f1@X))  
  # univariate & scalar
  expect_equal(f1+f1, 2*f1)
  expect_equal(f1+f1, f1*2)
  expect_equal(f1-f1, 0*f1)
  expect_equal(f1-f1, f1*0)
  expect_equal(f1*f1, f1^2)
  expect_equal(f1/f1, 0*f1+1)
  expect_equal(f1/f1, 1+ f1*0)  
  # univariate with e1/e2 having only one observation
  expect_equal(extractObs(f1 + extractObs(f1,1),1), extractObs(2*f1,1), check.attributes = FALSE)
  expect_equal(extractObs(f2 + extractObs(f2,1),1), extractObs(2*f2,1), check.attributes = FALSE)
  expect_equal(extractObs(extractObs(f1,1),1) + f1, extractObs(2*f1,1), check.attributes = FALSE)
  expect_equal(extractObs(extractObs(f2,1),1) + f2, extractObs(2*f2,1), check.attributes = FALSE)
  
  # multivariate & multivariate
  expect_equal(m1+m1, multiFunData(mapply("+", m1, m1)))
  expect_equal(m1-m1, multiFunData(mapply("-", m1, m1)))
  expect_equal(m1*m1, multiFunData(mapply("*", m1, m1)))
  expect_equal(m1/m1, multiFunData(mapply("/", m1, m1)))  
  # multivariate & scalar
  expect_equal(m1+m1, 2*m1)
  expect_equal(m1+m1, m1*2)
  expect_equal(m1-m1, 0*m1)
  expect_equal(m1-m1, m1*0)
  expect_equal(m1*m1, m1^2)
  expect_equal(m1/m1, 0*m1+1)
  expect_equal(m1/m1, 1 + m1*0) 
  
  # irreg & irreg
  x1 <- unique(unlist(i1@argvals))
  expect_equal(i1+i1, irregFunData(i1@argvals,mapply('+', i1@X, i1@X)))
  expect_equal(i1-i1, irregFunData(i1@argvals,mapply('-', i1@X, i1@X)))
  expect_equal(i1*i1, irregFunData(i1@argvals,mapply('*', i1@X, i1@X)))
  expect_equal(i1/i1, irregFunData(i1@argvals,mapply('/', i1@X, i1@X)))
  expect_equal(i1 + irregFunData(argvals = list(x1), X = list(rep(0, length(x1)))), i1)
  expect_equal(irregFunData(argvals = list(x1), X = list(rep(1, length(x1)))) + i1, 1+ i1)
  # irreg & reg
  expect_equal(i1 + extractObs(f1, obs = 1:3), extractObs(f1, obs = 1:3) + i1) # same number of observations
  expect_equal(i1 + extractObs(f1, obs = 1), extractObs(f1, obs = 1) + i1) # funData object has only one observation
  # irreg & scalar
  expect_equal(i1+i1, 2*i1)
  expect_equal(i1+i1, i1*2)
  expect_equal(i1-i1, 0*i1)
  expect_equal(i1-i1, i1*0)
  expect_equal(i1*i1, i1^2)
  expect_equal(i1/i1, 0*i1+1)
  expect_equal(i1/i1, 1 + i1*0)   
})


test_that("Math", {
  # Check functionality:
  # funData
  expect_equal(exp(f1), funData(f1@argvals, exp(f1@X)))
  expect_equal(sin(f1)^2 + cos(f1)^2, 0*f1+1) # combination of Arith and math
  
  # irregFunData
  expect_equal(exp(i1), irregFunData(i1@argvals, lapply(i1@X,exp)))
  expect_equal(sin(i1)^2 + cos(i1)^2, 0*i1+1) # combination of Arith and math
  
  # multiFunData
  expect_equal(exp(m1), multiFunData(exp(f1), exp(f2)))
  expect_equal(sin(m1)^2 + cos(m1)^2, 0*m1+1) # combination of Arith and math
})

test_that("norm", {
  # Check errors:
  # univariate FD object
  expect_error(norm(f1, squared = "Yes"), "Parameter 'squared' must be passed as a logical.") 
  expect_error(norm(f1, squared = c(TRUE, FALSE)), "Parameter 'squared' must be passed as a logical.") 
  expect_error(norm(f1, weight = "1"), "Parameter 'weight' must be passed as a positive number.")
  expect_error(norm(f1, weight = 1:2), "Parameter 'weight' must be passed as a positive number.")
  expect_error(norm(f1, weight = -1), "Parameter 'weight' must be passed as a positive number.")
  # multivariate FD object
  expect_error(norm(m1, weight = c(1,"2")),
               "Parameter 'weight' must be passed as a vector of 2 positive numbers.") 
  expect_error(norm(m1, weight = 1:3),
               "Parameter 'weight' must be passed as a vector of 2 positive numbers.") 
  expect_error(norm(m1, weight = c(-1,1)),
               "Parameter 'weight' must be passed as a vector of 2 positive numbers.") 
  # irreg FD object
  expect_error(norm(i1, squared = "Yes"), "Parameter 'squared' must be passed as a logical.")
  expect_error(norm(i1, squared = c(TRUE, TRUE)), "Parameter 'squared' must be passed as a logical.")
  expect_error(norm(i1, weight = "1"), "Parameter 'weight' must be passed as a positive number.")
  expect_error(norm(i1, weight = 1:2), "Parameter 'weight' must be passed as a positive number.")
  expect_error(norm(i1, weight = -1), "Parameter 'weight' must be passed as a positive number.")
  
  # Check functionality:
  # univariate FD object
  expect_equal(norm(f1), # all observations
               apply((f1^2)@X, 1, function(f, argvals, method){funData:::.intWeights(argvals, method) %*% f}, argvals = f1@argvals[[1]], method = "trapezoidal") )
  expect_equal(norm(f1)[1:3], norm(f1, obs = 1:3))   # only some observations
  expect_equal(norm(f1, squared = FALSE)[2], sqrt(norm(f1)[2])) # squared option
  expect_equal(norm(f1, weight = 2), 2*norm(f1)) # weight (makes little sense for univariate funData objects...)
  # multivariate FD object
  expect_equal(norm(m1), rowSums(sapply(m1, norm, simplify = TRUE))) # all observations
  expect_equal(norm(m1)[1], norm(m1, obs = 1)) # only one observation
  expect_equal(norm(m1, squared = FALSE), sqrt(rowSums(sapply(m1, norm, squared = TRUE, simplify = TRUE)))) # squared option
  expect_equal(norm(m1, weight = c(2,1)), norm(multiFunData(sqrt(2)*f1,f2))) # with weight
  # irreg FD object  
  expect_equal(norm(i1), c(42,19,9), tolerance = 1e-5) # result calculated explicitly
  expect_equal(norm(i1, fullDom = TRUE), c(42,42,43), tolerance = 1e-5) # result calculated explicitly
  expect_equal(norm(i1, weight = 2), 2*norm(i1)) # weight (makes little sense for univariate funData objects...)
})


test_that("scalarProduct", {
  # Check errors:
  expect_error(scalarProduct(m1, as.multiFunData(f1)),
               "multiFunData objects must have the same number of elements.")
  expect_error(scalarProduct(m1, m1, weight = 1:3),
               "Weight vector must have the same number of elements as the multiFunData objects.")
  expect_error(scalarProduct(m1, m1, weight = c(-1,1)),
               "Weights must be non-negative.")
  expect_error(scalarProduct(m1, m1, weight = c(0,0)),
               "At least one weighting factor must be different from 0.")
  
  # Check functionality:
  # univariate FD objects
  s <- scalarProduct(f1, 2*f1)
  expect_equal(length(s), nObs(f1))
  expect_equal(s[1], 840, tol = 1e-5)
  expect_equal(scalarProduct(f1,f1), norm(f1, squared = TRUE))
  # multivariate FD object
  expect_equal(scalarProduct(m1,m1), norm(m1, squared = TRUE))
  expect_equal(scalarProduct(m1,m1, weight = c(1,2)), norm(m1, squared = TRUE, weight = c(1,2))) # with weights
  expect_equal(scalarProduct(as.multiFunData(f1),as.multiFunData(f1)), norm(f1, squared = TRUE)) # special case: only one element
  # irreg FD object  
  expect_equal(scalarProduct(i1,i1), norm(i1, squared = TRUE))
  expect_equal(norm(i1, squared = FALSE)^2, norm(i1, squared = TRUE)) # check squared
})

test_that("integrate", {
  # Check errors:  
  expect_error(integrate(funData(argvals = list(1:2,1:3,1:4,1:5), X = array(rnorm(120), dim = c(1,2,3,4,5)))),
               "Integration is not yet defined for functional data objects with dim > 3")
  expect_error(integrate(f1, method = 1),"Parameter 'method' must be a string.")
  expect_error(integrate(f1, method = c("m1", "m2")),"Parameter 'method' must be a string.")
  expect_error(integrate(i1, fullDom = "Yes"),"Parameter 'fullDom' must be a logical.") 
  expect_error(integrate(i1, fullDom = c(TRUE, FALSE)),"Parameter 'fullDom' must be a logical.")
  expect_warning(integrate(extractObs(f1, argvals = 1:2)), # method = trapezoidal and not enough observation points
                 "Trapezoidal quadrature is not applicable for functions with < 3 observation points. 'method' changed to 'midpoint'.")
  
  # Check functionality:
  # univariate FD objects
  expect_equal(integrate(f1)[1], sum(funData:::.intWeights(f1@argvals[[1]], "trapezoidal")*f1@X[1,]))
  expect_equal(integrate(f2)[1], as.numeric(t(funData:::.intWeights(f2@argvals[[1]], "trapezoidal")) %*% 
                                              f2@X[1,,] %*% funData:::.intWeights(f2@argvals[[2]], "trapezoidal")))
  expect_equal(integrate(f3)[1], 14340)
  # multivariate FD objects
  expect_equal(integrate(m1), as.numeric(integrate(f1) + integrate(f2)))
  expect_equal(integrate(m1.1), as.numeric(integrate(f1.1) + integrate(f2.1)))
  # irreg FD object 
  expect_equal(integrate(i1), c(12,6,-4), tolerance = 1e-5)
  expect_equal(integrate(i1, fullDom = TRUE), c(12,12,-12), tolerance = 1e-5)
  expect_equal( integrate(extractObs(i1, argvals = 1:3), fullDom = TRUE), c(4,4,6)) # fullDom uses extrapolate and 3rd obs has only one observation point
  
  # check generic default (from stats::integrate help page)
  expect_equal(integrate(dnorm, -1.96, 1.96)$value, 2*pnorm(1.96)- 1)
})

test_that("integrate3D",{
  x <- seq(0,1, 0.02); nX <- length(x)
  y <- seq(-0.5,0.5, 0.02); nY <- length(y)
  z <- seq(1,2,0.02); nZ <- length(z)
  
  A <- array(NA, c(nX, nY, nZ))
  
  for(ix in 1:nX)
    for(iy in 1:nY)
      for(iz in 1:nZ)
        A[ix,iy,iz] <-  x[ix]*cos(pi*y[iy])*z[iz]^2
  
  expect_equal(funData:::integrate3D(A, argvals = list(x,y,z)), 7/(3*pi), tolerance = 1e-3)
})

test_that("set/get", {
  # Check errors:
  # univariate FD object (one-dim)
  expect_error({argvals(f1) <-  1:6}, 
               "argvals and X have different number of sampling points! X-Dimensions must be of the form N x M1 x ... x Md") # wrong number of sampling points (argvals)
  expect_error({X(f1) <- matrix(1:24, nrow = 4)}, 
               "argvals and X have different number of sampling points! X-Dimensions must be of the form N x M1 x ... x Md") # wrong number of sampling points (X)
  expect_warning({tmp <- f1; X(tmp) <- matrix(1:25, nrow = 5)}, 'Number of observations has changed') # warning: more observations
  # univariate FD object (two-dim)
  expect_error({argvals(f2) <- 1:5}, 
               "argvals and X element have different support dimensions! X-Dimensions must be of the form N x M1 x ... x Md") # wrong dimension (argvals)
  expect_error({X(f2) <- matrix(1:20, nrow = 4)}, 
               "argvals and X element have different support dimensions! X-Dimensions must be of the form N x M1 x ... x Md") # wrong dimension (X)
  # multivariate FD object
  expect_error({argvals(m1) <- list(1+1:5, list(2+1:5, 3+1:6), 4+1:5)}, 'multiFunData object and new argvals must have the same length') # wrong length (argvals, multiFunData)
  expect_error({X(m1) <- list(X(f1), X(f2), matrix(1:12, nrow = 4))}, 'multiFunData object and new X must have the same length') # wrong length (X, multiFunData)
  expect_error({X(m1) <- list(matrix(1:25, nrow = 5), array(1:120, c(4,5,6)))}, 'New X object must have the same number of observations in all elements!') # different number of observations
  expect_warning({X(m1) <- list(matrix(1:25, nrow = 5), array(1:150, c(5,5,6)))}, 'Number of observations has changed') # warning: more observations
  # irreg FD object
  expect_error({argvals(i1) <- list(1:4)}, "New argvals must be a list of the same length as the original argvals.")
  expect_error({argvals(i1) <- list(1:6, 1:3, 1:10)}, "New argvals must have the same structure as the original argvals.")
  expect_error({X(i1) <- list(1:4)}, "New X must be a list of the same length as the original X.")
  expect_error({X(i1) <- list(1:6, 1:3, 1:10)}, "New X must have the same structure as the original X.")
  
  # Check functionality:
  # univariate FD object (one-dim)
  expect_equal({argvals(f1) <- list(1+1:5)}, list(1+1:5))
  expect_equal({argvals(f1) <- 1+1:5; argvals(f1)}, list(1+1:5)) # special case: one-dimensional domain
  expect_equal({X(f1) <- matrix(1+1:20, nrow = 4)}, matrix(1+1:20, nrow = 4))
  # univariate FD object (two-dim)
  expect_equal({argvals(f2) <- list(1+1:5, 2+1:6)}, list(1+1:5, 2+1:6))  
  # multivariate FD object
  expect_equal({argvals(m1) <- list(list(2+1:5), list(1+1:5, 3+1:6))}, list(list(2+1:5), list(1+1:5, 3+1:6)))
  expect_equal({X(m1) <- list(matrix(1+1:20, nrow = 4), array(2+1:120, c(4,5,6)))}, list(matrix(1+1:20, nrow = 4), array(2+1:120, c(4,5,6))))
  expect_equal({argvals(m1) <- list(1+1:5, list(2+1:5, 3+1:6)); argvals(m1)}, list(list(1+1:5), list(2+1:5, 3+1:6))) # special case: one-dimensional domains
  # irreg FD object
  expect_equal({argvals(i1) <- list(0:4, 0:2, 1:3)}, list(0:4, 0:2, 1:3))
  expect_equal({X(i1) <- list(0:4, 0:2, 1:3)}, list(0:4, 0:2, 1:3))
  
  # check multivariate functions with one element
  expect_equal(argvals(f1), argvals(as.multiFunData(f1))[[1]])
  
  # check deprecated functions
  expect_warning(tmp <- getArgvals(f1));   expect_equal(tmp, argvals(f1))
  expect_warning(tmp <- getArgvals(f2)); expect_equal(tmp, argvals(f2))
  expect_warning(tmp <- getArgvals(m1)); expect_equal(tmp, argvals(m1))
  expect_warning(tmp <- getArgvals(i1)); expect_equal(tmp, argvals(i1))
  
  expect_warning(tmp <- getX(f1)); expect_equal(tmp, X(f1))
  expect_warning(tmp <- getX(f2)); expect_equal(tmp, X(f2))
  expect_warning(tmp <- getX(m1)); expect_equal(tmp, X(m1))
  expect_warning(tmp <- getX(i1)); expect_equal(tmp, X(i1))
  
  expect_warning(tmp <- setArgvals(f1, list(1+1:5))); expect_equal( {argvals(f1) <- list(1+1:5); f1}, tmp)
  expect_warning(tmp <- setArgvals(f1, 1+1:5)); expect_equal( {argvals(f1) <- list(1+1:5); f1}, tmp) # special case: one-dimensional domain
  expect_warning(tmp <- setArgvals(f2, list(1+1:5, 2+1:6))); expect_equal( {argvals(f2) <- list(1+1:5, 2+1:6); f2}, tmp)  
  expect_warning(tmp <- setArgvals(m1, list(list(2+1:5), list(1+1:5, 3+1:6))));  expect_equal( {argvals(m1) <- list(list(2+1:5), list(1+1:5, 3+1:6)); m1}, tmp)
  expect_warning(tmp <- setArgvals(m1, list(1+1:5, list(2+1:5, 3+1:6)))); expect_equal( {argvals(m1) <- list(list(1+1:5), list(2+1:5, 3+1:6)); m1}, tmp) # special case: one-dimensional domains
  expect_warning(tmp <- setArgvals(i1, list(0:4, 0:2, 1:3))); expect_equal( {argvals(i1) <- list(0:4, 0:2, 1:3); i1}, tmp)
  
  expect_warning(tmp <- setX(f1, matrix(1+1:20, nrow = 4))); expect_equal( {X(f1) <- matrix(1+1:20, nrow = 4); f1}, tmp)
  expect_warning(tmp <- setX(m1, list(matrix(1+1:20, nrow = 4), array(2+1:120, c(4,5,6))))); expect_equal( {X(m1) <- list(matrix(1+1:20, nrow = 4), array(2+1:120, c(4,5,6))); m1}, tmp)
  expect_warning(tmp <- setX(i1, list(0:4, 0:2, 1:3))); expect_equal( {X(i1) <-  list(0:4, 0:2, 1:3); i1}, tmp)
})

test_that("flipFun", {
  # Check errors:
  # univariate FD object
  expect_error(flipFuns(f1,funData(argvals = list(1:5), X = array(1:30,c(6,5)))), 
               'Functions must have the same number of observations or use a single function as reference.') # not the same number of observations
  expect_error(flipFuns(f1,f2), 
               'Functions must have the dimension.') # not the same dimension
  expect_error(flipFuns(f1,funData(argvals = list(2:6), X = array(1:20,c(4,5)))), 
               'Functions must be defined on the same domain.') # not the same domain
  expect_error(flipFuns(f3, 2*f3),
               "Function is only implemented for data of dimension <= 2")
  # multivariate FD
  expect_error(flipFuns(m1, as.multiFunData(f1)),
               "multiFunData objects must have the same length")
  expect_error(flipFuns(m1, extractObs(m1, 1:2)),
               "Functions must have the same number of observations or use a single function as reference.")
  expect_error(flipFuns(m1, multiFunData(f2,f1)),
               "Functions must have the dimension.")
  expect_error(flipFuns(m1, multiFunData(extractObs(f1, argvals = 1:4), f2)),
               "Functions must be defined on the same domain.")
  # irreg FD object (regular reference)
  expect_error(flipFuns(f2,i1),
               "Function is only implemented for irregular data with one-dimensional support")
  expect_error(flipFuns(extractObs(f1, 1:2), i1),
               "Functions must have the same number of observations or use a single function as reference.")
  expect_error(flipFuns(extractObs(f1, argvals = 1:3), fi),
               "Irregular functions must be defined on a sub-domain of the reference function(s).", fixed = TRUE)# fixed, as '(...)' is interpreted as regexp
  # irreg FD object (irregular reference)
  expect_error(flipFuns(extractObs(i1, 1:2), i1),
               "Functions must have the same number of observations or use a single function as reference.")
  expect_error(flipFuns(extractObs(i1, argvals = 1:3), i1),
               "New functions must be defined on a sub-domain of the reference function(s).", fixed = TRUE)  # fixed, as '(...)' is interpreted as regexp
  
  # Check functionality:
  # univariate FD object (one-dim)
  expect_equal(flipFuns(f1, -1*f1), f1)
  # univariate FD object (two-dim)
  expect_equal(flipFuns(f2, -1*f2), f2)
  # multivariate FD object
  expect_equal(flipFuns(m1, -1*m1), m1) 
  # irreg FD object
  expect_equal(flipFuns(f1,fi),fi) # regular reference for each observation
  expect_equal(flipFuns(extractObs(f1, obs = 1), fi), fi) # single  regular reference function
  expect_equal(flipFuns(i1, -1*i1), i1) # irreg reference for each observation
  expect_equal(flipFuns(extractObs(fi, obs = 1), -1*fi), fi) # irreg reference for each observation
})


test_that("meanFunction",{
  set.seed(2)
  f1NA <- f1; f1NA@X[sample(prod(dim(f1NA@X)), 5)] <- NA
  
  # Check errors:
  # funData
  expect_error(meanFunction(f1, na.rm = "Yes"), "Parameter 'na.rm' must be a logical.")
  expect_error(meanFunction(f1, na.rm = c(TRUE, FALSE)), "Parameter 'na.rm' must be a logical.")
  # irreg FD object
  expect_error(meanFunction(i1, na.rm = "Yes"), "Parameter 'na.rm' must be a logical.")
  expect_error(meanFunction(i1, na.rm = c(TRUE, FALSE)), "Parameter 'na.rm' must be a logical.")
  expect_error(meanFunction(irregFunData(argvals = list(1:3,1:5), X = list(1:3,1:5))),
               "Mean function defined only for irregular functional data objects on the same domain.")
  expect_error(meanFunction(i1, na.rm = TRUE),
               "Option na.rm = TRUE is not implemented for mean functions of irregular data.")
  
  # Check functionality:
  # univariate FD object (one-dim)
  expect_equal(meanFunction(f1), {mean1 <- funData(1:5, matrix(seq(2.5, 18.5, 4), nrow = 1))})
  expect_equal(meanFunction(f1NA), 
               funData(f1NA@argvals, array(colMeans(f1NA@X), dim = c(1, length(f1@argvals[[1]])))))
  # univariate FD object (two-dim)
  expect_equal(meanFunction(f2), {mean2 <- funData(f2@argvals, array(seq(2.5,118.5, 4), dim = c(1,5,6)))})
  # multivariate FD object
  expect_equal(meanFunction(m1), multiFunData(mean1,mean2))
  # irregular FD object
  expect_equal(meanFunction(fi), as.irregFunData(mean1))
})

test_that("expand.int",{
  expect_null(funData:::expand.int())
  expect_equal(funData:::expand.int(2,5), data.frame(Var1 = rep(1:2, each = 5), Var2 = rep(1:5, times = 2)))
}
)

test_that("tensorProduct",{
  # Check errors:
  expect_error(tensorProduct(f1), "tensorProduct currently accepts only 2 or 3 arguments.")
  expect_error(tensorProduct(f1, f2, f2, f1), "tensorProduct currently accepts only 2 or 3 arguments.")
  expect_error(tensorProduct(f1, tensorProduct(f1,f2)), "tensorProduct is defined only for funData objects on one-dimensional domains!")
  
  # Check functionality:
  # tensor product of two functions
  TP1 <- tensorProduct(f1, f1.1)
  expect_equal(dimSupp(TP1), 2)
  expect_equal(TP1@argvals, list(f1@argvals[[1]], f1.1@argvals[[1]]))
  expect_equal(nObs(TP1), nObs(f1)*nObs(f1.1))
  expect_equal(apply(TP1@X[1,-1,]/TP1@X[4,-1,], 1, mean), c(0.625, 0.75, 0.8125, 0.85), tol = 1e-5)
  expect_equal(apply(TP1@X[1,-1,]/TP1@X[4,-1,], 1, var), rep(0,4), tol = 1e-5)
  
  # tensor product of three functions
  TP2 <- tensorProduct(f1, f1.1, f1)
  expect_equal(dimSupp(TP2), 3)
  expect_equal(TP2@argvals, list(f1@argvals[[1]], f1.1@argvals[[1]], f1@argvals[[1]]))
  expect_equal(nObs(TP2), nObs(f1)^2*nObs(f1.1))
  expect_equal(mean(TP2@X[1,-1,-1,-1]/TP2@X[2,-1,-1,-1]), 0.90159, tol = 1e-5)
  expect_equal(var(TP2@X[1,-1,-1,-1]/TP2@X[2,-1,-1,-1]), 0.0018352, tol = 1e-7)
})

test_that("approxNA",{
  set.seed(2)
  expect_equal(integrate(f1 - as.irregFunData(approxNA(sparsify(f1, minObs = 3, maxObs = 5)))),
               rep(0, nObs(f1)))
  
})

Try the funData package in your browser

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

funData documentation built on May 29, 2024, 6:08 a.m.