test-platform.R
In dsem: Dynamic Structural Equation Models

test_that("dsem example is working ", {
  #skip_on_ci()
  data(KleinI, package="AER")
  TS = ts(data.frame(KleinI, "time"=time(KleinI) - 1931))

  # Specify by declaring each arrow and lag
  sem = "
    # Link, lag, param_name
    cprofits -> consumption, 0, a1
    cprofits -> consumption, 1, a2
    pwage -> consumption, 0, a3
    gwage -> consumption, 0, a3

    cprofits -> invest, 0, b1
    cprofits -> invest, 1, b2
    capital -> invest, 0, b3

    gnp -> pwage, 0, c2
    gnp -> pwage, 1, c3
    time -> pwage, 0, c1
  "
  tsdata = TS[,c("time","gnp","pwage","cprofits",'consumption',
                 "gwage","invest","capital")]

  # Fit model
  fit = dsem( sem=sem,
              tsdata=tsdata,
              control = dsem_control(getJointPrecision=TRUE) )
  # Check objective function
  expect_equal( as.numeric(fit$opt$obj), 431.6122, tolerance=1e-2 )

  #
  fitRTMB = dsemRTMB( sem=sem,
              tsdata=tsdata,
              control = dsem_control(getsd=FALSE) )
  # Check objective function
  expect_equal( as.numeric(fit$opt$obj), as.numeric(fitRTMB$opt$obj), tolerance=1e-2 )

  # Convert and plot using phylopath
  as_fitted_DAG(fit)

  # Various other utilities
  plot(fit)
  vcov(fit, which="fixed")
  vcov(fit, which="random")
  vcov(fit, which="both")
  print(fit)
  logLik(fit)
  total_effect(fit)
  as_sem(fit)
  predict(fit, type="link")
  predict(fit, type="response")
  predict(fit, type="link", newdata=tsdata)
  simulate(fit, variance = "none")
  simulate(fit, variance = "random")
  simulate(fit, variance = "both")
  simulate(fit, resimulate_gmrf=TRUE)

  # Refit with measurement errors .. ignore quality of fit, just checking that it runs
  fit1 = dsem( sem=sem,
               tsdata = tsdata,
               family = c("normal","gamma",rep("fixed",ncol(tsdata)-2)),
               control = dsem_control(getsd=FALSE,
                                      extra_convergence_checks = FALSE,
                                      newton_loops=0) )
  residuals(fit1, type="deviance")
  residuals(fit1, type="response")

  # Test equations including lags, starting values, and mirrored params
  equations = "
    consumption = a1(0.1)*cprofits + a2(0.1)*lag[cprofits,1]+ a3(0.1)*pwage + a3(0.2)*gwage
    invest = b1*cprofits + b2*lag[cprofits,1] + b3*capital
    pwage = c1*time + c2*gnp + c3*lag[gnp,1]
  "
  sem_equations = convert_equations(equations)
  # Fit model
  fit_equations = dsem( sem=sem_equations,
              tsdata=tsdata,
              control = dsem_control(getsd=FALSE) )
  # Check objective function
  expect_equal( as.numeric(fit$opt$obj), as.numeric(fit_equations$opt$obj), tolerance=1e-2 )
})

test_that("dsem adds variances ", {
  data(isle_royale)
  data = ts( log(isle_royale[,2:3]), start=1959)

  sem = "
    wolves <-> wolves, 0, sd1
    moose <-> moose, 0, sd2
  "
  # initial first without delta0 (to improve starting values)
  fit1 = dsem( sem = "",
               tsdata = data )
  # initial first without delta0 (to improve starting values)
  fit2 = dsem( sem = sem,
               tsdata = data )
  # Check objective function
  expect_equal( as.numeric(fit1$opt$obj), as.numeric(fit2$opt$obj), tolerance=1e-2 )
})

