tests/testthat/setup-init.R

In latrend: A Framework for Clustering Longitudinal Data

options(deparse.max.lines=5)

options(latrend.id = 'Traj')
options(latrend.time = 'Assessment')
options(latrend.verbose = R.utils::Verbose())
options(latrend.warnModelDataClusterColumn = FALSE)
options(latrend.warnNewDataClusterColumn = FALSE)
options(latrend.warnTrajectoryLength = 0)

DEFAULT_LATREND_TESTS = c('method', 'basic', 'fitted', 'predict', 'cluster-single', 'cluster-three', 'data-na', 'data-varlen')

foreach::registerDoSEQ()

# remove kml cld file from possible previous failed run
if (file.exists('cld.Rdata')) {
  file.remove('cld.Rdata')
}

# one of the cluster methods is altering the RNG kind, so reset it for each context
rngReset = function() {
  RNGkind('Mersenne-Twister', 'Inversion', 'Rejection')
}

mixt_file = file.path('..', '..', 'MixTVEM.R')
if(file.exists(mixt_file)) {
  source(mixt_file)
}

expect_valid_lcModel = function(object) {
  expect_s4_class(object, 'lcModel')
  expect_true(is.count(nClusters(object)))

  # clusters
  # change cluster names to ensure the model implementations correctly handle this
  clusNames = paste0('T', seq_len(nClusters(object)))
  clusterNames(object) = clusNames
  expect_is(clusterNames(object), 'character')
  expect_length(clusterNames(object), nClusters(object))
  expect_equal(clusterNames(object), clusNames)
  expect_is(clusterSizes(object), 'integer')
  expect_true(all(clusterSizes(object) >= 0))
  expect_is(clusterProportions(object), 'numeric')
  expect_gte(min(clusterProportions(object)), 0)
  expect_lte(max(clusterProportions(object)), 1)

  expect_is(getCall(object), 'call')
  expect_is(getName(object), 'character')
  expect_is(getShortName(object), 'character')
  expect_is(idVariable(object), 'character')
  expect_is(timeVariable(object), 'character')
  expect_is(responseVariable(object), 'character')
  expect_is(coef(object), c('numeric', 'matrix', 'list', 'NULL'), label='coef')
  expect_is(converged(object), c('logical', 'numeric', 'integer'), label='converged')

  expect_true(is.count(nobs(object)))

  expect_true(is.count(nIds(object)))
  expect_length(ids(object), nIds(object))

  expect_true(is.numeric(time(object)))
  expect_gt(length(time(object)), 0)

  expect_is(deviance(object), 'numeric')
  expect_true(is.numeric(df.residual(object)))
  expect_is(logLik(object), 'logLik')
  expect_is(sigma(object), 'numeric')
  expect_gte(estimationTime(object), 0)
  expect_is(formula(object), 'formula')


  # model.data
  expect_is(model.data(object), 'data.frame')
  expect_true(has_name(model.data(object), c(
    idVariable(object),
    timeVariable(object),
    responseVariable(object))))

  # Posterior
  pp = postprob(object)
  expect_true(is_valid_postprob(pp, object))

  clus = trajectoryAssignments(object)
  expect_is(clus, 'factor')
  expect_length(clus, nIds(object))
  expect_gte(min(as.integer(clus)), 1)
  expect_lte(max(as.integer(clus)), nIds(object))

  # Predict
  # cluster-specific prediction
  pred = predict(object, newdata=data.frame(Cluster='T1', Assessment=time(object)[c(1,3)]))
  expect_is(pred, 'data.frame', info='predictClusterTime')
  expect_true('Fit' %in% names(pred), info='predictClusterTime')
  expect_equal(nrow(pred), 2, info='predictClusterTime')

  # prediction for all clusters; list of data.frames
  pred2 = predict(object, newdata=data.frame(Assessment=time(object)[c(1,3)]))
  expect_is(pred2, 'list', info='predictTime')
  expect_length(pred2, nClusters(object))
  expect_true('Fit' %in% names(pred2$T1), info='predictTime')

  # id-specific prediction for a specific cluster; data.frame
  pred3 = predict(object, newdata=data.frame(Cluster=rep('T1', 4),
                                     Traj=c(ids(object)[c(1,1,2)], tail(ids(object), 1)),
                                     Assessment=c(time(object)[c(1,3,1,1)])))
  expect_is(pred3, 'data.frame', info='predictClusterIdTime')
  expect_true('Fit' %in% names(pred3), info='predictClusterIdTime')
  expect_equal(nrow(pred3), 4, info='predictClusterIdTime')

  # id-specific prediction for all clusters; list of data.frames
  pred4 = predict(object, newdata=data.frame(Traj=c(ids(object)[c(1,1,2)], tail(ids(object), 1)),
                                     Assessment=c(time(object)[c(1,3,1,1)])))
  expect_is(pred4, 'list', info='predictIdTime')
  expect_length(pred4, nClusters(object))
  expect_true('Fit' %in% names(pred4$T1), info='predictIdTime')

  fitted(object, clusters=trajectoryAssignments(object)) %>%
    expect_is(c('NULL', 'numeric'), info='fittedClusters')
  fitted(object, clusters=NULL) %>%
    expect_is(c('NULL', 'matrix'), info='fittedNull')

  predNul = predict(object, newdata=NULL)
  expect_is(predNul, 'list', info='predictNull')
  expect_length(predNul, nClusters(object))
  expect_true('Fit' %in% names(predNul$T1), info='predictNull')

  # predictForCluster
  predClus = predictForCluster(
    object,
    newdata = data.frame(Assessment = time(object)[c(1,3)]),
    cluster = 'T1'
  )
  expect_is(predClus, 'numeric', info='predictForCluster')
  expect_length(predClus, 2)

  # empty predictForCluster prediction
  predClusNull = predictForCluster(object, cluster = 'T1')
  predClusNull2 = predictForCluster(object, newdata = NULL, cluster = 'T1')
  predClusFitted = predictForCluster(object, newdata = model.data(object), cluster = 'T1')
  expect_equal(predClusNull, predClusNull2)
  expect_equal(predClusNull2, predClusFitted)

  residuals(object, clusters=trajectoryAssignments(object)) %>%
    expect_is(c('NULL', 'numeric'), label='residuals')
  residuals(object, clusters=NULL) %>%
    expect_is(c('NULL', 'matrix'), label='residuals')

  # Derivative predict
  ctPred = clusterTrajectories(object)
  expect_is(ctPred, 'data.frame', label='clusterTrajectories')

  fittedTrajectories(object) %>%
    expect_is(c('NULL', 'data.frame'), label='fittedTrajectories')
  trajectories(object) %>%
    expect_is('data.frame', label='trajectories')

  if (requireNamespace('ggplot2', quietly = TRUE)) {
    expect_true(is.ggplot(plot(object)))
  }

  # Misc
  summary(object) %>%
    expect_is('lcSummary')
  expect_output(print(object))

  newObject = strip(object)
  expect_is(newObject, class(object))

  return(object)
}