tests/testthat/test-fits.R

In cmjt/stelfi: Hawkes and Log-Gaussian Cox Point Processes Using Template Model Builder

test_that("Hawkes simulation (1)", {
    ## sim_hawkes example
    set.seed(1234)
    times <- sim_hawkes(mu = 0.3, alpha = 4, beta = 5)
    expect_equal(round(times[1:6], 2),
                 c(4.15,  4.95,  7.80, 14.64, 18.69, 33.61),
                 tolerance = 0.01)
})
test_that("Hawkes simulation (2)", {
    ## sim_hawkes example
    set.seed(1234)
    times <- sim_hawkes(mu = 0.3, alpha = 4, beta = 5, method = "2")
    expect_equal(round(times[1:6], 2),
                 c(4.15,  4.22,  4.40, 4.42, 4.43, 5.54),
                 tolerance = 0.01)
})
test_that("Simple Hawkes model fitting", {
    ## NIWA retweets
    data(retweets_niwa, package = "stelfi")
    times <- unique(sort(as.numeric(difftime(retweets_niwa,
                                             min(retweets_niwa),
                                             units = "mins"))))
    params <- c(mu = 9, alpha = 3, beta = 10)
    fit <- fit_hawkes(times = times, parameters = params)
    pars <- as.numeric(get_coefs(fit)[, 1])
    expect_equal(pars[1], 0.06328, tolerance = 1)
    expect_equal(pars[2], 0.07597, tolerance = 1)
    expect_equal(pars[3], 0.07911, tolerance = 1)
})
test_that("Non-homogeneous Hawkes model fitting", {
    set.seed(1)
    times <- sim_hawkes(mu = 0.3, alpha = 4, beta = 5)
    background <- function(params, times) {
        A <- exp(params[[1]])
        B <- stats::plogis(params[[2]]) * A
        return(A + B * sin(times))
    }
    background_integral <- function(params, x) {
        A <- exp(params[[1]])
        B <- stats::plogis(params[[2]]) * A
        return((A * x) - B * cos(x))
    }
    param <- list(alpha = 0.5, beta = 1.5)
    background_param <- list(1, 1)
    fit <- fit_hawkes_cbf(times = times, parameters = param,
                          background = background,
                          background_integral = background_integral,
                          background_parameters = background_param)
    estA <- exp(fit$background_parameters[1])
    estB <- plogis(fit$background_parameters[2]) * exp(fit$background_parameters[1])
    expect_equal(estA, 0.2387370, tolerance = 0.1)
    expect_equal(estB, 0.02600446, tolerance = 0.1)
})
test_that("Multivariate Hawkes model fitting", {
    data(multi_hawkes, package = "stelfi")
    fit <- stelfi::fit_mhawkes(times = multi_hawkes$times, stream = multi_hawkes$stream,
                           parameters = list(mu =  c(0.2,0.2),
                                        alpha =  matrix(c(0.5,0.1,0.1,0.5),byrow = TRUE,nrow = 2),
                                        beta = c(0.7,0.7)))
    ll <- fit$fn()
    expect_equal(ll,  132, tolerance = 2)
})
test_that("LGCP model fitting (spatial)", {
    if(requireNamespace("fmesher")){
        data(xyt, package = "stelfi")
        domain <- sf::st_as_sf(xyt$window)
        locs <- data.frame(x = xyt$x, y = xyt$y)
        bnd <- fmesher::fm_as_segm(as.matrix(sf::st_coordinates(domain)[, 1:2]))
        smesh <- fmesher::fm_mesh_2d(boundary = bnd,
                                    max.edge = 0.75, cutoff = 0.3)
        fit <- fit_lgcp(locs = locs, sf = domain, smesh = smesh,
                        parameters = c(beta = 0, log_tau = log(1),
                                       log_kappa = log(1)))
        pars <- as.numeric(get_coefs(fit)[, 1])
        expect_equal(pars[1], 2.45, tolerance = 0.5)
        expect_equal(pars[2], -1.32, tolerance = 0.1)
        expect_equal(pars[3], 0.95, tolerance = 0.1)
    }
})
test_that("Simulate LGCP (spatial)", {
    if(requireNamespace("fmesher")){
        data(xyt, package = "stelfi")
        domain <- sf::st_as_sf(xyt$window)
        bnd <- fmesher::fm_as_segm(as.matrix(sf::st_coordinates(domain)[, 1:2]))
        smesh <- fmesher::fm_mesh_2d(boundary = bnd, max.edge = 0.75, cutoff = 0.3)
        parameters <- c(beta = 1, log_tau = log(1), log_kappa = log(1))
        set.seed(91234)
        sim <- sim_lgcp(parameters = parameters, sf = domain, smesh = smesh)
        expect_equal(round(c(sim$x[1:3]), 3),
                     c(0.172, 0.175, 0.298),
                     tolerance = 0.5)
        expect_equal(length(sim$x),length(sim$y))
    }
})
test_that("LGCP model fitting (spatiotemporal)", {
    skip_on_cran()
    if(requireNamespace("fmesher")){
        data(xyt, package = "stelfi")
        domain <- sf::st_as_sf(xyt$window)
        ndays <- 2
        locs <- data.frame(x = xyt$x, y = xyt$y, t = xyt$t)
        bnd <- fmesher::fm_as_segm(as.matrix(sf::st_coordinates(domain)[, 1:2]))
        w0 <- 2
        smesh <- fmesher::fm_mesh_2d(boundary = bnd,
                                    max.edge = 0.75, cutoff = 0.3)
        tmesh <- fmesher::fm_mesh_1d(seq(0, ndays, by = w0))
        fit <- fit_lgcp(locs = locs, sf = domain, smesh = smesh, tmesh = tmesh,
                        parameters = c(beta = 0, log_tau = log(1),
                                       log_kappa = log(1), atanh_rho = 0.2))
        pars <- as.numeric(get_coefs(fit)[, 1])
        expect_equal(pars[1], 0.31, tolerance = 1)
        expect_equal(pars[2], 1.68, tolerance = 1)
        expect_equal(pars[3], -1.06, tolerance = 1)
    }
})
test_that("Simulate LGCP (spatiotemporal)", {
    skip_on_cran()
    if(requireNamespace("fmesher")){
        data(xyt, package = "stelfi")
        domain <- sf::st_as_sf(xyt$window)
        bnd <- fmesher::fm_as_segm(as.matrix(sf::st_coordinates(domain)[, 1:2]))
        smesh <- fmesher::fm_mesh_2d(boundary = bnd, max.edge = 0.75, cutoff = 0.3)
        set.seed(91234)
        ndays <- 2
        w0 <- 2
        tmesh <-  fmesher::fm_mesh_1d(seq(0, ndays, by = w0))
        parameters <- c(beta = 1, log_tau = log(1), log_kappa = log(1), atanh_rho = 0.2)
        sim <- sim_lgcp(parameters = parameters, sf = domain, smesh = smesh, tmesh = tmesh)
        expect_equal(round(c(sim$x[1:3, 2]), 3), c(0.252, 0.674, 0.575), tolerance = 0.1)
        expect_equal(c(sim$y[1:3]), c(0, 0, 1), tolerance = 0.1)
    }
})
test_that("LGCP model fitting (marked)", {
    skip_on_cran()
    if(requireNamespace("fmesher")){
        data(marked, package = "stelfi")
        loc.d <- 3 * cbind(c(0, 1, 1, 0, 0), c(0, 0, 1, 1, 0))
        domain <-  sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(loc.d))))
        smesh <- fmesher::fm_mesh_2d(loc.domain = loc.d, offset = c(0.3, 1),
                                    max.edge = c(0.3, 0.7), cutoff = 0.05)
        locs <- cbind(x = marked$x, y = marked$y)
        marks <- cbind(m1 = marked$m1) ## Gaussian
        parameters <- list(betamarks = matrix(0, nrow = 1, ncol = ncol(marks)),
                           log_tau = log(1), log_kappa = log(1),
                           marks_coefs_pp = rep(0, ncol(marks)), betapp = 0)

        fit <- fit_mlgcp(locs = locs, marks = marks,
                         sf = domain, smesh = smesh,
                         parameters = parameters, methods = 0,
                         fields = 0)
        pars <- as.numeric(get_coefs(fit)[, 1])
        expect_equal(pars[1], 9.90, tolerance = 0.1)
        expect_equal(pars[3], -0.279, tolerance = 0.1)
    }
})
test_that("LGCP model fitting (marked) with covariate overlap", {
    skip_on_cran()
    if(requireNamespace("fmesher")){
        data(marked, package = "stelfi")
        loc.d <- 3 * cbind(c(0, 1, 1, 0, 0), c(0, 0, 1, 1, 0))
        domain <-  sf::st_sf(geometry = sf::st_sfc(sf::st_polygon(list(loc.d))))
        smesh <- fmesher::fm_mesh_2d(loc.domain = loc.d, offset = c(0.3, 1),
                                    max.edge = c(0.3, 0.7), cutoff = 0.05)
        locs <- cbind(x = marked$x, y = marked$y)
        marks <- cbind(m1 = marked$m1) ## Gaussian
        set.seed(132) 
        covs <- cbind(cov = rnorm(smesh$n))
        parameters <- list(betamarks = matrix(0, nrow = 2, ncol = ncol(marks)),
                   log_tau = log(1), log_kappa = log(1),
                   marks_coefs_pp = rep(0, ncol(marks)), betapp = c(0, 1))
        fit <- fit_mlgcp(locs = locs, marks = marks,
                 sf = domain, smesh = smesh,
                 parameters = parameters, methods = 0,
                 fields = 0, covariates = covs,
                 pp_covariates = 1,
                 marks_covariates = 1)
        pars <- as.numeric(get_coefs(fit)[, 1])
        expect_equal(pars[4], 0.08150350, tolerance = 0.1)
    }
})
test_that("Spatial self-exciting (no GMRF)", {
    skip_on_cran()
    if(requireNamespace("fmesher")){
        data(xyt, package = "stelfi")
        N <- 50
        locs <- data.frame(x = xyt$x[1:N], y = xyt$y[1:N])
        times <- xyt$t[1:N]
        domain <- sf::st_as_sf(xyt$window)
        bnd <- fmesher::fm_as_segm(as.matrix(sf::st_coordinates(domain)[, 1:2]))
        smesh <- fmesher::fm_mesh_2d(boundary = bnd,
                                    max.edge = 0.75, cutoff = 0.3)
        param <- list(mu = 3, alpha = 1, beta = 3, xsigma = 0.2,
                      ysigma = 0.2, rho = 0.8)
        fit <- fit_stelfi(times = times, locs = locs, sf = domain, smesh = smesh, parameters = param) 
        pars <- as.numeric(get_coefs(fit)[, 1])
        expect_equal(pars[1], 0.3, tolerance = 0.2)
        expect_equal(pars[2], -1.1, tolerance = 0.2)
        expect_equal(pars[7], -0.17, tolerance = 0.2)
    }
})
test_that("Spatial self-exciting (GMRF)", {
    skip_on_cran()
    if(requireNamespace("fmesher")){
        data(xyt, package = "stelfi")
        N <- 50
        locs <- data.frame(x = xyt$x[1:N], y = xyt$y[1:N])
        times <- xyt$t[1:N]
        domain <- sf::st_as_sf(xyt$window)
        bnd <- fmesher::fm_as_segm(as.matrix(sf::st_coordinates(domain)[, 1:2]))
        smesh <- fmesher::fm_mesh_2d(boundary = bnd,
                                    max.edge = 0.75, cutoff = 0.3)
        param <- list( mu = 5, alpha = 1, beta = 3, kappa = 0.9, tau = 1, xsigma = 0.2, ysigma = 0.2, rho = 0.8)
        fit <- fit_stelfi(times = times, locs = locs, sf = domain, smesh = smesh, parameters = param, GMRF = TRUE)
        pars <- as.numeric(get_coefs(fit)[, 1])
        expect_equal(pars[1], 0.003, tolerance = 0.02)
        expect_equal(pars[2], -5.88, tolerance = 0.2)
    }
})