test_that("dsem works with fixed variances ", {
  data(isle_royale)
  data = ts( log(isle_royale[,2:3]), start=1959)

  # initial first without delta0 (to improve starting values)
  sem = "
    wolves <-> wolves, 0, sd1
    moose <-> moose, 0, sd2
    wolves -> wolves, 1, rho1
    moose -> moose, 1, rho2
  "
  fit1 = dsem( sem = sem,
               tsdata = data )

  # initial first without delta0 (to improve starting values)
  sem = "
    wolves <-> wolves, 0, NA, 0.3732812
    moose <-> moose, 0, NA, 0.1911209
    wolves -> wolves, 1, NA, 0.8558536
    moose -> moose, 1, NA, 0.9926087
  "
  fit2 = dsem( sem = sem,
               tsdata = data,
               family = c("normal", "normal") )

  # initial first without delta0 (to improve starting values)
  sem = "
    wolves <-> wolves, 0, NA, 0.3732812
    moose <-> moose, 0, NA, 0.1911209
    wolves -> wolves, 1, NA, 0.8558536
    moose -> moose, 1, NA, 0.9926087
  "
  fit3 = dsemRTMB( sem = sem,
               tsdata = data,
               family = c("normal", "normal") )

  # Check objective function
  expect_equal( as.numeric(fit1$opt$obj), as.numeric(fit2$opt$obj), tolerance=1e-2 )
  expect_equal( as.numeric(fit1$opt$obj), as.numeric(fit3$opt$obj), tolerance=1e-2 )
})

test_that("bering sea example is stable ", {
  data(bering_sea)

  #
  Z = ts( bering_sea )
  family = rep( "fixed", ncol(bering_sea) )

  # Specify model
  sem = "
    log_seaice -> log_CP, 0, seaice_to_CP
    log_CP -> log_Cfall, 0, CP_to_Cfall
    log_CP -> log_Esummer, 0, CP_to_E
    log_PercentEuph -> log_RperS, 0, Seuph_to_RperS
    log_PercentCop -> log_RperS, 0, Scop_to_RperS
    log_Esummer -> log_PercentEuph, 0, Esummer_to_Suph
    log_Cfall -> log_PercentCop, 0, Cfall_to_Scop
    SSB -> log_RperS, 0, SSB_to_RperS

    log_seaice -> log_seaice, 1, AR1, 0.001
    log_CP -> log_CP, 1,  AR2, 0.001
    log_Cfall -> log_Cfall, 1, AR4, 0.001
    log_Esummer -> log_Esummer, 1, AR5, 0.001
    SSB -> SSB, 1, AR6, 0.001
    log_RperS ->  log_RperS, 1, AR7, 0.001
    log_PercentEuph -> log_PercentEuph, 1, AR8, 0.001
    log_PercentCop -> log_PercentCop, 1, AR9, 0.001
  "

  # Run model
  fit = dsem( sem=sem,
               tsdata=Z,
               family=family,
               control = dsem_control(use_REML=FALSE) )

  # Check objective function
  expect_equal( as.numeric(fit$opt$obj), 189.3005, tolerance=1e-2 )
})

test_that("Fixing parameters works ", {
  sem = "
    A -> B, 0, NA, 1
    B -> C, 0, NA, 0.5
    # Extra links
    A -> D, 1, beta
    B -> D, 1, beta
  "
  set.seed(101)
  nobs = 40
  A = rnorm(nobs)
  B = A + rnorm(nobs)
  C = 0.5 * B + rnorm(nobs)
  D = rnorm(nobs)
  tsdata = ts(cbind(A=A, B=B, C=C, D=D))

  # Run models
  fit = dsem( sem=sem,
               tsdata=tsdata,
               control = dsem_control(getsd=FALSE) )
  fitRTMB = dsemRTMB( sem=sem,
               tsdata=tsdata,
               control = dsem_control(getsd=FALSE) )
  # Check objective function
  expect_equal( as.numeric(fit$opt$obj), 224.2993, tolerance=1e-2 )
  expect_equal( as.numeric(fit$opt$obj), as.numeric(fitRTMB$opt$obj), tolerance=1e-2 )

})