[r-cran-lava] 01/02: New upstream version 1.5.1
Andreas Tille
tille at debian.org
Sun Oct 22 20:47:12 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-lava.
commit 1ba2f139ea1d760f232211c351ff391e52b5a7d1
Author: Andreas Tille <tille at debian.org>
Date: Sun Oct 22 22:46:06 2017 +0200
New upstream version 1.5.1
---
DESCRIPTION | 37 ++
INDEX | 176 +++++++
MD5 | 294 +++++++++++
NAMESPACE | 657 ++++++++++++++++++++++++
NEWS | 263 ++++++++++
R/By.R | 39 ++
R/Col.R | 35 ++
R/Expand.R | 38 ++
R/Inverse.R | 41 ++
R/Missing.R | 84 ++++
R/Objective.R | 276 +++++++++++
R/addattr.R | 38 ++
R/addhook.R | 116 +++++
R/addvar.R | 105 ++++
R/assoc.R | 213 ++++++++
R/backdoor.R | 84 ++++
R/baptize.R | 61 +++
R/blockdiag.R | 24 +
R/bootstrap.R | 195 ++++++++
R/cancel.R | 53 ++
R/categorical.R | 55 ++
R/children.R | 140 ++++++
R/cluster.hook.R | 87 ++++
R/coef.R | 765 ++++++++++++++++++++++++++++
R/combine.R | 65 +++
R/commutation.R | 24 +
R/compare.R | 187 +++++++
R/complik.R | 129 +++++
R/confband.R | 283 +++++++++++
R/confint.R | 72 +++
R/confpred.R | 68 +++
R/constrain.R | 423 ++++++++++++++++
R/contr.R | 36 ++
R/correlation.R | 103 ++++
R/covariance.R | 304 ++++++++++++
R/csplit.R | 44 ++
R/curly.R | 88 ++++
R/cv.R | 102 ++++
R/deriv.R | 222 +++++++++
R/describecoef.R | 28 ++
R/devcoords.R | 30 ++
R/diagtest.R | 208 ++++++++
R/distribution.R | 459 +++++++++++++++++
R/dsep.R | 76 +++
R/effects.R | 228 +++++++++
R/endogenous.R | 51 ++
R/equivalence.R | 140 ++++++
R/estimate.default.R | 759 ++++++++++++++++++++++++++++
R/estimate.lvm.R | 883 +++++++++++++++++++++++++++++++++
R/estimate.multigroup.R | 649 ++++++++++++++++++++++++
R/eventTime.R | 428 ++++++++++++++++
R/exogenous.R | 91 ++++
R/finalize.R | 211 ++++++++
R/fix.R | 516 +++++++++++++++++++
R/fixsome.R | 107 ++++
R/formula.R | 21 +
R/fplot.R | 58 +++
R/functional.R | 49 ++
R/gkgamma.R | 133 +++++
R/glmest.R | 348 +++++++++++++
R/gof.R | 386 ++++++++++++++
R/graph.R | 49 ++
R/graph2lvm.R | 12 +
R/heavytail.R | 56 +++
R/iid.R | 122 +++++
R/img.R | 128 +++++
R/index.sem.R | 303 +++++++++++
R/information.R | 235 +++++++++
R/interactive.R | 106 ++++
R/iv.R | 323 ++++++++++++
R/kappa.R | 32 ++
R/kill.R | 81 +++
R/ksmooth.R | 137 +++++
R/labels.R | 398 +++++++++++++++
R/latent.R | 70 +++
R/lava-package.R | 256 ++++++++++
R/lisrel.R | 49 ++
R/lmers.R | 62 +++
R/logLik.R | 350 +++++++++++++
R/logo.R | 33 ++
R/lvm.R | 110 ++++
R/makemissing.R | 22 +
R/manifest.R | 34 ++
R/matrices.R | 515 +++++++++++++++++++
R/measurement.R | 26 +
R/measurement.error.R | 75 +++
R/merge.R | 164 ++++++
R/missingMLE.R | 292 +++++++++++
R/model.R | 55 ++
R/model.frame.R | 18 +
R/modelPar.R | 122 +++++
R/modelVar.R | 20 +
R/modelsearch.R | 308 ++++++++++++
R/moments.R | 72 +++
R/multigroup.R | 330 ++++++++++++
R/multinomial.R | 241 +++++++++
R/multipletesting.R | 70 +++
R/nodecolor.R | 39 ++
R/nonlinear.R | 144 ++++++
R/normal.R | 178 +++++++
R/onload.R | 16 +
R/operators.R | 63 +++
R/optims.R | 229 +++++++++
R/ordinal.R | 294 +++++++++++
R/ordreg.R | 161 ++++++
R/parameter.R | 47 ++
R/parlabels.R | 12 +
R/parpos.R | 77 +++
R/pars.R | 62 +++
R/parsedesign.R | 89 ++++
R/partialcor.R | 58 +++
R/path.R | 245 +++++++++
R/pcor.R | 170 +++++++
R/pdfconvert.R | 39 ++
R/plot.R | 426 ++++++++++++++++
R/plot.estimate.R | 29 ++
R/plotConf.R | 382 ++++++++++++++
R/predict.R | 332 +++++++++++++
R/print.R | 211 ++++++++
R/procformula.R | 175 +++++++
R/profile.R | 66 +++
R/randomslope.R | 80 +++
R/regression.R | 268 ++++++++++
R/residuals.R | 42 ++
R/revdiag.R | 72 +++
R/scheffe.R | 33 ++
R/score.R | 162 ++++++
R/score.survreg.R | 47 ++
R/sim.default.R | 738 +++++++++++++++++++++++++++
R/sim.lvm.R | 756 ++++++++++++++++++++++++++++
R/spaghetti.R | 220 ++++++++
R/stack.R | 49 ++
R/startvalues.R | 388 +++++++++++++++
R/subgraph.R | 19 +
R/subset.R | 54 ++
R/summary.R | 183 +++++++
R/timedep.R | 85 ++++
R/toformula.R | 37 ++
R/tr.R | 29 ++
R/transform.R | 99 ++++
R/trim.R | 13 +
R/twostage.R | 374 ++++++++++++++
R/utils.R | 443 +++++++++++++++++
R/variances.R | 20 +
R/vars.R | 105 ++++
R/vcov.R | 19 +
R/vec.R | 26 +
R/weights.R | 5 +
R/wrapvec.R | 16 +
R/zcolorbar.R | 68 +++
R/zgetmplus.R | 248 +++++++++
R/zgetsas.R | 44 ++
R/zib.R | 397 +++++++++++++++
R/zorg.R | 72 +++
data/bmd.rda | Bin 0 -> 2055 bytes
data/bmidata.rda | Bin 0 -> 39870 bytes
data/brisa.rda | Bin 0 -> 16020 bytes
data/calcium.rda | Bin 0 -> 6225 bytes
data/hubble.rda | Bin 0 -> 542 bytes
data/hubble2.rda | Bin 0 -> 605 bytes
data/indoorenv.rda | Bin 0 -> 18846 bytes
data/missingdata.rda | Bin 0 -> 32960 bytes
data/nldata.rda | Bin 0 -> 1353 bytes
data/nsem.rda | Bin 0 -> 27193 bytes
data/semdata.rda | Bin 0 -> 15976 bytes
data/serotonin.rda | Bin 0 -> 27313 bytes
data/serotonin2.rda | Bin 0 -> 28477 bytes
data/twindata.rda | Bin 0 -> 58896 bytes
demo/00Index | 5 +
demo/estimation.R | 3 +
demo/inference.R | 5 +
demo/lava.R | 5 +
demo/model.R | 6 +
demo/simulation.R | 2 +
inst/CITATION | 30 ++
inst/doc/reference.pdf | Bin 0 -> 140894 bytes
inst/gof1.png | Bin 0 -> 48621 bytes
inst/lava1.png | Bin 0 -> 20732 bytes
inst/me1.png | Bin 0 -> 6316 bytes
inst/mediation1.png | Bin 0 -> 15305 bytes
inst/mediation2.png | Bin 0 -> 31274 bytes
man/By.Rd | 34 ++
man/Col.Rd | 34 ++
man/Combine.Rd | 28 ++
man/Expand.Rd | 31 ++
man/Graph.Rd | 35 ++
man/Missing.Rd | 76 +++
man/Model.Rd | 38 ++
man/Org.Rd | 50 ++
man/PD.Rd | 40 ++
man/Range.lvm.Rd | 22 +
man/addvar.Rd | 20 +
man/backdoor.Rd | 28 ++
man/baptize.Rd | 19 +
man/blockdiag.Rd | 25 +
man/bmd.Rd | 19 +
man/bmidata.Rd | 11 +
man/bootstrap.Rd | 22 +
man/bootstrap.lvm.Rd | 80 +++
man/brisa.Rd | 14 +
man/calcium.Rd | 19 +
man/cancel.Rd | 20 +
man/children.Rd | 26 +
man/click.Rd | 61 +++
man/closed.testing.Rd | 44 ++
man/colorbar.Rd | 52 ++
man/commutation.Rd | 20 +
man/compare.Rd | 50 ++
man/complik.Rd | 46 ++
man/confband.Rd | 96 ++++
man/confint.lvmfit.Rd | 71 +++
man/confpred.Rd | 47 ++
man/constrain-set.Rd | 195 ++++++++
man/contr.Rd | 31 ++
man/correlation.Rd | 19 +
man/covariance.Rd | 120 +++++
man/csplit.Rd | 34 ++
man/curly.Rd | 51 ++
man/cv.Rd | 42 ++
man/density.sim.Rd | 35 ++
man/devcoords.Rd | 26 +
man/diagtest.Rd | 45 ++
man/dsep.lvm.Rd | 39 ++
man/equivalence.Rd | 34 ++
man/estimate.default.Rd | 201 ++++++++
man/estimate.lvm.Rd | 150 ++++++
man/eventTime.Rd | 143 ++++++
man/fplot.Rd | 37 ++
man/getMplus.Rd | 24 +
man/getSAS.Rd | 35 ++
man/gof.Rd | 104 ++++
man/hubble.Rd | 15 +
man/hubble2.Rd | 14 +
man/iid.Rd | 35 ++
man/images.Rd | 70 +++
man/indoorenv.Rd | 14 +
man/intercept.Rd | 82 +++
man/internal.Rd | 80 +++
man/ksmooth2.Rd | 55 ++
man/labels-set.Rd | 80 +++
man/lava-package.Rd | 20 +
man/lava.options.Rd | 43 ++
man/lvm.Rd | 47 ++
man/makemissing.Rd | 30 ++
man/measurement.error.Rd | 58 +++
man/missingdata.Rd | 30 ++
man/modelsearch.Rd | 46 ++
man/multinomial.Rd | 77 +++
man/nldata.Rd | 14 +
man/nsem.Rd | 14 +
man/op_concat.Rd | 37 ++
man/op_match.Rd | 32 ++
man/ordreg.Rd | 36 ++
man/parpos.Rd | 19 +
man/partialcor.Rd | 38 ++
man/path.Rd | 82 +++
man/pcor.Rd | 22 +
man/pdfconvert.Rd | 39 ++
man/plot.lvm.Rd | 104 ++++
man/plotConf.Rd | 119 +++++
man/predict.lvm.Rd | 52 ++
man/predictlvm.Rd | 39 ++
man/regression-set.Rd | 135 +++++
man/revdiag.Rd | 30 ++
man/rmvar.Rd | 42 ++
man/scheffe.Rd | 33 ++
man/semdata.Rd | 14 +
man/serotonin.Rd | 35 ++
man/serotonin2.Rd | 17 +
man/sim.Rd | 289 +++++++++++
man/sim.default.Rd | 84 ++++
man/spaghetti.Rd | 94 ++++
man/stack.estimate.Rd | 33 ++
man/subset.lvm.Rd | 34 ++
man/timedep.Rd | 77 +++
man/toformula.Rd | 33 ++
man/tr.Rd | 31 ++
man/trim.Rd | 21 +
man/twindata.Rd | 23 +
man/twostage.Rd | 19 +
man/twostage.lvmfit.Rd | 126 +++++
man/vars.Rd | 106 ++++
man/vec.Rd | 26 +
man/wrapvec.Rd | 21 +
man/zibreg.Rd | 74 +++
tests/test-all.R | 4 +
tests/testthat/test-constrain.R | 133 +++++
tests/testthat/test-estimate_default.R | 55 ++
tests/testthat/test-graph.R | 15 +
tests/testthat/test-inference.R | 514 +++++++++++++++++++
tests/testthat/test-misc.R | 125 +++++
tests/testthat/test-model.R | 123 +++++
tests/testthat/test-multigroup.R | 95 ++++
tests/testthat/test-plot.R | 192 +++++++
tests/testthat/test-sim.R | 183 +++++++
295 files changed, 32794 insertions(+)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..2b0fff6
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,37 @@
+Package: lava
+Type: Package
+Title: Latent Variable Models
+Version: 1.5.1
+Date: 2017-09-25
+Authors at R: c(person("Klaus K.", "Holst", email="klaus at holst.it", role=c("aut", "cre")),
+ person("Brice", "Ozenne", role = "ctb"),
+ person("Thomas", "Gerds", role = "ctb"))
+Author: Klaus K. Holst [aut, cre],
+ Brice Ozenne [ctb],
+ Thomas Gerds [ctb]
+Maintainer: Klaus K. Holst <klaus at holst.it>
+Description: A general implementation of Structural Equation Models
+ with latent variables (MLE, 2SLS, and composite likelihood
+ estimators) with both continuous, censored, and ordinal
+ outcomes (Holst and Budtz-Joergensen (2013)
+ <doi:10.1007/s00180-012-0344-y>). The package also provides
+ methods for graph exploration (d-separation, back-door criterion),
+ simulation of general non-linear latent variable models, and
+ estimation of influence functions for a broad range of statistical
+ models.
+URL: https://github.com/kkholst/lava
+BugReports: https://github.com/kkholst/lava/issues
+License: GPL-3
+LazyLoad: yes
+Depends: R (>= 3.0)
+Imports: grDevices, graphics, methods, numDeriv, stats, survival, utils
+Suggests: KernSmooth, Matrix, Rgraphviz, ascii, data.table, fields,
+ foreach, geepack, gof (>= 0.9), graph, igraph (>= 0.6),
+ lava.tobit, lme4, mets (>= 1.1), optimx, quantreg, rgl,
+ testthat (>= 0.11), visNetwork, zoo
+ByteCompile: yes
+RoxygenNote: 6.0.1
+NeedsCompilation: no
+Packaged: 2017-09-27 20:46:26 UTC; klaus
+Repository: CRAN
+Date/Publication: 2017-09-27 21:25:09 UTC
diff --git a/INDEX b/INDEX
new file mode 100644
index 0000000..8c1490d
--- /dev/null
+++ b/INDEX
@@ -0,0 +1,176 @@
+* Estimation and simulation of latent variable models
+
+** Model building
+
+addvar Add variable to (model) object
+adjMat Extract adjancey matrix from model/graph
+ancestors Extract ancestors of nodes
+baptize Label elements of object
+cancel Generic cancel method
+categorical Define categorical variables (predictors)
+children Extract children or parent elements of object
+constrain<- Add non-linear constraints to latent variable model
+covariance Add covariance structure to Latent Variable Model
+descendants Extract descendants of nodes
+describecoef Show parameter names
+edgeList Extract edge list from model/graph
+edgelabels Define labels on edges of graph
+eventTime Add an observed event time outcome to a latent variable model.
+fixsome Constrain parameters in measurement models (identifiability)
+functional Add non-linear associations (for simulation only)
+intercept Fix mean parameters in 'lvm'-object
+rmvar Remove variables from (model) object.
+labels<- Define labels of graph
+lvm Initialize new latent variable model
+makemissing Create random missing data
+measurement Extract measurement models
+merge Merge model objects (lvm, estimate, ...)
+multigroup Define multiple group object
+nodecolor Set node colours
+ordinal Define variables as ordinal
+parameter Define additional parameters of the model
+parpos Generic method for finding indeces of model parameters
+parents Extract parents of nodes
+path Extract pathways in model graph
+plot.lvm Plot path diagram
+Range.lvm Define range constraints of parameters
+regression<- Add regression association to latent variable model
+subset.lvm Extract subset of latent variable model
+timedep Time-dependent parameters
+transform Create non-linear parameter constraints
+vars Extract variable names from latent variable model
+
+** Model inference
+
+backdoor Check backdoor criterion
+bootstrap Generic bootstrap method
+bootstrap.lvm Calculate bootstrap estimates of a lvm object
+closed.testing Closed testing procedure
+confint.lvmfit Calculate confidence limits for parameters
+contr Create contrast matrices
+compare Statistical tests Performs Likelihood-ratio, Wald and score tests
+complik Composite likelihood inference
+confpred Conformal prediction limits
+correlation Generic method for extracting correlation coefficients of model object
+cv Cross-validation function
+dsep Check d-separation criterion in graph
+equivalence Identify candidates of equivalent models
+effects Mediation; calculate indirect, direct and total effects
+estimate.default Aggregation of parameters and data
+estimate.lvm Estimation of parameters in a Latent Variable Model (lvm)
+gof Extract model summaries and GOF statistics for model object
+gkgamma Kruskal-Gamma for contigency tables
+Graph Extract graph
+iid Extract i.i.d. decomposition (influence function) from model object
+IV Instrumental variables estimator (2SLS)
+kappa Cohens kappa
+lava.options Set global options for 'lava'
+measurement.error Two-stage estimator for (non-linear) measurement error models
+Model Extract model
+modelsearch Model searching
+moments Estimate model-specific mean and variance
+multinomial Estimate probabilities in contingency table
+nonlinear Define non-linear associations (see 'twostage')
+ordreg Ordinal regression models
+partialcor Calculate partial correlations
+p.correct Multiple testing adjustment
+pcor Polychoric correlations
+plot.estimate Forest-plot or regression line plot
+predict.lvm Prediction in structural equation models
+profile Profile likelihood
+residuals Extract residuals
+riskcomp Calculate association measure (see also 'OR','logor','Diff','Ratio')
+scheffe Simulatenous confidence bands (lm)
+score Extract score function of model fit
+stack.estimate Stack estimating equations
+sim Simulate model
+sim.default Wrapper function for mclapply
+startvalues Starting values
+twostage Two-stage estimator (non-linear SEM)
+zibreg Regression model for binomial data with unknown group of unaffected
+
+
+** Utilities
+
+%++% Concatenation operator
+%ni% Matching operator (x not in y) oposed to the '%in%'-operator (x in y)
+By Apply a Function to a Data Frame Split by Factors
+click Identify points on plot
+Col Generate a transparent RGB color
+Combine Report estimates across different models
+commutation Finds the unique commutation matrix
+csplit Define random folds of data
+curly Add curly brackets to plot
+dsort Sort data.frame
+Expand Create a Data Frame from All Combinations of Factors
+fplot Faster plots of large data via rgl
+getSAS Read SAS output (ODS)
+getMplus Read Mplus output
+Inverse Generalized inverse
+ksmooth2 Estimate and visualize bivariate density
+PD Dose response calculation for binomial regression models
+blockdiag Combine matrices to block diagonal structure
+colsel Select colour(s) interactively
+colorbar Add colorbar to plot
+confband Add Confidence limits bar to plot
+devcoords Returns device-coordinates and plot-region
+diagtest Calculate diagnostic tests for 2x2 table
+images Organize several image calls (for visualizing categorical data)
+org Convert object to ascii suitable for org-mode
+parsedesign Create contrast matrix from expression
+plotConf Plot regression lines
+pdfconvert Convert pdf to raster format
+procformula Process formula
+revdiag Create/extract 'reverse'-diagonal matrix
+surface Visualize function surface
+offdiag Extract or set off-diagonal elements of matrix
+density.sim Plot sim object
+spaghetti Plot longitudinal data
+toformula Converts strings to formula
+tr Trace operator
+trim Trim tring of (leading/trailing/all) white spaces
+vec vec operator
+wrapvec Wrap vector
+
+** Distributions
+
+Missing Add missing mechanism to model
+normal.lvm
+lognormal.lvm
+poisson.lvm
+threshold.lvm
+binomial.lvm
+Gamma.lvm
+loggamma.lvm
+chisq.lvm
+student.lvm
+uniform.lvm
+weibull.lvm
+sequence.lvm
+ones.lvm
+beta.lvm
+GM2.lvm
+GM3.lvm
+coxWeibull.lvm
+coxExponential.lvm
+aalenExponential.lvm
+coxGompertz.vlm
+heavytail.lvm
+
+** Datasets
+
+bmd Longitudinal Bone Mineral Density Data (Wide format)
+bmidata Data
+brisa Simulated data
+calcium Longitudinal Bone Mineral Density Data
+hubble Hubble data
+hubble2 Hubble data
+indoorenv Data
+nldata Example data (nonlinear model)
+missingdata Data
+nsem Example SEM data (nonlinear)
+semdata Example SEM data
+serotonin Serotonin data
+serotonin2 Data
+twindata Twin menarche data
+
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..38dd65a
--- /dev/null
+++ b/MD5
@@ -0,0 +1,294 @@
+2ff53cf278f30b4ffd7a581864a2f47f *DESCRIPTION
+def520b46e6cd102a3ffc94fb612ee26 *INDEX
+931dae519ef7e5ee078d96e529364630 *NAMESPACE
+f5836f640076195bb30176226ab241f9 *NEWS
+de70ed42553dacc167440662306d453d *R/By.R
+a28c3044137e563c2f000316b7ffbe64 *R/Col.R
+9a51c793e1a8d12fa5af4ea0229b5017 *R/Expand.R
+22d4e0984057695668cd3cb5e55e43f6 *R/Inverse.R
+89669eb70adbdca87251eeb515d85b67 *R/Missing.R
+1c61fa147f434e81c69998a142a7ed00 *R/Objective.R
+6a9ee095d2e81d57a534c595c30ef03f *R/addattr.R
+9143ad9952a41c4742c905254d9dd2ad *R/addhook.R
+f142b25d770eda822137f43728298167 *R/addvar.R
+f8f295b3171092ca97c8b1202d2996d5 *R/assoc.R
+3d6aeb202d89bce384583e53f0522571 *R/backdoor.R
+2c713c785c9da9613d58c6034d6dc5dd *R/baptize.R
+c9c640ae87a1af46daf4a4fe454757b9 *R/blockdiag.R
+eac8d3811c1186a8a00d3bb15746e61b *R/bootstrap.R
+1bd364979f05497599c7fb8ce094ce40 *R/cancel.R
+f69a41842da6a838a2db5e6957a14b04 *R/categorical.R
+a4b72e7ad50a0dc80551b66f96e5138d *R/children.R
+945b2afeecf1eed2ef82f0f736d21919 *R/cluster.hook.R
+6f4da8f23dedf1fe9786376045d99a0a *R/coef.R
+6e8dbf38779cf07c3a4c5c58396c49e1 *R/combine.R
+387f2f8f28d2d4b59fea63608ed4e39f *R/commutation.R
+aacc413fd9349ee72ff8701b27d37e0d *R/compare.R
+ee4f6598af67bf089a462a16e0f7c707 *R/complik.R
+e8b3cd107f63360971ba2087bb45969b *R/confband.R
+a9b73063d64badca12b7021f0c6f134a *R/confint.R
+f90bd480c4a5f07b7f05538155909243 *R/confpred.R
+1f4f99a645e51516199c70bed6ff1f35 *R/constrain.R
+58b433ace6f2831f55b881d67b8938c1 *R/contr.R
+18818cc1a617a54d96c81f472b73b99c *R/correlation.R
+6d6eb854e8d76237a8dd267ae543379e *R/covariance.R
+87acc8a71389f25378545f92e843eab8 *R/csplit.R
+dc0717bc8026b72ea0018ef90d8caa72 *R/curly.R
+3a9a7d53ba1497161c7c79f36ccf2db2 *R/cv.R
+72f7b3ea4c352962557893fc3d518c17 *R/deriv.R
+67c8a5cf9dffbd180a8aec04e18107dd *R/describecoef.R
+bb75525bd21d13dfbb201f7407f89eb5 *R/devcoords.R
+a4b18c13c8658f4553c1175e3714b9dd *R/diagtest.R
+a87b0c9b135f64769fb8e0b581f65d00 *R/distribution.R
+8e3686d1aaa6ac9e6d44045656344883 *R/dsep.R
+70cfabe32f609b73d84bd7695cdcebd4 *R/effects.R
+baaacdcc552d9f9d5f7d1e741a8daed0 *R/endogenous.R
+f1dcf24633de1ad49bc900c146532eb0 *R/equivalence.R
+1808b14202a4615d9765f105fb92408d *R/estimate.default.R
+5afd74cef559e406c74373379334a3e4 *R/estimate.lvm.R
+5c15c5615fb22627e345efc5797cf24f *R/estimate.multigroup.R
+3cc9e9eca7b49f6348b914f43f4a691b *R/eventTime.R
+23afb04c3e40a26ee7cc042274743260 *R/exogenous.R
+263cda8ca8b6a10911763c116ca920ef *R/finalize.R
+3f4a3d38dec2d5d47452688405a03be1 *R/fix.R
+f7a7c3c522bc47dfaefacc6b1288567c *R/fixsome.R
+1d9f68603528e78289d344ec18942c18 *R/formula.R
+c0320cf197286da6c9477835d67adf6f *R/fplot.R
+b888ed920f3d9ff950f3b6205ae2199e *R/functional.R
+772614bf89fe4701e9f363d7640aa6c6 *R/gkgamma.R
+12ce3e50b224f4c1634ccdd00e4d79a3 *R/glmest.R
+447ed56995089cf15c9db528ddd62e8f *R/gof.R
+e1c53c33331a3f7aef842614f5d9d89e *R/graph.R
+2c34bd9716abfd5a374c769c52ef3abd *R/graph2lvm.R
+fdfb462e975439a61e488ecb8813c58d *R/heavytail.R
+b0e926ba810288c05c2aafc6cc8e757d *R/iid.R
+9288f38680de6116e651214852cf1612 *R/img.R
+9492afb80e5d9870b8c8ccf78606b0f9 *R/index.sem.R
+557186211f33298080cbd131a0bcc994 *R/information.R
+c0f4a426e46a1ec689291c0d0ac49b51 *R/interactive.R
+e28903d80468bf5362e78780c4ae6f7c *R/iv.R
+3e085acb5bd959d3d592bf5e1de555a7 *R/kappa.R
+a15efc876d53eb45ce40e58ba89dbfd4 *R/kill.R
+2f211c63c5929e3c0538ce481261c78b *R/ksmooth.R
+2bf1ed16f9c637991efc8505cbe6e42a *R/labels.R
+bd3e9b1bd5548cb3454a654e0b20bf52 *R/latent.R
+e3886c5525a46704cc65646da6b9e861 *R/lava-package.R
+5094ce7c6dfcd326ee4e4b06232520f7 *R/lisrel.R
+77e00bae2f10e35a2c9e4e1963123aae *R/lmers.R
+6dd369c9bc0a206d5ee4fda469b40c35 *R/logLik.R
+965f9148202dc588c6f333e0fb032d41 *R/logo.R
+db257244e3be81a9a97076f83d9706bf *R/lvm.R
+a21e2ee62290147bdceffba7c6681c3e *R/makemissing.R
+bf998c4b49901baf7ce2117995616d5f *R/manifest.R
+b775eddcbe0f27ca3796e3636d329b09 *R/matrices.R
+1515ca5171efd228aad877bca2eb0a8d *R/measurement.R
+bf59be64937b99b39827d323d28722d5 *R/measurement.error.R
+0248f4ffd7f3492ff877639396c8ba7c *R/merge.R
+c528402ac265f7bdc49429f99dbb2f23 *R/missingMLE.R
+90ee09af235159a546e7d1dc11f058c4 *R/model.R
+24a144e6530322d6be25c77c94dbbca5 *R/model.frame.R
+47b7832e6c2b36cb561a43eef9aa2397 *R/modelPar.R
+ca097422372ea58ae2f0b640a1cfe2a8 *R/modelVar.R
+e4eed65212e2dac2a4f9d3e2d8833472 *R/modelsearch.R
+279c0bd9878c99331ccde2385efd29ca *R/moments.R
+d208fc49fc1f53808b91b3b460b3c86e *R/multigroup.R
+39c0c1c5eab5f43b39bb802aa776b6bb *R/multinomial.R
+1f9bfa57aa1a9c3e875d73f20ad8104e *R/multipletesting.R
+c245590d634326ec5fc4a33922b8f62c *R/nodecolor.R
+afde414fc26740a6d926ebaf17aeb801 *R/nonlinear.R
+f012637fecb886a3bebac4a3ab31e22a *R/normal.R
+51c01d90caecc82d9391acf22ed67ba3 *R/onload.R
+70fa043e0ea0129bfdf77a4979ff5512 *R/operators.R
+c21d4b6958c09dba185c9d20adfe0a89 *R/optims.R
+88fe1c1ef71784537daab762d3f703de *R/ordinal.R
+d7f7cdaa2f36b69aa8eedcfdd0ca3177 *R/ordreg.R
+ede5ff6ffb5bb2a1ec45c97e44a22de3 *R/parameter.R
+7091579f34b4380725e4e67bd4937595 *R/parlabels.R
+58b93d0108be5bae602a7ff9fa7ec148 *R/parpos.R
+fb6925e5e1b024c8e486734416a9e1f2 *R/pars.R
+099a9737f4a0bff97a41d5f9fca9d5ce *R/parsedesign.R
+aa8756bff3dbeaee91ab62b914271571 *R/partialcor.R
+7a6bea2c69bdc0886821f6aa2d0c2bf0 *R/path.R
+d20c397a6c77e7d56da90629a9a4cd0b *R/pcor.R
+bacb0c975e2a4b2037099f40a827c11a *R/pdfconvert.R
+164ec1d177fdc0a1293d009d2d578228 *R/plot.R
+f9e14094a96e1dd2ca91d8ed724131eb *R/plot.estimate.R
+11c5888b20ea640e8f61e7489e69a678 *R/plotConf.R
+f487daaf04029a92b59f332904906e6d *R/predict.R
+710650ea7431fe46954214c0e10daa3f *R/print.R
+9381c9d87c8c919c4a656c0fe0fc6ac6 *R/procformula.R
+f00dd0c7579f6cc9e02d517bb8249bee *R/profile.R
+a3b8f843649749ee06f63f1642769b57 *R/randomslope.R
+996b1702abd47d799f05be0bbe1dede2 *R/regression.R
+748143a050a26259772393b89eec4c81 *R/residuals.R
+9885f45a75921e30edb59f296b531ff3 *R/revdiag.R
+76ebbdff4078491228cba31c26af20c1 *R/scheffe.R
+fa1516e93eb7effdadb172fcffabfd7f *R/score.R
+60f707d9fe306bb27717ddb92e95d714 *R/score.survreg.R
+c05fccd3a6da15912a4e8e9bea16fac2 *R/sim.default.R
+ef91fe55618f49a99d25a313a4147869 *R/sim.lvm.R
+2c9043a67901f7a8764aaccb1e67242d *R/spaghetti.R
+5276f205df711d2fa24ceaa3ece4fdb9 *R/stack.R
+36ee87ac21e9b4bca4272f640883adfb *R/startvalues.R
+80f33064ca0b4227e24816acfc6a0ea1 *R/subgraph.R
+fcf92cafd2d4cb9d995837adf629d85b *R/subset.R
+75421133d76026fd4375d05be651e492 *R/summary.R
+dda5d57fbe303014f555098e538e9e29 *R/timedep.R
+deed4d83d746a5bfb5632a5153794025 *R/toformula.R
+8612e2ee4584c59436ab771ca65026f7 *R/tr.R
+daca917407929c0e98ef59a3089ad200 *R/transform.R
+f28eb8beca4ba1a1573a99cd9f077785 *R/trim.R
+67641265b69bf5ffef01922770a23845 *R/twostage.R
+73129349df1756e7bf26c99a9fe6a0a7 *R/utils.R
+9f1708fb07673983ad7e6be149eeaac4 *R/variances.R
+04f4423dd16c96a318941ef83b546a24 *R/vars.R
+18ef760f3b474bd98d72cf860b6f3d8f *R/vcov.R
+7e3faa58e6302e6ca6ffd51424ff61f3 *R/vec.R
+c6d12d6aeec59e858ee0b790131a0b6a *R/weights.R
+ef670a9b5a126aa296c23165736511be *R/wrapvec.R
+a8d4bc3766dd32998a7f8ffac9cb7b56 *R/zcolorbar.R
+df6449e1c757a089e4dc6eb89113f2da *R/zgetmplus.R
+49a252e6e85ed587a9769962f4fd98a3 *R/zgetsas.R
+d512a45fa5db2a96793e9657a87dfa6e *R/zib.R
+8b271d0c4285f388753a2aee3f912e9b *R/zorg.R
+2feb5db344bfce229c01a7de40929e85 *data/bmd.rda
+2d838f53ad9c3d58fd6a184ff6e3720e *data/bmidata.rda
+b336965303f236bc616ba63780e29b61 *data/brisa.rda
+9ed389e894e3e81aef087c3fe36a0f85 *data/calcium.rda
+dde030b59f5556ed38fe3236ec7102b2 *data/hubble.rda
+ba9087ddb7fe4ed67e99f88fa85bc0e2 *data/hubble2.rda
+f9c3971a3dd0592d01a2c9b11a91ef1a *data/indoorenv.rda
+d1ee26f4b06b582d4c9ed32c6db80c36 *data/missingdata.rda
+f27c6f08c08335bd97b4803fe9f3d237 *data/nldata.rda
+dd0d23c6c2d7af474103d775a3a7473b *data/nsem.rda
+f32233d3ea8e9f45ad38b46e5dcb6dc5 *data/semdata.rda
+6149c35c960ec0456b55b002e377ea6e *data/serotonin.rda
+6b6a2b27a7b1662b7eac0ff20479a9b1 *data/serotonin2.rda
+933bb6d260016522315cb165b3d9e42c *data/twindata.rda
+6d29355c2d2381668b48f533289a9a56 *demo/00Index
+49cbb725daeee9df4bcd3f3218d15af7 *demo/estimation.R
+cdefb6eb610f302036b2de243a99a517 *demo/inference.R
+25f8dfc7d3b67315792b61f64f6778f0 *demo/lava.R
+a08f2482ed1aa2c382c8e518ecc4a779 *demo/model.R
+891ffcc55aa9fc46d121187705269df5 *demo/simulation.R
+1487b811b5815fe9d33f9202b3688598 *inst/CITATION
+9c622abcd38a960910d024ddd68e5b04 *inst/doc/reference.pdf
+e5565bd9058e67350fee135e726a1203 *inst/gof1.png
+353943bdc7be1e7b960a39a6f3151f3b *inst/lava1.png
+142883ae5125f895240b57b6de582158 *inst/me1.png
+fc920f32cbf64f061c136182e3884cdb *inst/mediation1.png
+dd5c946311f4359b326bd6ab9d012d17 *inst/mediation2.png
+7b6ffb90e95d2678700214aa78fa5f1d *man/By.Rd
+f8e3420d7ddf9e5b98ee8b36eb5be760 *man/Col.Rd
+70c5a7f02608e37b9a1c157bcdba3ad1 *man/Combine.Rd
+61ae311aaca910331d64972e0f036c09 *man/Expand.Rd
+a6a7d1968ee9d64d3e5b993af09c04da *man/Graph.Rd
+57b370a192f5d4cef3ffc8db9fe8b862 *man/Missing.Rd
+acb160f41f5f0764e55e4031c49f3d89 *man/Model.Rd
+f8a6d3a344495d1d99d89e0d38940c74 *man/Org.Rd
+e3e3435c6fd3ec4aafef404473982c43 *man/PD.Rd
+43b2d9cc18d196d229a196b7ae262aae *man/Range.lvm.Rd
+59623c19b395b35aefffc1c10edf3057 *man/addvar.Rd
+1430e3bcc89c125ad372745707156d7b *man/backdoor.Rd
+e7e95df43364b92a679509086c8ff05e *man/baptize.Rd
+16047192af5bae954f82a50a1cd3876f *man/blockdiag.Rd
+8cd1a006a4b05401f14820110650a601 *man/bmd.Rd
+30af5e935e4e346a0a9ecba2ce9bf8bd *man/bmidata.Rd
+b399672fcaf643917b85171b48e3f544 *man/bootstrap.Rd
+94a5bcd6edc9ab6c80f03a9c87e0e00d *man/bootstrap.lvm.Rd
+cbcdc5d58164c1d28d5faf01316c9d11 *man/brisa.Rd
+f2f728c0587313c8db0c1870b3229983 *man/calcium.Rd
+cdbe152faa7797b3292a3885e0f7ad6b *man/cancel.Rd
+5be6986bee085c84684ae0f2c78a5564 *man/children.Rd
+0637793104d239e30fccf961befeec89 *man/click.Rd
+898bb2629d8fe24fae185b8304775de6 *man/closed.testing.Rd
+0e972f22db7222235ec05e4f1edddc23 *man/colorbar.Rd
+723c960e50860f937f9f92dfd39a8d88 *man/commutation.Rd
+fc3e122d0cb13f821992aaabc69f16b3 *man/compare.Rd
+488e525dd75c239376275cadacf59d34 *man/complik.Rd
+672fee18656d7a4f445145554a9e9e5e *man/confband.Rd
+75e55115d284d9608ff999254723e849 *man/confint.lvmfit.Rd
+1a121fdf598e4ec8ee6e8bbc72e9e7aa *man/confpred.Rd
+6cdcb59dd2b167246f615bb921f7c30e *man/constrain-set.Rd
+79c29dc5b1c5773253d96d9e1b1e7460 *man/contr.Rd
+fa7cd815048af0283d7547d700c594ef *man/correlation.Rd
+9bd9fd58066941179a2504e690b1becf *man/covariance.Rd
+463cb7e4b1b18e2c069d02e5a711c436 *man/csplit.Rd
+44ab52c6a4426b7a4905ec1cf8430347 *man/curly.Rd
+8593bb2cf5c8c30b390a99a014d4294d *man/cv.Rd
+39cec5e0359756ba69d58dd798aa412f *man/density.sim.Rd
+a040fa84bce00149e50204487f8261c7 *man/devcoords.Rd
+f93ab6183689f51995ababc766ca8491 *man/diagtest.Rd
+123b7eb66e6c708638fdfed4e9d34877 *man/dsep.lvm.Rd
+17bc658658e63f72f2303b81d53e252e *man/equivalence.Rd
+6e1b3e87dc8f9ba474b16a7882ce9c2d *man/estimate.default.Rd
+be07e5ccdf7da7bdbd1f36869f51eda6 *man/estimate.lvm.Rd
+563e34cc4f17143c32f6eb9541b78bb8 *man/eventTime.Rd
+72fe8797413faa8eb7a5b78150b5352e *man/fplot.Rd
+78a3104a3649ba232919f3afc1941244 *man/getMplus.Rd
+67f938720672c7fed9fac04ec2d7d994 *man/getSAS.Rd
+154fc5f7728778ae532621052ee6bdfa *man/gof.Rd
+d68f6594a617404eb95003b853375b1b *man/hubble.Rd
+075d9aa117a3501d1c60508d8fff039d *man/hubble2.Rd
+cb471dffc2cb20755317b9dcaf3b6e0c *man/iid.Rd
+b4166ca78462b84b7c10fe89b09ee562 *man/images.Rd
+76e0ca4ac5656534f5b33df1146ca978 *man/indoorenv.Rd
+10ca8d812f2ade6d60c38a640e4205d2 *man/intercept.Rd
+5998723fbadcd25f13ba719fb2311eaa *man/internal.Rd
+195d2f5b25692d84f62ec75dd9a7d27a *man/ksmooth2.Rd
+f02a7f008d8d76bd8725513679292e78 *man/labels-set.Rd
+be503752595681df64d48bac974cbed4 *man/lava-package.Rd
+7f250dd7b7694b9844a1b1651e459834 *man/lava.options.Rd
+a5e47f288bcd7e80e286d586dc78d213 *man/lvm.Rd
+7a81bb2c262d5751bfd71af74469b88d *man/makemissing.Rd
+e086dd1f019469e37f93dcc255613e04 *man/measurement.error.Rd
+556da354f27b0b1f4c96a27ef7fa80bc *man/missingdata.Rd
+3d00d7757908c73589e94b6680e2b32b *man/modelsearch.Rd
+6d49d0357ba6da87116a599faf940434 *man/multinomial.Rd
+24ad677894b70b2d252999291ae5246e *man/nldata.Rd
+cebf30fbfdd01962a81f5403c02849bd *man/nsem.Rd
+875e20f9314df1bf0ca8d539d7dfb62b *man/op_concat.Rd
+77c27cfed5e8d232f25194a63bd90b7e *man/op_match.Rd
+3b1ef7ffe3bb0f0f2c8723f6bfa6fa6d *man/ordreg.Rd
+5201fc27fa2eef2593220b6b0f9c3351 *man/parpos.Rd
+7a3b3a67afc2755df0b141c32328bb4a *man/partialcor.Rd
+bcc85f24e585426e62f0577555fffb9f *man/path.Rd
+8701da0b3ed59679e48e101d01401f84 *man/pcor.Rd
+808be5a530f5cc1486d5354ef88a8046 *man/pdfconvert.Rd
+143fa9da6a979b5c2f3c5191161d15ab *man/plot.lvm.Rd
+9f3c140e0f3d37bf444c02133f836ae1 *man/plotConf.Rd
+e3cd6f46918b3f1ff81b6cc1dc30c12f *man/predict.lvm.Rd
+422d69d35587cfe9d634ecca19fc8228 *man/predictlvm.Rd
+c8e8dd15904691a33f49fe4c1332e7af *man/regression-set.Rd
+31781fbf5da9b66994663f6b0d594364 *man/revdiag.Rd
+6b2ffdff46dc6a11d5e5945780ec3e27 *man/rmvar.Rd
+42b9f58b2da657008bbf8bb8c75b2cdf *man/scheffe.Rd
+0b6322ea6b679a4e01f15d7287dff581 *man/semdata.Rd
+70c657aac2d9b3f38e338bf00ae6c8dd *man/serotonin.Rd
+29ed5f5ff7966b18d4d2786922816155 *man/serotonin2.Rd
+30d4df135bbc91786b0f052f066536fe *man/sim.Rd
+2df39ef31ff78a76c4a4a0fd172ed7cf *man/sim.default.Rd
+41e9a9259d7f67747dc820a744957e48 *man/spaghetti.Rd
+4104c944ac9ac6673d64cbf57d0567ed *man/stack.estimate.Rd
+8aa9020192187714eeb76ebc86433991 *man/subset.lvm.Rd
+74d9828f0d6b1eee3c681c8a7343f96f *man/timedep.Rd
+22b6ec2f7df041c76e3df1dab09a5813 *man/toformula.Rd
+b6152bb0398362f381d70121e67ea59c *man/tr.Rd
+95cae60f23cb8c5d6a7946eb535f9485 *man/trim.Rd
+7f7648b1439f40e220ead810e924c79c *man/twindata.Rd
+34a3918d7cec0f56fcc7f09993ed9cf1 *man/twostage.Rd
+fa3d435b276f8106be3a094a277c2f6f *man/twostage.lvmfit.Rd
+13e4dc28973f1a8562101fd2979edb0b *man/vars.Rd
+9c72a8e15757f169f1e0464fb284e778 *man/vec.Rd
+9a7e9cdea94ccf9c802cf86a5b5a5b71 *man/wrapvec.Rd
+6bb11d642f624d521be6f36d1bdf7fab *man/zibreg.Rd
+daa9175db1f86ba2dc6b10b16523377f *tests/test-all.R
+e45850abf84a9d3f300ba9f5b7eb9de3 *tests/testthat/test-constrain.R
+373e8546d03676088fb35f5ceae65d56 *tests/testthat/test-estimate_default.R
+8f701383d7b955d28ce5226a9ef22ef7 *tests/testthat/test-graph.R
+9250d1e6fd93a37c6a52c7df306be2c5 *tests/testthat/test-inference.R
+056a2a4f2225b84a0c373e25b2d69b74 *tests/testthat/test-misc.R
+34a0bfbd38c96515341358ebd8f85b9d *tests/testthat/test-model.R
+24e7d2ab446e85db7e52a86039c2be3a *tests/testthat/test-multigroup.R
+a17573071ba8d3fc6598cdbc22c5e3a6 *tests/testthat/test-plot.R
+063215af6b119d29b402de10895a5352 *tests/testthat/test-sim.R
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..60f0890
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,657 @@
+# Generated by roxygen2: do not edit by hand
+
+S3method("%++%","function")
+S3method("%++%",character)
+S3method("%++%",default)
+S3method("%++%",lvm)
+S3method("%++%",matrix)
+S3method("+",estimate)
+S3method("+",lvm)
+S3method("Graph<-",lvm)
+S3method("Graph<-",lvmfit)
+S3method("Model<-",lvm)
+S3method("Model<-",lvmfit)
+S3method("Model<-",multigroup)
+S3method("Model<-",multigroupfit)
+S3method("[",sim)
+S3method("addvar<-",lvm)
+S3method("cancel<-",lvm)
+S3method("constrain<-",default)
+S3method("constrain<-",multigroupfit)
+S3method("covariance<-",lvm)
+S3method("covfix<-",lvm)
+S3method("distribution<-",lvm)
+S3method("edgelabels<-",graphNEL)
+S3method("edgelabels<-",lvm)
+S3method("edgelabels<-",lvmfit)
+S3method("exogenous<-",lvm)
+S3method("functional<-",lvm)
+S3method("heavytail<-",lvm)
+S3method("index<-",lvm)
+S3method("index<-",lvmfit)
+S3method("intercept<-",lvm)
+S3method("kill<-",lvm)
+S3method("labels<-",default)
+S3method("latent<-",lvm)
+S3method("nodecolor<-",default)
+S3method("nodecolor<-",lvm)
+S3method("nonlinear<-",lvm)
+S3method("ordinal<-",lvm)
+S3method("parameter<-",lvm)
+S3method("parameter<-",lvmfit)
+S3method("parfix<-",lvm)
+S3method("randomslope<-",lvm)
+S3method("regfix<-",lvm)
+S3method("regression<-",lvm)
+S3method("rmvar<-",lvm)
+S3method("transform<-",lvm)
+S3method("variance<-",lvm)
+S3method(Graph,lvm)
+S3method(Graph,lvmfit)
+S3method(Model,default)
+S3method(Model,lvm)
+S3method(Model,lvmfit)
+S3method(Model,multigroup)
+S3method(Model,multigroupfit)
+S3method(Weights,default)
+S3method(addattr,graphNEL)
+S3method(addattr,lvm)
+S3method(addattr,lvmfit)
+S3method(addvar,lvm)
+S3method(adjMat,lvm)
+S3method(adjMat,lvmfit)
+S3method(ancestors,lvm)
+S3method(ancestors,lvmfit)
+S3method(baptize,lvm)
+S3method(bootstrap,lvm)
+S3method(bootstrap,lvmfit)
+S3method(cancel,lvm)
+S3method(children,lvm)
+S3method(children,lvmfit)
+S3method(click,default)
+S3method(coef,effects)
+S3method(coef,estimate)
+S3method(coef,lvm)
+S3method(coef,lvmfit)
+S3method(coef,multigroup)
+S3method(coef,multigroupfit)
+S3method(coef,multinomial)
+S3method(coef,ordreg)
+S3method(coef,pcor)
+S3method(coef,summary.estimate)
+S3method(coef,summary.lvmfit)
+S3method(coef,zibreg)
+S3method(compare,default)
+S3method(confint,effects)
+S3method(confint,lvmfit)
+S3method(confint,multigroupfit)
+S3method(constrain,default)
+S3method(correlation,data.frame)
+S3method(correlation,lvmfit)
+S3method(correlation,matrix)
+S3method(covariance,formula)
+S3method(covariance,lvm)
+S3method(covfix,lvm)
+S3method(density,sim)
+S3method(deriv,lvm)
+S3method(descendants,lvm)
+S3method(descendants,lvmfit)
+S3method(distribution,lvm)
+S3method(dsep,lvm)
+S3method(edgeList,lvm)
+S3method(edgeList,lvmfit)
+S3method(edgelabels,graphNEL)
+S3method(edgelabels,lvm)
+S3method(edgelabels,lvmfit)
+S3method(effects,lvmfit)
+S3method(endogenous,list)
+S3method(endogenous,lm)
+S3method(endogenous,lvm)
+S3method(endogenous,lvmfit)
+S3method(endogenous,multigroup)
+S3method(estimate,MAR)
+S3method(estimate,default)
+S3method(estimate,estimate.sim)
+S3method(estimate,formula)
+S3method(estimate,list)
+S3method(estimate,lvm)
+S3method(estimate,multigroup)
+S3method(estimate,twostage.lvm)
+S3method(exogenous,list)
+S3method(exogenous,lm)
+S3method(exogenous,lvm)
+S3method(exogenous,lvmfit)
+S3method(exogenous,multigroup)
+S3method(family,zibreg)
+S3method(finalize,lvm)
+S3method(formula,lvm)
+S3method(formula,lvmfit)
+S3method(functional,lvm)
+S3method(gof,lvmfit)
+S3method(heavytail,lvm)
+S3method(iid,data.frame)
+S3method(iid,default)
+S3method(iid,estimate)
+S3method(iid,glm)
+S3method(iid,matrix)
+S3method(iid,multigroupfit)
+S3method(iid,multinomial)
+S3method(iid,numeric)
+S3method(index,lvm)
+S3method(index,lvmfit)
+S3method(information,data.frame)
+S3method(information,glm)
+S3method(information,lvm)
+S3method(information,lvm.missing)
+S3method(information,lvmfit)
+S3method(information,multigroup)
+S3method(information,multigroupfit)
+S3method(information,multinomial)
+S3method(information,table)
+S3method(information,zibreg)
+S3method(intercept,lvm)
+S3method(kappa,data.frame)
+S3method(kappa,multinomial)
+S3method(kappa,table)
+S3method(kill,lvm)
+S3method(labels,graphNEL)
+S3method(labels,lvm)
+S3method(labels,lvmfit)
+S3method(latent,list)
+S3method(latent,lvm)
+S3method(latent,lvmfit)
+S3method(latent,multigroup)
+S3method(logLik,lvm)
+S3method(logLik,lvm.missing)
+S3method(logLik,lvmfit)
+S3method(logLik,multigroup)
+S3method(logLik,multigroupfit)
+S3method(logLik,ordreg)
+S3method(logLik,pcor)
+S3method(logLik,zibreg)
+S3method(manifest,list)
+S3method(manifest,lvm)
+S3method(manifest,lvmfit)
+S3method(manifest,multigroup)
+S3method(merge,estimate)
+S3method(merge,glm)
+S3method(merge,lm)
+S3method(merge,lvm)
+S3method(merge,lvmfit)
+S3method(merge,multinomial)
+S3method(model.frame,estimate)
+S3method(model.frame,lvmfit)
+S3method(model.frame,multigroupfit)
+S3method(model.frame,multinomial)
+S3method(modelPar,lvm)
+S3method(modelPar,lvmfit)
+S3method(modelPar,multigroup)
+S3method(modelPar,multigroupfit)
+S3method(modelVar,lvm)
+S3method(modelVar,lvmfit)
+S3method(moments,lvm)
+S3method(moments,lvm.missing)
+S3method(moments,lvmfit)
+S3method(nonlinear,lvm)
+S3method(nonlinear,lvmfit)
+S3method(nonlinear,twostage.lvm)
+S3method(ordinal,lvm)
+S3method(parents,lvm)
+S3method(parents,lvmfit)
+S3method(parfix,lvm)
+S3method(parpos,default)
+S3method(parpos,lvm)
+S3method(parpos,lvmfit)
+S3method(parpos,multigroup)
+S3method(parpos,multigroupfit)
+S3method(pars,default)
+S3method(pars,glm)
+S3method(pars,lvm)
+S3method(pars,lvm.missing)
+S3method(pars,survreg)
+S3method(path,graphNEL)
+S3method(path,lvm)
+S3method(path,lvmfit)
+S3method(plot,estimate)
+S3method(plot,lvm)
+S3method(plot,lvmfit)
+S3method(plot,multigroup)
+S3method(plot,multigroupfit)
+S3method(plot,sim)
+S3method(plot,twostage.lvm)
+S3method(predict,lvm)
+S3method(predict,lvm.missing)
+S3method(predict,lvmfit)
+S3method(predict,multinomial)
+S3method(predict,ordreg)
+S3method(predict,twostage.lvmfit)
+S3method(predict,zibreg)
+S3method(print,Combine)
+S3method(print,CrossValidated)
+S3method(print,bootstrap.lvm)
+S3method(print,effects)
+S3method(print,equivalence)
+S3method(print,estimate)
+S3method(print,estimate.sim)
+S3method(print,fix)
+S3method(print,gkgamma)
+S3method(print,gof.lvmfit)
+S3method(print,lvm)
+S3method(print,lvm.predict)
+S3method(print,lvmfit)
+S3method(print,lvmfit.randomslope)
+S3method(print,modelsearch)
+S3method(print,multigroup)
+S3method(print,multigroupfit)
+S3method(print,multinomial)
+S3method(print,offdiag)
+S3method(print,ordinal.lvm)
+S3method(print,ordreg)
+S3method(print,pcor)
+S3method(print,sim)
+S3method(print,summary.estimate)
+S3method(print,summary.lvmfit)
+S3method(print,summary.multigroupfit)
+S3method(print,summary.ordreg)
+S3method(print,summary.sim)
+S3method(print,summary.zibreg)
+S3method(print,transform.lvm)
+S3method(print,twostage.lvm)
+S3method(print,zibreg)
+S3method(profile,lvmfit)
+S3method(randomslope,lvm)
+S3method(randomslope,lvmfit)
+S3method(regfix,lvm)
+S3method(regression,formula)
+S3method(regression,lvm)
+S3method(residuals,lvm)
+S3method(residuals,lvmfit)
+S3method(residuals,multigroupfit)
+S3method(residuals,zibreg)
+S3method(rmvar,lvm)
+S3method(roots,lvm)
+S3method(roots,lvmfit)
+S3method(score,glm)
+S3method(score,lm)
+S3method(score,lvm)
+S3method(score,lvm.missing)
+S3method(score,lvmfit)
+S3method(score,multigroup)
+S3method(score,multigroupfit)
+S3method(score,ordreg)
+S3method(score,pcor)
+S3method(score,survreg)
+S3method(score,zibreg)
+S3method(sim,default)
+S3method(sim,lvm)
+S3method(sim,lvmfit)
+S3method(simulate,lvm)
+S3method(simulate,lvmfit)
+S3method(sinks,lvm)
+S3method(sinks,lvmfit)
+S3method(stack,estimate)
+S3method(stack,glm)
+S3method(subset,lvm)
+S3method(summary,effects)
+S3method(summary,estimate)
+S3method(summary,lvm)
+S3method(summary,lvmfit)
+S3method(summary,multigroup)
+S3method(summary,multigroupfit)
+S3method(summary,ordreg)
+S3method(summary,sim)
+S3method(summary,zibreg)
+S3method(totaleffects,lvmfit)
+S3method(tr,matrix)
+S3method(transform,lvm)
+S3method(twostage,estimate)
+S3method(twostage,lvm)
+S3method(twostage,lvm.mixture)
+S3method(twostage,lvmfit)
+S3method(twostage,twostage.lvm)
+S3method(variance,formula)
+S3method(variance,lvm)
+S3method(vars,graph)
+S3method(vars,list)
+S3method(vars,lm)
+S3method(vars,lvm)
+S3method(vars,lvmfit)
+S3method(vcov,effects)
+S3method(vcov,estimate)
+S3method(vcov,lvmfit)
+S3method(vcov,multigroupfit)
+S3method(vcov,multinomial)
+S3method(vcov,ordreg)
+S3method(vcov,pcor)
+S3method(vcov,zibreg)
+export("%++%")
+export("%ni%")
+export("Graph<-")
+export("Missing<-")
+export("Model<-")
+export("addvar<-")
+export("cancel<-")
+export("categorical<-")
+export("constrain<-")
+export("covariance<-")
+export("covfix<-")
+export("distribution<-")
+export("edgelabels<-")
+export("eventTime<-")
+export("exogenous<-")
+export("functional<-")
+export("heavytail<-")
+export("index<-")
+export("intercept<-")
+export("intfix<-")
+export("kill<-")
+export("labels<-")
+export("latent<-")
+export("nodecolor<-")
+export("nonlinear<-")
+export("offdiag<-")
+export("ordinal<-")
+export("parameter<-")
+export("parfix<-")
+export("randomslope<-")
+export("regfix<-")
+export("regression<-")
+export("revdiag<-")
+export("rmvar<-")
+export("timedep<-")
+export("transform<-")
+export("variance<-")
+export(By)
+export(CoefMat)
+export(CoefMat.multigroupfit)
+export(Col)
+export(Combine)
+export(Diff)
+export(Expand)
+export(GM2.lvm)
+export(GM3.lvm)
+export(Gamma.lvm)
+export(Graph)
+export(IV)
+export(Inverse)
+export(Missing)
+export(Model)
+export(NR)
+export(OR)
+export(Org)
+export(PD)
+export(Range.lvm)
+export(Ratio)
+export(Specials)
+export(Weights)
+export(aalenExponential.lvm)
+export(addattr)
+export(addhook)
+export(addvar)
+export(adjMat)
+export(ancestors)
+export(backdoor)
+export(baptize)
+export(beta.lvm)
+export(binomial.lvm)
+export(blockdiag)
+export(bootstrap)
+export(cancel)
+export(categorical)
+export(children)
+export(chisq.lvm)
+export(click)
+export(closed.testing)
+export(colorbar)
+export(colsel)
+export(commutation)
+export(compare)
+export(complik)
+export(confband)
+export(confpred)
+export(constrain)
+export(constraints)
+export(contr)
+export(correlation)
+export(covariance)
+export(covfix)
+export(coxExponential.lvm)
+export(coxGompertz.lvm)
+export(coxWeibull.lvm)
+export(csplit)
+export(curly)
+export(cv)
+export(decomp.specials)
+export(density.sim)
+export(descendants)
+export(describecoef)
+export(devcoords)
+export(diagtest)
+export(distribution)
+export(dmvn)
+export(dsep)
+export(edgeList)
+export(edgelabels)
+export(endogenous)
+export(equivalence)
+export(estimate)
+export(eventTime)
+export(exogenous)
+export(expit)
+export(finalize)
+export(fixsome)
+export(foldr)
+export(forestplot)
+export(fplot)
+export(functional)
+export(gaussian.lvm)
+export(gaussian_logLik.lvm)
+export(getMplus)
+export(getSAS)
+export(gethook)
+export(getoutcome)
+export(gkgamma)
+export(gof)
+export(graph2lvm)
+export(heavytail)
+export(idplot)
+export(igraph.lvm)
+export(iid)
+export(images)
+export(index)
+export(information)
+export(intercept)
+export(intfix)
+export(kill)
+export(ksmooth2)
+export(latent)
+export(lava)
+export(lava.options)
+export(loggamma.lvm)
+export(logit)
+export(logit.lvm)
+export(lognormal.lvm)
+export(lvm)
+export(makemissing)
+export(manifest)
+export(measurement)
+export(measurement.error)
+export(modelPar)
+export(modelVar)
+export(modelsearch)
+export(moments)
+export(multigroup)
+export(multinomial)
+export(nonlinear)
+export(normal.lvm)
+export(odds)
+export(offdiag)
+export(offdiags)
+export(ones.lvm)
+export(ordinal)
+export(ordreg)
+export(p.correct)
+export(parameter)
+export(parents)
+export(pareto.lvm)
+export(parfix)
+export(parlabels)
+export(parpos)
+export(pars)
+export(parsedesign)
+export(partialcor)
+export(path)
+export(pcor)
+export(pdfconvert)
+export(plot.sim)
+export(plotConf)
+export(poisson.lvm)
+export(predictlvm)
+export(probit.lvm)
+export(procformula)
+export(randomslope)
+export(regfix)
+export(regression)
+export(reindex)
+export(revdiag)
+export(riskcomp)
+export(rmvar)
+export(rmvn)
+export(roots)
+export(rsq)
+export(scheffe)
+export(score)
+export(sequence.lvm)
+export(sim)
+export(sinks)
+export(spaghetti)
+export(starter.multigroup)
+export(startvalues)
+export(startvalues0)
+export(startvalues1)
+export(startvalues2)
+export(student.lvm)
+export(summary.sim)
+export(surface)
+export(threshold.lvm)
+export(tigol)
+export(timedep)
+export(toformula)
+export(totaleffects)
+export(tr)
+export(trim)
+export(twostage)
+export(uniform.lvm)
+export(updatelvm)
+export(variance)
+export(variances)
+export(vars)
+export(vec)
+export(weibull.lvm)
+export(wrapvec)
+export(zibreg)
+importFrom(grDevices,col2rgb)
+importFrom(grDevices,colorRampPalette)
+importFrom(grDevices,colors)
+importFrom(grDevices,gray.colors)
+importFrom(grDevices,heat.colors)
+importFrom(grDevices,palette)
+importFrom(grDevices,rainbow)
+importFrom(grDevices,rgb)
+importFrom(grDevices,topo.colors)
+importFrom(grDevices,xy.coords)
+importFrom(graphics,abline)
+importFrom(graphics,axis)
+importFrom(graphics,box)
+importFrom(graphics,contour)
+importFrom(graphics,contour.default)
+importFrom(graphics,identify)
+importFrom(graphics,image)
+importFrom(graphics,layout)
+importFrom(graphics,lines)
+importFrom(graphics,locator)
+importFrom(graphics,matplot)
+importFrom(graphics,mtext)
+importFrom(graphics,par)
+importFrom(graphics,plot)
+importFrom(graphics,plot.new)
+importFrom(graphics,plot.window)
+importFrom(graphics,points)
+importFrom(graphics,polygon)
+importFrom(graphics,rect)
+importFrom(graphics,segments)
+importFrom(graphics,text)
+importFrom(graphics,title)
+importFrom(methods,as)
+importFrom(methods,new)
+importFrom(stats,AIC)
+importFrom(stats,addmargins)
+importFrom(stats,approxfun)
+importFrom(stats,as.formula)
+importFrom(stats,coef)
+importFrom(stats,confint)
+importFrom(stats,confint.default)
+importFrom(stats,cor)
+importFrom(stats,cov)
+importFrom(stats,cov2cor)
+importFrom(stats,density)
+importFrom(stats,deriv)
+importFrom(stats,dnorm)
+importFrom(stats,effects)
+importFrom(stats,family)
+importFrom(stats,fft)
+importFrom(stats,formula)
+importFrom(stats,get_all_vars)
+importFrom(stats,glm)
+importFrom(stats,lm)
+importFrom(stats,logLik)
+importFrom(stats,model.frame)
+importFrom(stats,model.matrix)
+importFrom(stats,model.weights)
+importFrom(stats,na.omit)
+importFrom(stats,na.pass)
+importFrom(stats,nlminb)
+importFrom(stats,p.adjust)
+importFrom(stats,pchisq)
+importFrom(stats,pnorm)
+importFrom(stats,predict)
+importFrom(stats,printCoefmat)
+importFrom(stats,pt)
+importFrom(stats,qchisq)
+importFrom(stats,qf)
+importFrom(stats,qnorm)
+importFrom(stats,qt)
+importFrom(stats,quantile)
+importFrom(stats,rbinom)
+importFrom(stats,rchisq)
+importFrom(stats,residuals)
+importFrom(stats,rgamma)
+importFrom(stats,rlnorm)
+importFrom(stats,rnorm)
+importFrom(stats,rpois)
+importFrom(stats,rt)
+importFrom(stats,runif)
+importFrom(stats,sd)
+importFrom(stats,simulate)
+importFrom(stats,terms)
+importFrom(stats,uniroot)
+importFrom(stats,update)
+importFrom(stats,update.formula)
+importFrom(stats,var)
+importFrom(stats,vcov)
+importFrom(survival,is.Surv)
+importFrom(utils,combn)
+importFrom(utils,data)
+importFrom(utils,getFromNamespace)
+importFrom(utils,getTxtProgressBar)
+importFrom(utils,glob2rx)
+importFrom(utils,head)
+importFrom(utils,methods)
+importFrom(utils,modifyList)
+importFrom(utils,packageVersion)
+importFrom(utils,read.csv)
+importFrom(utils,setTxtProgressBar)
+importFrom(utils,stack)
+importFrom(utils,tail)
+importFrom(utils,txtProgressBar)
+importFrom(utils,write.table)
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000..f98ec87
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,263 @@
+
+* Version 1.5.1 <2017-09-25 Mon>
+ - conformal predictions: confpred
+ - warnings (char2num used instead of coersion via as.numeric)
+ - %++% for function compositon
+ - New summary.effects methods with mediation proportion in the
+ output
+ - New hook: remove.hooks (see example ordinal.lvm)
+ - constrain methods now handled more robustly in sim.lvm allowing
+ both vectorized and non-vectorized functions
+ - Non-linear associations can now be specified with 'nonlinear'
+ method. Estimation via the 'twostage' function.
+ - Robust standard errors added to the IV estimator (2SLS)
+ - New cross-validation function: cv (and csplit function for
+ creating random sets).
+
+* Version 1.5.0 <2017-03-16 Thu>
+ - lava.tobit is longer required for ordinal and censored
+ responses. Default is now to use the implementation in the 'mets' package.
+ - Composite likelihood method (complik) updated
+ - weight argument renamed to weights in agreement with lm, glm, coxph, ...
+ - sim.default: new argument 'arg' passed on to simulation function
+ - sim.default: new argument 'iter'. If TRUE the iteration number is
+ passed to function call as first argument (default FALSE)
+ - estimate.default: Wildcards/global expressions can now be used for specifying
+ contrasts based on the syntax of the functions 'contr', 'parsedesign'.
+ See examples on the help-page.
+ The argument transform.ci has been renamed to back.transform.
+ - correlation methods for matrices and data.frames (either pairwise or full MLE).
+ All methods can now return the influence functions.
+ - revdiag: dimnames are kept
+ - Combine: output updated
+ - forestplot: point estimates shown by default
+ - backdoor now works without conditioning set (yields all possible conditioning sets)
+ - New formula syntax: y+x~v+z same as c(y,x)~v+z
+ - spaghetti: trend.formula can now contain a factor statement on the rhs
+
+* Version 1.4.7 <2017-01-26 Wed>
+ - Maintenance release
+ - models can now be specified as y1+y2~x1+x2 instead of c(y1,2y)~x1+x2
+ - sim method now has a seed argument
+
+* Version 1.4.6 <2016-12-14 Wed>
+ - New backtrace algorithms for Newton-Raphson optimization routine.
+ - 'diagtest' updated.
+
+* Version 1.4.5 <2016-10-25 Tue>
+ - New graph functions:
+ dsep: check for d-separation (conditional independence).
+ backdoor: check backdoor criterion of a graph (lvm-object).
+ adjMat: return adjaceny matrix.
+ edgeList: return edge list.
+ ancestors: return ancenstors of nodes.
+ descendants: return descendants of nodes.
+ - All simple paths in a graph can now be extracted with:
+ path(...,all=TRUE)
+ - Covariance parameters are now reference with ~~ instead of ,.
+ Applies to setting starting values in 'estimate', parameters in
+ 'sim','compare','estimate',...
+ To use the old syntax set 'lava.options(symbol=c("~",","))'
+ - 'layout' argument added to lava.options (default 'dot')
+ - visNetwork support, new 'plot.engine' argument added to plot methods.
+ - bootstrap.lvmfit now default returns original estimates.
+ - print, transform methods updated (transform output).
+ - '+' operator overloaded for lvm and estimate objects (merge).
+ - New composite likelihood function: complik.
+ - New functions for simple association measures: riskcomp, rdiff, rratio,...
+ - New argument 'latent' in simulate method. If FALSE the latent
+ variables are dropped from the returned data.frame.
+ - modelsearch by default now shows both directional or undirectional
+ associations (type='all' vs type='cor').
+ - sim.default now stores timings. New print functions (data.table
+ like output).
+ - lvm model can now be updated with the 'sim' function,
+ for instance setting parameter values for the simulation only once:
+ m <- sim(m,p=p,...), with faster subsequent calls sim(m,n=n).
+ - estimate.default can now simulate p-values ('R' argument). Returns
+ an object which can also be used as input for 'estimate'.
+ - Bug fixes: NR optimization with back-tracing; fixed matrices.lvm when called
+ without variance parameters; fixed a bug in r-square computations.
+ - Contrast matrix can be specified with the function 'contr'.
+
+* Version 1.4.4 <2016-08-13 Sat>
+ - estimate.default will now use the id-variable of an 'estimate'
+ object if the 'id' argument is left unspecified. For
+ multinomial,gkgamma,kappa additional arguments (...) are now
+ parsed on the 'estimate.default' (including id).
+ - Updated print/summary methods for
+ 'estimate.default'. Sample/cluster-size added to output.
+ - Code clean-up and optimization. Smarter calculations of kronecker
+ products, and some regular expressions updated.
+ - New function 'predictlvm' which return jacobian.
+ - Intercepts can now be specified via parantheses, e.g., y ~ (-2) + x
+ - 'getoutcome' with sep argument for splitting '|' statements in
+ formulas.
+ - Partial gamma, gkgamma, updated (probability interpretation,
+ homogeneity tests removed)
+ - 'moments' function now returns conditional mean with multiple rows. Side effect fixed across multiple functions
+ - twostage function with support for mixture models
+ - Beta (Beta.lvm) and Finite Gaussian (GM2.lvm,GM3.lvm) Mixtures
+ added.
+ - 'sim': parameters can now be specified as part of '...'
+ - summary.sim: calculate Wald CI if confint=TRUE, otherwise use the
+ user supplied confidence limits.
+ - Clopper-pearson intervals and exact binomial tests added to 'diagtest'.
+ - Interval censoring with 'normal' estimator, which now also works
+ with 'binary' definitions.
+ - default plot style updated.
+
+* Version 1.4.3 <2016-04-11 Mon>
+ - partial gamma coefficients (gkgamma)
+ - Unit tests works with new testthat version
+ - Avoid trying to fork new processes on windows (bootstrap,sim.default)
+
+* Version 1.4.2 <2016-04-05 Wed>
+ - Code optimization and minor bug fixes
+ - Travis-CI, unit-tests
+ - glm estimator update (censored regression)
+ - polychoric correlations (pcor)
+ - New utility functions: wrapvec, offdiag
+ - simulation: regression design on parameters (see weibull +
+ variance hetereogeneity example in help('sim'))
+ - Byte compile by default
+
+* Version 1.4.1 <2015-06-13 Sat>
+ - New plot.estimate method
+ - Documentation and examples updated
+
+* Version 1.4.0 <2015-02-15 Sun>
+ - Linear measurement error model: 'measurement.error'
+ - Diagnostic tests: 'diagtest'
+ - 'plotConf' updated with support for special function terms (I, poly, ns, ...).
+ Old version is available (not in namespace) as lava:::plotConf0
+ - Pareto distribution: 'pareto.lvm'
+ - Code clean-up/optimization: 'EventTime', 'stack'
+ - 'estimate.default' new syntax for contrast specification (parsedesign)
+ - 'regression.lvm' with y,x argument (as alias for to,from)
+ - plot longitudinal data: 'spaghetti'
+ - Examples updated
+
+* Version 1.3.0 <2014-11-18 Tue>
+ - New syntax for categorical predictors (method 'categorical' and
+ argument 'additive=FALSE' with 'regression method)
+ - Argument 'intervals' added to 'ones.lvm' for piece-wise constant effects
+ - Argument 'average=TRUE' now needed for empirical averages in estimate.default
+ - Fixed a bug in score.glm (with weights and offset) introduced in version 1.2.6
+ - estimate.default:
+ - small-sample corrections
+ - Default id from row names in estimate.default (used with merge method)
+ - iid decompostion also returned for hypothesis contrasts
+ - keep argument added to estimate.default and merge
+ - labels argument added to estimate.default
+ - 'images' function for visualization of tabular data added to namespace
+ - 'ksmooth' and 'surface' for surface estimation and visualization of bivariate data and functions
+ - 'dsort': Sort data.frames
+ - general multivariate distributions in simulations. see example in 'sim'
+ - 'or2prob', 'tetrachoric' for conversion from OR to probabilities
+ (and tetrachoric correlations).
+ 'prob.normal': calculates probabilities from threshold model given thresholds and variance
+ See also mets:::assoc for calculations of kappa, gamma, uncer.coef.
+ 'normal.threshold': returns thresholds,variance,mu from model with
+ categorical outcomes.
+ - Multiple testing routines: closed.testing, p.correct, ...
+ - 'Missing' method updated with a simple 'suffix' argument
+ - Back-tracing updated in Newton-Raphson routine
+
+* Version 1.2.6 <2014-05-07 Wed>
+ - New 'stack' function for two-stage estimation (via 'estimate' objects)
+ - New 'blocksample' function for resampling clustered data.
+ - New function 'Missing' to generate complex missing data patterns
+ - Weibull parametrization of 'coxWeibull.lvm' rolled back
+ (ver. 1.2.4). The function 'weibull.lvm' now leads to Accelerated
+ Failure Time model (see examples of 'eventTime')
+ - iid function cleanup (new 'bread' attribute).
+ iid.glm now gives correct estimated influence functions for
+ 'quasi' link (constant variance)
+ - Parameter constraints on (co)variance parameters now possible with
+ the syntax lvm(...,y~~a*x) (corresponding to
+ covariance(...,y~x)<-"a")
+ - Some additional utilities: pdfconvert, scheffe, images, click. confband
+ updated with 'polygon' argument.
+ - New function getMplus: Import results from Mplus
+ - New function getSAS: Import SAS ODS
+ - New 'edgecolor' argument of plot-function
+
+* Version 1.2.5 <2014-03-13 Thu>
+ - 'merge' method added for combining 'estimate' objects
+ - Adjustments to starting values
+ - Function 'categorical' for adding categorical predictors to
+ simulation model
+ - Improved flexibility in simulations with 'transform','constrain'
+ (ex: categorical predictors)
+ - Added 'dataid' argument to estimate.default allowing different id
+ for 'data' and i.i.d. decomposition of model parameter estimates.
+ With the argument 'stack=FALSE' influence functions within
+ clusters will not be stacked together.
+ - R-squared values (+ approximate standard
+ errors/i.i.d. decomposition) via 'rsq(model,TRUE)'
+ - New infrastructure for adding additional parameters to models (no
+ user-visible changes).
+ - multinomial function for calculating influence curves for
+ multinomial probabilities. 'gammagk' and 'kappa' methods for
+ calculating Goodman-Kruskals gamma and Cohens kappa coefficients.
+ - ordreg function for univariate ordinal regression models
+ - iid methods for data.frames/matrices (empirical mean and variance)
+ - Support for using 'mets::cluster.index' in GEE-type models (much
+ faster).
+ - plotConf updated (vcov argument added and more graphical arguments
+ parsed to plotting functions)
+ - Additional unit-tests implemented
+ - New 'forestplot' and 'Combine' functions
+ - Covariance structure may now be specified using '~~', e.g.
+ 'lvm(c(y,v)~~z+u)' specifies correlation between residuals of
+ (y,z),(y,u),(v,z),(v,u).
+
+* Version 1.2.4 <2013-12-01 Sun>
+ - Avoid estimating IC in 'estimate.default' when 'vcov' argument is
+ given.
+ - New default starting values
+ - Time-varying effects via 'timedep'
+ - R-squared added to summary
+ - alias: covariance->variance
+ - added size argument to binomial.lvm;
+
+* Version 1.2.3 <2013-10-27 Sun>
+ - 'subset' argument added to estimate.default. Calculates empirical
+ averages conditional on subsets of data
+ - Improved output from compare/estimate functions
+ - Minor bug fixes (plot, predict)
+ - sim: Piecewise constant rates with coxEponential.lvm. New
+ aalenExponential.lvm function for additive models. Functions
+ ones.lvm and sequence.lvm for deterministic variables.
+
+* Version 1.2.2 <2013-07-10 Wed>
+ - Regression parameters are now by default referenced using '~',
+ e.g. "y~x" instead of "y<-x". Applies to setting starting values
+ in 'estimate', parameters in 'sim','compare','estimate',....
+ To use the old syntax set 'lava.options(symbol=c("<-","<->"))'
+ - Newton-Raphson/scoring procedure updated
+ - Search-interval for profile likelihood CI improved (for variance
+ parameters)
+ - 'estimate.default' updated (LRT)
+ - 'iid' updated (variance now obtained as tensor product of the result)
+ - progress bar for 'bootstrap' and 'modelsearch'
+ - various minor bug fixes
+ - new functions: Expand (expand.grid wrapper), By (by wrapper)
+
+* Version 1.2.1 <2013-05-10 Fri>
+ - Optimization + minor bug fixes
+
+* Version 1.2.0 <2013-03-28 Thu>
+ - New method 'iid' for extracting i.i.d. decomposition (influence
+ functions) from model objects (e.g. glm, lvm, ...)
+ - Method 'estimate' can now be used on model objects to transform
+ parameters (Delta method) or conduct Wald tests. Average effects,
+ i.e. averaging functionals over the empirical distribution is also
+ possible including calculation of standard errors.
+ - 'curereg' function for estimating mixtures of binary data.
+ - Instrumental Variable (IV) estimator (two-stage
+ least-squares) optimized.
+ - New distributions: Gamma.lvm, coxWeibull.lvm, coxExponential.lvm,
+ coxGompertz.lvm. New method 'eventTime' (for simulation of
+ competing risks data)
diff --git a/R/By.R b/R/By.R
new file mode 100644
index 0000000..f13850d
--- /dev/null
+++ b/R/By.R
@@ -0,0 +1,39 @@
+##' Apply a Function to a Data Frame Split by Factors
+##'
+##' Simple wrapper of the 'by' function
+##' @title Apply a Function to a Data Frame Split by Factors
+##' @param x Data frame
+##' @param INDICES Indices (vector or list of indices, vector of column names, or formula of column names)
+##' @param FUN A function to be applied to data frame subsets of 'data'.
+##' @param COLUMNS (Optional) subset of columns of x to work on
+##' @param array if TRUE an array/matrix is always returned
+##' @param ... Additional arguments to lower-level functions
+##' @author Klaus K. Holst
+##' @export
+##' @examples
+##' By(datasets::CO2,~Treatment+Type,colMeans,~conc)
+##' By(datasets::CO2,~Treatment+Type,colMeans,~conc+uptake)
+By <- function(x,INDICES,FUN,COLUMNS,array=FALSE,...) {
+ if (inherits(INDICES,"formula")) {
+ INDICES <- as.list(model.frame(INDICES,x))
+ } else {
+ if (is.character(INDICES) && length(INDICES)!=nrow(x)) {
+ INDICES <- as.list(x[,INDICES,drop=FALSE])
+ }
+ }
+ if (!missing(COLUMNS)) {
+ if (inherits(COLUMNS,"formula")) {
+ x <- model.frame(COLUMNS,x)
+ } else {
+ x <- x[,COLUMNS,drop=FALSE]
+ }
+ }
+ a <- by(x, INDICES, FUN=FUN, ...)
+ if (NCOL(x)==1 && !array) {
+ ##DimElem <- length(a[rep(1,length(dim(a)))][[1]])
+ a <- a[]
+ attr(a,"call") <- NULL
+ ## a <- array(a,)
+ }
+ return(a)
+}
diff --git a/R/Col.R b/R/Col.R
new file mode 100644
index 0000000..e130e1c
--- /dev/null
+++ b/R/Col.R
@@ -0,0 +1,35 @@
+mypal <- function(set=TRUE,...) {
+ oldpal <- palette()
+ col <- c("black","darkblue","darkred","goldenrod","mediumpurple",
+ "seagreen","aquamarine3","violetred1","salmon1",
+ "lightgoldenrod1","darkorange2","firebrick1","violetred1", "gold")
+ if (!set) return(col)
+ palette(col)
+ invisible(oldpal)
+}
+
+
+##' This function transforms a standard color (e.g. "red") into an
+##' transparent RGB-color (i.e. alpha-blend<1).
+##'
+##' This only works for certain graphics devices (Cairo-X11 (x11 as of R>=2.7), quartz, pdf, ...).
+##' @title Generate a transparent RGB color
+##' @param col Color (numeric or character)
+##' @param alpha Degree of transparency (0,1)
+##' @param locate Choose colour (with mouse)
+##' @return A character vector with elements of 7 or 9 characters, '"\#"'
+##' followed by the red, blue, green and optionally alpha values in
+##' hexadecimal (after rescaling to '0 ... 255').
+##' @author Klaus K. Holst
+##' @examples
+##' plot(runif(1000),cex=runif(1000,0,4),col=Col(c("darkblue","orange"),0.5),pch=16)
+##' @keywords color
+##' @export
+Col <- function(col,alpha=0.2,locate=0) {
+ if (locate>0) return(colsel(locate))
+
+ mapply(function(x,alpha)
+ do.call(rgb,as.list(c(col2rgb(x)/255,alpha))),
+ col,alpha)
+}
+
diff --git a/R/Expand.R b/R/Expand.R
new file mode 100644
index 0000000..f469ed0
--- /dev/null
+++ b/R/Expand.R
@@ -0,0 +1,38 @@
+##' Create a Data Frame from All Combinations of Factors
+##'
+##' Simple wrapper of the 'expand.grid' function. If x is a table
+##' then a data frame is returned with one row pr individual
+##' observation.
+##' @title Create a Data Frame from All Combinations of Factors
+##' @param _data Data.frame
+##' @param ... vectors, factors or a list containing these
+##' @author Klaus K. Holst
+##' @export
+##' @examples
+##' dd <- Expand(iris, Sepal.Length=2:8, Species=c("virginica","setosa"))
+##' summary(dd)
+##'
+##' T <- with(warpbreaks, table(wool, tension))
+##' Expand(T)
+Expand <- function(`_data`,...) {
+ if (missing(`_data`)) {
+ return(expand.grid(...))
+ }
+ if (inherits(`_data`,"table")) {
+ M <- as.data.frame(`_data`)
+ idx <- rep(seq(nrow(M)),M[,ncol(M)])
+ return(M[idx,-ncol(M),drop=FALSE])
+ }
+ if (!inherits(`_data`,"data.frame")) {
+ return(expand.grid(`_data`,...))
+ }
+ dots <- list(...)
+ nn <- names(dots)
+ for (n in nn) {
+ y <- dots[[n]]
+ if (is.factor(`_data`[1,n])) {
+ dots[[n]] <- factor(y,levels=levels(`_data`[1,n]))
+ }
+ }
+ do.call("expand.grid",dots)
+}
diff --git a/R/Inverse.R b/R/Inverse.R
new file mode 100644
index 0000000..f854e98
--- /dev/null
+++ b/R/Inverse.R
@@ -0,0 +1,41 @@
+##' @export
+Inverse <- function(X,tol=lava.options()$itol,det=TRUE,names=!chol,chol=FALSE,symmetric=FALSE) {
+ n <- NROW(X)
+ # return(structure(solve(X),))
+ if (n==1L) {
+ res <- 1/X
+ if (det) attributes(res)$det <- X
+ if (chol) attributes(res)$chol <- X
+ return(res)
+ }
+ if (chol) {
+ L <- chol(X)
+ res <- chol2inv(L)
+ if (det) attributes(res)$det <- prod(diag(L)^2)
+ if (chol) attributes(res)$chol <- X
+ } else {
+ if(symmetric){
+ decomp <- eigen(X, symmetric = TRUE)
+ D <- decomp$values
+ U <- decomp$vectors
+ V <- decomp$vectors
+ }else{
+ X.svd <- svd(X)
+ U <- X.svd$u
+ V <- X.svd$v
+ D <- X.svd$d
+ }
+ id0 <- numeric(n)
+ idx <- which(abs(D)>tol)
+ id0[idx] <- 1/D[idx]
+ res <- V%*%diag(id0,nrow=length(id0))%*%t(U)
+
+ if (det)
+ attributes(res)$det <- prod(D[D>tol])
+ attributes(res)$pseudo <- (length(idx)<n)
+ attributes(res)$minSV <- min(D)
+
+ }
+ if (names && !is.null(colnames(X))) dimnames(res) <- list(colnames(X),colnames(X))
+ return(res)
+}
diff --git a/R/Missing.R b/R/Missing.R
new file mode 100644
index 0000000..ec0c97e
--- /dev/null
+++ b/R/Missing.R
@@ -0,0 +1,84 @@
+##' Missing value generator
+##'
+##' This function adds a binary variable to a given \code{lvm} model
+##' and also a variable which is equal to the original variable where
+##' the binary variable is equal to zero
+##'
+##' @title Missing value generator
+##' @param object \code{lvm}-object.
+##' @param formula The right hand side specifies the name of a latent
+##' variable which is not always observed. The left hand side
+##' specifies the name of a new variable which is equal to the latent
+##' variable but has missing values. If given as a string then this
+##' is used as the name of the latent (full-data) name, and the
+##' observed data name is 'missing.data'
+##' @param Rformula Missing data mechanism with left hand side
+##' specifying the name of the observed data indicator (may also just
+##' be given as a character instead of a formula)
+##' @param missing.name Name of observed data variable (only used if
+##' 'formula' was given as a character specifying the name of the
+##' full-data variable)
+##' @param suffix If missing.name is missing, then the name of the
+##' oberved data variable will be the name of the full-data variable +
+##' the suffix
+##' @param ... Passed to binomial.lvm.
+##' @return lvm object
+##' @aliases Missing, Missing<-
+##' @examples
+##' library(lava)
+##' set.seed(17)
+##' m <- lvm(y0~x01+x02+x03)
+##' m <- Missing(m,formula=x1~x01,Rformula=R1~0.3*x02+-0.7*x01,p=0.4)
+##' sim(m,10)
+##'
+##'
+##' m <- lvm(y~1)
+##' m <- Missing(m,"y","r")
+##' ## same as
+##' ## m <- Missing(m,y~1,r~1)
+##' sim(m,10)
+##'
+##' ## same as
+##' m <- lvm(y~1)
+##' Missing(m,"y") <- r~x
+##' sim(m,10)
+##'
+##' m <- lvm(y~1)
+##' m <- Missing(m,"y","r",suffix=".")
+##' ## same as
+##' ## m <- Missing(m,"y","r",missing.name="y.")
+##' ## same as
+##' ## m <- Missing(m,y.~y,"r")
+##' sim(m,10)
+##'
+##' @export
+##' @author Thomas A. Gerds <tag@@biostat.ku.dk>
+Missing <- function(object,formula,Rformula,missing.name,suffix="0",...){
+ if (is.character(Rformula)) {
+ indicatorname <- Rformula
+ Rformula <- toformula(Rformula,1)
+ } else {
+ indicatorname <- all.vars(Rformula)[1]
+ }
+ if (length(all.vars(formula))==1) formula <- all.vars(formula)
+ if (is.character(formula)) {
+ if (missing(missing.name)) missing.name <- paste0(formula,suffix)
+ formula <- toformula(missing.name,formula)
+ }
+ newf <- update(formula,paste(".~.+",indicatorname))
+ if (is.null(distribution(object,indicatorname)[[1]]) || length(list(...))>0) {
+ distribution(object,indicatorname) <- binomial.lvm(...)
+ }
+ transform(object,newf) <- function(u){
+ out <- u[,1]
+ out[u[,2]==0] <- NA
+ out
+ }
+ regression(object) <- Rformula
+ object
+}
+
+##' @export
+"Missing<-" <- function(object,formula,...,value) {
+ Missing(object,formula,value,...)
+}
diff --git a/R/Objective.R b/R/Objective.R
new file mode 100644
index 0000000..4ee8efb
--- /dev/null
+++ b/R/Objective.R
@@ -0,0 +1,276 @@
+###{{{ gaussian
+
+gaussian_method.lvm <- "nlminb2"
+`gaussian_objective.lvm` <-
+ function(x,p,data,S,mu,n,...) {
+ mp <- modelVar(x,p=p,data=data,...)
+ C <- mp$C ## Model specific covariance matrix
+ xi <- mp$xi ## Model specific mean-vector
+ if (!lava.options()$allow.negative.variance && any(diag(mp$P)<0)) return(NaN)
+
+ iC <- Inverse(C,det=TRUE, symmetric = TRUE)
+ detC <- attributes(iC)$det
+ if (n<2) {
+ z <- as.numeric(data-xi)
+ val <- log(detC) + tcrossprod(z,crossprod(z,iC))[1]
+ return(0.5*val)
+ }
+ if (!is.null(mu)){
+ W <- suppressMessages(crossprod(rbind(mu-xi)))
+ T <- S+W
+ } else {
+ T <- S
+ }
+ res <- n/2*log(detC) + n/2*tr(T%*%iC) ## Objective function (Full Information ML)
+ ## if (any(attr(iC,"lambda")<1e-16)) res <- res-1e2
+ return(res)
+ }
+
+
+`gaussian_hessian.lvm` <- function(x,p,n,...) {
+ dots <- list(...); dots$weights <- NULL
+ do.call("information", c(list(x=x,p=p,n=n),dots))
+}
+
+gaussian_gradient.lvm <- function(x,p,data,S,mu,n,...) {
+ dots <- list(...); dots$weights <- NULL
+ if (n>2) data <- NULL
+ val <- -gaussian_score.lvm(x,p=p,S=S,mu=mu,n=n,data=data,reindex=FALSE,...)
+ if (!is.null(nrow(val))) {
+ val <- colSums(val)
+ }
+ val
+}
+
+gaussian_score.lvm <- function(x, data, p, S, n, mu=NULL, weights=NULL, debug=FALSE, reindex=FALSE, mean=TRUE, constrain=TRUE, indiv=FALSE,...) {
+
+ if (!is.null(data)) {
+ if ((nrow(data)<2 | !is.null(weights))| indiv)
+ {
+ mp <- modelVar(x,p,data=data[1,])
+ iC <- Inverse(mp$C,det=FALSE, symmetric = TRUE)
+ MeanPar <- attributes(mp)$meanpar
+ D <- with(attributes(mp), deriv.lvm(x, meanpar=MeanPar, p=pars, mom=mp, mu=NULL)) ##, all=length(constrain(x))>0))
+ myvars <- (index(x)$manifest)
+ if (NCOL(data)!=length(myvars)) {
+ data <- subset(data,select=myvars)
+ }
+ score <- matrix(ncol=length(p),nrow=NROW(data))
+ score0 <- -1/2*as.vector(iC)%*%D$dS
+ if (!is.null(weights)) {
+ W0 <- diag(nrow=length(myvars))
+ widx <- match(colnames(weights),myvars)
+ }
+
+ for (i in seq_len(NROW(data))) {
+ z <- as.numeric(data[i,])
+ u <- z-as.numeric(mp$xi)
+ if (!is.null(weights)) {
+ W <- W0; diag(W)[widx] <- as.numeric(weights[i,])
+ score[i,] <-
+ as.numeric(crossprod(u,iC%*%W)%*%D$dxi +
+ -1/2*(as.vector((iC
+ - iC %*% crossprod(rbind(u))
+ %*% iC)%*%W)) %*% D$dS
+ )
+ } else {
+ score[i,] <-
+ as.numeric(score0 + crossprod(u,iC)%*%D$dxi +
+ 1/2*as.vector(iC%*%crossprod(rbind(u))%*%iC)%*%D$dS)
+ }
+ }; colnames(score) <- names(p)
+ return(score)
+ }
+ }
+
+ ### Here the emperical mean and variance of the population are sufficient statistics:
+ if (missing(S)) {
+ data0 <- na.omit(data[,manifest(x),drop=FALSE])
+ n <- NROW(data0)
+ S <- cov(data0)*(n-1)/n
+ mu <- colMeans(data0)
+ }
+ mp <- modelVar(x,p)
+ C <- mp$C
+ xi <- mp$xi
+ iC <- Inverse(C,det=FALSE, symmetric = TRUE)
+ Debug("Sufficient stats.",debug)
+ if (!is.null(mu) & !is.null(xi)) {
+ W <- crossprod(rbind(mu-xi))
+ T <- S+W
+ } else {
+ T <- S
+ }
+ D <- deriv.lvm(x, meanpar=attributes(mp)$meanpar, mom=mp, p=p, mu=mu, mean=mean)
+ vec.iC <- as.vector(iC)
+ if (lava.options()$devel) {
+ Grad <- numeric(length(p))
+ imean <- with(index(x)$parBelongsTo,mean)
+ Grad[-imean] <- n/2*crossprod(D$dS[,-imean], as.vector(iC%*%T%*%iC)-vec.iC)
+ } else {
+ Grad <- n/2*crossprod(D$dS, as.vector(iC%*%T%*%iC)-vec.iC)
+ }
+ if (!is.null(mu) & !is.null(xi)) {
+ if (!(lava.options()$devel)) {
+ Grad <- Grad - (n/2*crossprod(D$dT,vec.iC))
+ } else {
+ Grad[with(index(x)$parBelongsTo,c(mean,reg))] <- Grad[with(index(x)$parBelongsTo,c(mean,reg))] - (n/2*crossprod(D$dT,vec.iC))
+ }
+ }
+ res <- as.numeric(Grad)
+ return(rbind(res))
+}
+
+###}}} gaussian
+
+###{{{ gaussian variants
+
+## Maximum Likelihood with numerical gradient + hessian
+gaussian0_objective.lvm <- gaussian_objective.lvm
+
+gaussian1_objective.lvm <- gaussian_objective.lvm
+gaussian1_gradient.lvm <- function(...) gaussian_gradient.lvm(...)
+gaussian1_hessian.lvm <- function(x,p,...) {
+ myg2 <- function(p1) gaussian_gradient.lvm(x,p=p1,...)
+ myg3 <- function(p1) numDeriv::jacobian(myg2,p1)
+ return(myg3(p))
+ ## myg <- function(p1) gaussian_objective.lvm(x,p=p1,...)
+ ## numDeriv::hessian(myg,p)
+}
+
+## BHHH
+gaussian2_method.lvm <- "NR"
+gaussian2_objective.lvm <- gaussian_objective.lvm
+gaussian2_gradient.lvm <- gaussian_gradient.lvm
+gaussian2_hessian.lvm <- function(x,p,n,data,...) {
+ S <- -score(x,p=p,n=n,data=data,indiv=TRUE,...)
+ I <- t(S)%*%S
+ attributes(I)$grad <- colSums(S)
+ return(I)
+}
+
+###}}}
+
+###{{{ Weighted
+
+weighted_method.lvm <- "NR"
+weighted_gradient.lvm <- function(x,p,data,weights,indiv=FALSE,...) {
+ myvars <- index(x)$manifest
+ if (NCOL(data)!=length(myvars))
+ data <- subset(data,select=myvars)
+ score <- matrix(ncol=length(p),nrow=NROW(data))
+ myy <- index(x)$endogenous
+ myx <- index(x)$exogenous
+ mynx <- setdiff(myvars,myx)
+ W0 <- diag(nrow=length(myy))
+ widx <- match(colnames(weights),myy)
+ pp <- modelPar(x,p)
+ mp <- moments(x,p=p,conditional=TRUE,data=data[1,])
+ iC <- Inverse(mp$C,det=FALSE, symmetric = TRUE)
+ v <- matrix(0,ncol=length(vars(x)),nrow=NROW(data))
+ colnames(v) <- vars(x)
+ for (i in mynx) v[,i] <- mp$v[i]
+ for (i in myx) v[,i] <- data[,i]
+ xi <- t(mp$G%*%t(v))
+ u <- as.matrix(data)[,myy]-xi
+ D <- deriv.lvm(x, meanpar=pp$meanpar,
+ p=pp$p, mom=mp, mu=NULL)
+ if (NROW(data)==1) {
+ W <- W0; diag(W)[widx] <- as.numeric(weights[i,])
+ score[i,] <-
+ as.numeric(crossprod(u,iC%*%W)%*%D$dxi +
+ -1/2*(as.vector((iC
+ - iC %*% crossprod(rbind(u))
+ %*% iC)%*%W)) %*% D$dS)
+ return(-score)
+}
+ score0 <- -0.5*as.vector(iC)%*%D$dS
+ Gdv <- mp$G%*%D$dv
+ for (i in seq_len(NROW(data))) {
+ W <- W0; diag(W)[widx] <- as.numeric(weights[i,])
+ dxi <-
+ (t(as.numeric(v[i,]))%x%diag(nrow=length(myy)))%*%D$dG + Gdv
+ score[i,] <- -0.5*as.vector(iC%*%W)%*%D$dS +
+ as.numeric(crossprod(u[i,],iC%*%W)%*%dxi +
+ 1/2*as.vector(iC%*%crossprod(rbind(u[i,]))%*%iC%*%W)%*%D$dS)
+ ## score[i,] <- -0.5*as.vector(iC)%*%D$dS +
+ ## as.numeric(crossprod(u[i,],iC)%*%dxi +
+ ## 1/2*as.vector(iC%*%tcrossprod(u[i,])%*%iC)%*%D$dS)
+
+ }
+ if (indiv) return(-score)
+ colSums(-score)
+}
+weighted_hessian.lvm <- function(...) {
+ S <- weighted_gradient.lvm(...,indiv=TRUE)
+ res <- crossprod(S)
+ attributes(res)$grad <- colSums(-S)
+ res
+}
+
+
+weighted0_method.lvm <- "estfun"
+weighted0_gradient.lvm <- function(...) {
+ val <- -gaussian_score.lvm(...)
+ colSums(val)
+}
+weighted0_hessian.lvm <- NULL
+
+weighted2_method.lvm <- "estfun"
+weighted2_gradient.lvm <- function(x,p,data,weights,indiv=FALSE,...) {
+ myvars <- index(x)$manifest
+ if (NCOL(data)!=length(myvars))
+ data <- subset(data,select=myvars)
+ score <- matrix(ncol=length(p),nrow=NROW(data))
+ myy <- index(x)$endogenous
+ myx <- index(x)$exogenous
+ mynx <- setdiff(myvars,myx)
+ W0 <- diag(nrow=length(myy))
+ widx <- match(colnames(weights),myy)
+ pp <- modelPar(x,p)
+ for (i in seq_len(NROW(data))) {
+ z <- as.matrix(data[i,myy])
+ mp <- moments(x,p=p,conditional=TRUE,data=data[i,])
+ u <- as.numeric(z-mp$xi[,1])
+ iC <- Inverse(mp$C,det=FALSE, symmetric = TRUE)
+ D <- deriv.lvm(x, meanpar=pp$meanpar,
+ p=pp$p, mom=mp, mu=NULL)
+ W <- W0; diag(W)[widx] <- as.numeric(weights[i,])
+ score[i,] <- -0.5*as.vector(iC%*%W)%*%D$dS +
+ as.numeric(crossprod(u,iC%*%W)%*%D$dxi +
+ 1/2*as.vector(iC%*%crossprod(rbind(u))%*%iC%*%W)%*%D$dS)
+ }
+ if (indiv) return(-score)
+ colSums(-score)
+}
+weighted2_hessian.lvm <- NULL
+
+###}}} Weighted
+
+###{{{ Simple
+
+`Simple_hessian.lvm` <- function(p,...) {
+ matrix(NA, ncol=length(p), nrow=length(p))
+}
+Simple_gradient.lvm <- function(x,p,...) {
+ naiveGrad(function(pp) Simple_objective.lvm(x,pp,...), p)
+}
+`Simple_objective.lvm` <-
+ function(x, p=p, S=S, n=n, ...) {
+ m. <- moments(x,p)
+ C <- m.$C
+ A <- m.$A
+ P <- m.$P
+ J <- m.$J
+ IAi <- m.$IAi
+ npar.reg <- m.$npar.reg; npar <- m.$npar
+ G <- J%*%IAi
+ detC <- det(C)
+ iC <- Inverse(C, symmetric = TRUE)
+ if (detC<0 | inherits(iC, "try-error"))
+ return(.Machine$double.xmax)
+ res <- n/2*(log(detC) + tr(S%*%iC) - log(det(S)) - npar)
+ res
+ }
+
+###}}} ObjectiveSimple
diff --git a/R/addattr.R b/R/addattr.R
new file mode 100644
index 0000000..44d440b
--- /dev/null
+++ b/R/addattr.R
@@ -0,0 +1,38 @@
+##' @export
+`addattr` <- function(x,...) UseMethod("addattr")
+
+##' @export
+`addattr.lvmfit` <- function(x,...) addattr(Model(x),...)
+
+##' @export
+`addattr.lvm` <- function(x, attr, var=NULL, val=TRUE, fun=graph::nodeRenderInfo,debug=FALSE,...) {
+ if (!is.null(var)) {
+ Graph(x) <- addattr(Graph(x), attr=attr, var=var, val=val, fun=fun, debug=debug)
+ return(x)
+ } else {
+ addattr(Graph(x), attr=attr, var=var, val=val, fun=fun)
+ }
+}
+
+##' @export
+`addattr.graphNEL` <- function(x, attr, var=NULL, val=TRUE,fun="graph::nodeRenderInfo",debug=FALSE,...) {
+ if (is.null(var)) {
+ ff <- strsplit(fun,"::")[[1]]
+ if (length(ff)>1) {
+ ff <- getFromNamespace(ff[2],ff[1])
+ }
+ f <- do.call(ff,list(x))
+ if (is.null(val) || !is.logical(f[[attr]]))
+ attrvar <- f[[attr]]
+ else
+ attrvar <- names(f[[attr]])[which(val==f[[attr]])]
+ return(attrvar)
+ }
+ if (is.character(val))
+ myexpr <- paste0("list(",attr,"=c(", paste0("\"",var,"\"=\"",val,"\"" , collapse=", "), "))")
+ else
+ myexpr <- paste0("list(",attr,"=c(", paste0("\"",var,"\"=",val, collapse=", "), "))")
+ Debug(list("str=",myexpr),debug)
+ eval(parse(text=paste0(fun,"(x) <- ",myexpr)))
+ return(x)
+}
diff --git a/R/addhook.R b/R/addhook.R
new file mode 100644
index 0000000..b1b83e5
--- /dev/null
+++ b/R/addhook.R
@@ -0,0 +1,116 @@
+
+##' Set global options for \code{lava}
+##'
+##' Extract and set global parameters of \code{lava}. In particular optimization
+##' parameters for the \code{estimate} function.
+##'
+##' \itemize{
+##' \item \code{param}: 'relative' (factor loading and variance of one
+##' endogenous variables in each measurement model are fixed to one), 'absolute'
+##' (mean and variance of latent variables are set to 0 and 1, respectively),
+##' 'hybrid' (intercept of latent variables is fixed to 0, and factor loading of
+##' at least one endogenous variable in each measurement model is fixed to 1),
+##' 'none' (no constraints are added)
+##' \item \code{layout}: One of 'dot','fdp','circo','twopi','neato','osage'
+##' \item \code{silent}: Set to \code{FALSE} to disable various output messages
+##' \item ... }
+##'
+##' see \code{control} parameter of the \code{estimate} function.
+##'
+##' @param \dots Arguments
+##' @return \code{list} of parameters
+##' @author Klaus K. Holst
+##' @keywords models
+##' @examples
+##'
+##' \dontrun{
+##' lava.options(iter.max=100,silent=TRUE)
+##' }
+##'
+##' @export
+lava.options <- function(...) {
+ dots <- list(...)
+ newopt <- curopt <- get("options",envir=lava.env)
+ if (length(dots)==0)
+ return(curopt)
+ if (length(dots)==1 && is.list(dots[[1]]) && is.null(names(dots))) {
+ dots <- dots[[1]]
+ }
+ idx <- which(names(dots)!="")
+ newopt[names(dots)[idx]] <- dots[idx]
+ assign("options",newopt,envir=lava.env)
+ invisible(curopt)
+}
+
+##' @export
+gethook <- function(hook="estimate.hooks",...) {
+ get(hook,envir=lava.env)
+}
+
+##' @export
+addhook <- function(x,hook="estimate.hooks",...) {
+ newhooks <- unique(c(gethook(hook),x))
+ assign(hook,newhooks,envir=lava.env)
+ invisible(newhooks)
+}
+
+versioncheck <- function(pkg="lava",geq,sep=".",...) {
+ xyz <- tryCatch(
+ char2num(strsplit(as.character(packageVersion(pkg)),sep,fixed=TRUE)[[1]]),
+ error=function(x) NULL)
+ if (is.null(xyz)) return(FALSE)
+ if (missing(geq)) return(xyz)
+ for (i in seq(min(length(xyz),length(geq)))) {
+ if (xyz[i]>geq[i]) return(TRUE)
+ if (xyz[i]<geq[i]) return(FALSE)
+ }
+ if (length(xyz)>=length(geq)) return(TRUE)
+ return(FALSE)
+}
+
+lava.env <- new.env()
+assign("init.hooks",c(),envir=lava.env)
+assign("remove.hooks",c(),envir=lava.env)
+assign("estimate.hooks",c(),envir=lava.env)
+assign("color.hooks",c(),envir=lava.env)
+assign("sim.hooks",c(),envir=lava.env)
+assign("post.hooks",c(),envir=lava.env)
+assign("print.hooks",c(),envir=lava.env)
+assign("plot.post.hooks",c(),envir=lava.env)
+assign("plot.hooks",c(),envir=lava.env)
+assign("options", list(
+ trace=0,
+ tol=1e-6,
+ gamma=1,
+ backtrack="wolfe",
+ ngamma=0,
+ iter.max=300,
+ eval.max=250,
+ constrain=FALSE,
+ allow.negative.variance=FALSE,
+ silent=TRUE,
+ progressbarstyle=3,
+ itol=1e-16,
+ cluster.index=versioncheck("mets",c(0,2,7)),
+ tobit=versioncheck("lava.tobit",c(0,5)),
+ Dmethod="simple", ##"Richardson"
+ messages=1,
+ parallel=TRUE,
+ param="relative",
+ sparse=FALSE,
+ test=TRUE,
+ coef.names=FALSE,
+ constrain=TRUE,
+ graph.proc="beautify",
+ regex=FALSE,
+ min.weight=1e-3,
+ exogenous=TRUE,
+ plot.engine="Rgraphviz",
+ node.color=c(exogenous="lightblue",endogenous="orange",
+ latent="yellowgreen",transform="lightgray"),
+ edgecolor=FALSE,
+ layout="dot",
+ ## symbols=c("<-","<->"),
+ symbols=c("~","~~"),
+ devel=FALSE,
+ debug=FALSE), envir=lava.env)
diff --git a/R/addvar.R b/R/addvar.R
new file mode 100644
index 0000000..38251b9
--- /dev/null
+++ b/R/addvar.R
@@ -0,0 +1,105 @@
+##' Generic method for adding variables to model object
+##'
+##' @title Add variable to (model) object
+##' @param x Model object
+##' @param \dots Additional arguments
+##' @author Klaus K. Holst
+##' @aliases addvar<-
+##' @export
+`addvar` <-
+function(x,...) UseMethod("addvar")
+
+##' @export
+`addvar<-` <-
+function(x,...,value) UseMethod("addvar<-")
+
+
+##' @export
+`addvar<-.lvm` <- function(x,...,value) {
+ if (inherits(value,"formula")) {
+ regression(x,...) <- value
+ return(x)
+## return(addvar(x,all.vars(value),...))
+ }
+ addvar(x, var=value, ...)
+}
+
+##' @export
+`addvar.lvm` <-
+function(x, var, silent=lava.options()$silent,reindex=TRUE,...) {
+ new <- setdiff(var,vars(x))
+ k <- length(new)
+ Debug(new)
+ if (k>0) {
+ if (lava.options()$sparse) {
+ requireNamespace("Matrix",quietly=TRUE)
+ newNA <- newM <- Matrix::Matrix(0,k,k)
+ newNAc <- newNA; diag(newNAc) <- NA
+ newcov <- Matrix::Diagonal(k)
+ } else {
+ newM <- matrix(0,k,k)
+ newcov <- diag(k)
+ }
+ newNA <- matrix(NA,k,k)
+ colnames(newM) <- rownames(newM) <-
+ colnames(newcov) <- rownames(newcov) <-
+ colnames(newNA) <- rownames(newNA) <- new
+ newmean <- as.list(rep(NA,k))
+ ## for (i in new) {
+ N <- nrow(x$cov)
+ if (is.null(N)) {
+ N <- 0
+ x$M <- newM
+ x$cov <- newcov; x$covfix <- x$fix <- x$par <- x$covpar <- newNA
+ x$mean <- newmean
+ } else {
+ if (lava.options()$sparse) {
+ x$M <- Matrix::bdiag(x$M, newM) ## Add regression labels.R
+ x$cov <- Matrix::bdiag(x$cov, newcov) ## Add covariance
+ x$par <- Matrix::bdiag(x$par, newNA) ## Add regression labels
+ x$covpar <- Matrix::bdiag(x$covpar, newNA) ## Add covariance labels
+ x$fix <- Matrix::bdiag(x$fix, newNA)
+ x$covfix <- Matrix::bdiag(x$covfix, newNA)
+
+ } else {
+ x$M <- blockdiag(x$M, newM, pad=0) ## Add regression labels
+ x$cov <- blockdiag(x$cov, newcov, pad=0) ## Add covariance
+ x$par <- blockdiag(x$par, newNA, pad=NA) ## Add regression labels
+ x$covpar <- blockdiag(x$covpar, newNA, pad=NA) ## Add covariance labels
+ x$fix <- blockdiag(x$fix, newNA, pad=NA) ##
+ x$covfix <- blockdiag(x$covfix, newNA, pad=NA) ##
+ }
+ x$mean <- c(x$mean, newmean)
+ }
+ names(x$mean)[N+seq_len(k)] <-
+ colnames(x$M)[N+seq_len(k)] <- rownames(x$M)[N+seq_len(k)] <-
+ colnames(x$covfix)[N+seq_len(k)] <- rownames(x$covfix)[N+seq_len(k)] <-
+ colnames(x$fix)[N+seq_len(k)] <- rownames(x$fix)[N+seq_len(k)] <-
+ colnames(x$covpar)[N+seq_len(k)] <- rownames(x$covpar)[N+seq_len(k)] <-
+ colnames(x$par)[N+seq_len(k)] <- rownames(x$par)[N+seq_len(k)] <-
+ colnames(x$cov)[N+seq_len(k)] <- rownames(x$cov)[N+seq_len(k)] <- new
+
+ ## x$cov[N+1,N+1] <- 1
+ ## names(x$mean)[N+1] <-
+ ## colnames(x$M)[N+1] <- rownames(x$M)[N+1] <-
+ ## colnames(x$covfix)[N+1] <- rownames(x$covfix)[N+1] <-
+ ## colnames(x$fix)[N+1] <- rownames(x$fix)[N+1] <-
+ ## colnames(x$covpar)[N+1] <- rownames(x$covpar)[N+1] <-
+ ## colnames(x$par)[N+1] <- rownames(x$par)[N+1] <-
+ ## colnames(x$cov)[N+1] <- rownames(x$cov)[N+1] <- i
+ ## myexpr <- paste("c(",i,"=expression(",i,"))", sep="\"")
+ ## labels(x) <- (eval(parse(text=myexpr)))
+ ## if (!silent)
+ ## message("\tAdded '", i, "' to model.\n", sep="")
+ if (!silent) {
+ if (k==1)
+ message("\tAdded '", new, "' to model.\n", sep="")
+ else
+ message("\tAdded ",paste(paste("'",new,"'",sep=""),collapse=",")," to model.\n", sep="")
+ }
+ exogenous(x) <- c(new,exogenous(x))
+ }
+ if (reindex)
+ index(x) <- reindex(x)
+ return(x)
+}
diff --git a/R/assoc.R b/R/assoc.R
new file mode 100644
index 0000000..2cc8fea
--- /dev/null
+++ b/R/assoc.R
@@ -0,0 +1,213 @@
+normal.threshold <- function(object,p=coef(object),...) {
+ M <- moments(object,p=p)
+ ord <- ordinal(Model(object))
+ K <- attributes(ord)$K
+ cK <- c(0,cumsum(K-1))
+ breaks.orig <- list()
+ for (i in seq(K)) {
+ breaks.orig <- c(breaks.orig,list(M$e[seq(K[i]-1)+cK[i]]))
+ }
+ breaks <- lapply(breaks.orig, ordreg_threshold)
+ names(breaks) <- names(K)
+ ii <- match(names(K),vars(object))
+ sigma <- M$Cfull[ii,ii]
+ list(breaks=breaks,sigma=sigma,mean=M$v[ii],K=K)
+}
+
+prob.normal <- function(sigma,breaks,breaks2=breaks) {
+ if (!requireNamespace("mets",quietly=TRUE)) stop("'mets' package required")
+ if (ncol(sigma)!=2 || missing(breaks)) stop("Wrong input")
+ P <- matrix(ncol=length(breaks2)-1, nrow=length(breaks)-1)
+ for (i in seq(length(breaks)-1))
+ for (j in seq(length(breaks2)-1))
+ P[i,j] <- mets::pmvn(lower=c(breaks[i],breaks2[j]),upper=c(breaks[i+1],breaks2[j+1]),sigma=sigma)
+ return(P)
+}
+
+assoc <- function(P,sigma,breaks,...) {
+ if (missing(P)) P <- prob.normal(sigma,breaks,...)
+ Agree <- sum(diag(P))
+ marg.row <- rowSums(P)
+ marg.col <- colSums(P)
+ Chance <- sum(marg.row*marg.col)
+ kap <- (Agree-Chance)/(1-Chance)
+ gam <- goodmankruskal_gamma(P)$gamma
+ inf <- information_assoc(P)
+ res <- c(list(kappa=kap,gamma=gam),inf)
+ if (!missing(sigma)) res <- c(res,rho=sigma[1,2])
+ return(res)
+}
+
+
+
+##################################################
+### Risk comparison
+##################################################
+
+## or:= riskcomp(x,scale=odds) // OR
+##' @export
+riskcomp <- function(x,...,scale,op="/",type=1,struct=FALSE) {
+ val <- c(x,unlist(list(...)))
+ if (!missing(scale)) val <- do.call(scale,list(val))
+ if (!struct && length(val)==2) {
+ if (type==2) {
+ return(do.call(op,list(val[2],val[1])))
+ } else if (type==1) {
+ return(do.call(op,list(val[1],val[2])))
+ }
+ return(c(do.call(op,list(val[2],val[1])),
+ do.call(op,list(val[1],val[2]))))
+ }
+ outer(val,val,op)
+ offdiag(outer(val,val,op) ,type=type)
+}
+
+##' @export
+Ratio <- function(x,...) riskcomp(x,...,op="/")
+
+##' @export
+Diff <- function(x,...) riskcomp(x,...,op="-")
+
+
+##################################################
+## Odds ratio
+##################################################
+
+##' @export
+odds <- function(x) x/(1-x)
+
+logor <- function(x) {
+ c(log(prod(diag(x))/prod(revdiag(x))),sum(1/x)^.5)
+}
+
+
+##' @export
+OR <- function(x,tabulate=FALSE,log=FALSE,...) {
+ if (!inherits(x,c("multinomial","table"))) {
+ val <- riskcomp(x,...,scale=odds)
+ if (log) val <- base::log(val)
+ return(val)
+ }
+ if (inherits(x,"multinomial")) {
+ M <- x
+ } else {
+ M <- multinomial(x)
+ }
+ pos <- M$position
+ if (ncol(pos)!=2 & ncol(pos)!=2) stop("Only for 2x2 tables")
+ orfun <- function(p,...) {
+ list(logOR=sum(log(p[diag(pos)]))-sum(log(p[revdiag(pos)])))
+ }
+ estimate(M,orfun,back.transform=exp)
+}
+
+
+
+##################################################
+## Information theoretical measures
+##################################################
+
+
+information_assoc <- function(P,base=exp(1),...) {
+ P.row <- rowSums(P)
+ P.col <- colSums(P)
+ H.row <- H.col <- H <- 0
+ for (j in seq_along(P.col))
+ if (P.col[j]>0) H.col <- H.col - P.col[j]*log(P.col[j]+(P.col[j]==0),base=base)
+ for (i in seq_along(P.row)) {
+ if (P.row[i]>0) H.row <- H.row - P.row[i]*log(P.row[i]+(P.row[i]==0),base=base)
+ for (j in seq_along(P.col)) {
+ if (P[i,j]>0) H <- H - P[i,j]*log(P[i,j],base=base)
+ }
+ }
+ I <- H.row+H.col-H
+ return(list(MI=I,H=H,H.row=H.row,H.col=H.col,
+ U.row=I/H.row,U.col=I/H.col,U.sym=2*I/(H.row+H.col)))
+}
+
+
+##' @export
+information.data.frame <- function(x,...) {
+ information(multinomial(x,marginal=TRUE),...)
+}
+
+##' @export
+information.table <- function(x,...) {
+ information(multinomial(x,marginal=TRUE),...)
+}
+
+##' @export
+information.multinomial <- function(x,...) {
+ estimate(x,function(p,object,...) {
+ P <- object$position; P[] <- p[object$position]
+ information_assoc(P)},...)
+}
+
+
+##################################################
+## Independence tests
+##################################################
+
+independence <- function(x,...) {
+ if (is.table(x) || is.data.frame(x) || is.matrix(x)) {
+ x <- multinomial(x)
+ }
+ if (!inherits(x,"multinomial")) stop("Expected table, data.frame or multinomial object")
+ if (length(x$levels)!=2) stop("Data from two categorical variables expected")
+ f <- function(p) {
+ P <- x$position; P[] <- p[x$position]
+ n <- nrow(x$iid)
+ k1 <- length(x$levels[[1]])
+ k2 <- length(x$levels[[2]])
+ A1 <- matrix(0,ncol=length(p),nrow=k1)
+ for (i in seq(k1)) A1[i,x$position[i,]] <- 1
+ A2 <- matrix(0,ncol=length(p),nrow=k2)
+ for (i in seq(k2)) A2[i,x$position[,i]] <- 1
+ P1 <- A1%*%p
+ P2 <- A2%*%p
+ I <- P1%*%t(P2)
+ Q <- P-I
+# Q <- sum(n*P*(log(I[1,1])-P1
+ sum((P-I)^2)
+ ##V <- sqrt(sum((P*n-I*n)^2/I/n) /(n*(min(k1,k2)-1)))
+ V <- sqrt(sum((P-I)^2/I) / ((min(k1,k2)-1)))
+ return(V)
+ sum(n*Q^2/I)^0.25
+ return((sum((P-I)^2))^.5)
+## V
+ }
+
+ ## M <- P*n
+ ## O2 <- colSums(M)
+ ## O1 <- rowSums(M)
+ ## M[1,1]-O1[1]*O2[1]/200
+ ## M[2,2]-O1[2]*O2[2]/200
+ ## sum((M-I*n)^2/(I*n))
+ ## sum((P*n-I*n)^2/I/n)
+ ## sum(Q)
+ ## sum(Q^2)
+ ## M <- P
+ ## chisq.test(M,correct=FALSE)
+
+ return(estimate(x,function(p) list(cramersV=f(p)),iid=TRUE,...))
+
+
+ e <- estimate(x,f,iid=TRUE,print=function(x,...) {
+ cat("\tTest for independence\n\n")
+ cat("Test statistc:\t ", formatC(x$coefmat[1]/x$coefmat[2]),
+ "\nP-value:\t ", x$coefmat[5],"\n\n")
+ print(estimate(x))
+ },...)
+ return(list(p.value=e$coefmat[5]))
+ ## Q <- sum((a$coefmat[1,1]/a$coefmat[1,2]))
+ ## df <- nrow(a$coefmat)
+ ## res <- list(##data.name=hypothesis,
+ ## statistic = Q, parameter = df,
+ ## p.value=pchisq(Q,df=1,lower.tail=FALSE),
+ ## method = "Test for independence")
+ ## class(res) <- "htest"
+ ## res
+}
+
+## independence(x)
+## chisq.test(table(dd))
diff --git a/R/backdoor.R b/R/backdoor.R
new file mode 100644
index 0000000..5116009
--- /dev/null
+++ b/R/backdoor.R
@@ -0,0 +1,84 @@
+##' Backdoor criterion
+##'
+##' Check backdoor criterion of a lvm object
+##' @param object lvm object
+##' @param f formula. Conditioning, z, set can be given as y~x|z
+##' @param cond Vector of variables to conditon on
+##' @param ... Additional arguments to lower level functions
+##' @param return.graph Return moral ancestral graph with z and effects from x removed
+##' @examples
+##' m <- lvm(y~c2,c2~c1,x~c1,m1~x,y~m1, v1~c3, x~c3,v1~y,
+##' x~z1, z2~z1, z2~z3, y~z3+z2+g1+g2+g3)
+##' ll <- backdoor(m, y~x)
+##' backdoor(m, y~x|c1+z1+g1)
+##' @export
+backdoor <- function(object, f, cond, ..., return.graph=FALSE) {
+ y <- getoutcome(f, sep = "|")
+ x <- attr(y, "x")
+ if (length(x) > 1) {
+ cond <- all.vars(x[[2]])
+ }
+ x <- all.vars(x[[1]])
+ nod <- vars(object)
+ des <- descendants(object, x)
+ ch <- children(object, x)
+ g0 <- cancel(object, toformula(x, ch))
+
+ if (!base::missing(cond)) {
+ val <- dsep(g0, c(y, x), cond = cond) && !any(cond %in% des)
+ if (return.graph) {
+ res <- dsep(g0, c(y, x), cond = cond, return.graph=TRUE)
+ attr(res,"result") <- val
+ return(res)
+ }
+ return(val)
+ }
+ cset <- base::setdiff(nod, c(des, x, y)) ## possible conditioning set
+ pp <- path(g0,from=x,to=y,all=TRUE) ## All backdoor paths
+ M <- adjMat(g0)
+ Collider <- function(vec) {
+ M[vec[2],vec[1]] & M[vec[2],vec[3]]
+ }
+ blockList <- collideList <- c()
+ for (i in seq_along(pp)) {
+ p0 <- pp[[i]]
+ blocks <- c()
+ collide <- c()
+ for (j in seq(length(p0)-2)) {
+ if (Collider(p0[0:2 + j])) {
+ collide <- c(collide,p0[1+j])
+ } else {
+ blocks <- c(blocks,p0[1+j])
+ }
+ }
+ blockList <- c(blockList,list(blocks))
+ collideList <- c(collideList,list(collide))
+ }
+ res <- list(blockList)
+ ## Paths with colliders:
+ col <- unlist(lapply(collideList,function(x) !is.null(x)))
+ if (length(col)>0) col <- which(col)
+ ## List of variables which are not on path between x and y:
+ optional <- setdiff(cset,c(unlist(collideList),unlist(blockList)))
+ callrecurs <- function(col,res=list()) {
+ if (length(col)==0) return(res)
+ blockList0 <- blockList
+ blockList0[col] <- NULL
+ blockList0 <- lapply(blockList0, function(x) setdiff(x,unlist(collideList[col])))
+ if (!any(unlist(lapply(blockList0,is.null)))) {
+ res <- c(res, list(blockList0))
+ }
+ for (i in seq_along(col)) {
+ col0 <- col[-i]
+ if (length(col0)>0)
+ res <- callrecurs(col0,res)
+ }
+ return(res)
+ }
+ if (length(col)>0)
+ res <- c(res,callrecurs(col))
+ ## Any element can be included from 'optional' For a given element
+ ## in 'include' at least one element in each member of the list
+ ## must be included in the conditioning set.
+ return(list(optional=optional, include=res))
+}
diff --git a/R/baptize.R b/R/baptize.R
new file mode 100644
index 0000000..7739e6e
--- /dev/null
+++ b/R/baptize.R
@@ -0,0 +1,61 @@
+##' Generic method for labeling elements of an object
+##'
+##' @title Label elements of object
+##' @param x Object
+##' @param \dots Additional arguments
+##' @author Klaus K. Holst
+##' @export
+`baptize` <- function(x,...) UseMethod("baptize")
+
+###{{{ baptize.lvm
+
+##' @export
+baptize.lvm <- function(x,labels,overwrite=FALSE,unique=FALSE,...) {
+ p <- describecoef(x, mean=TRUE)
+ sym <- lava.options()$symbols
+ MeanFix <- intfix(x)
+ RegFix <- regfix(x)
+ CovFix <- covfix(x)
+ count <- 0
+ curlab <- parlabels(x)
+ coef(x)
+ for (i in seq_along(p)) {
+ p0 <- p[[i]]
+ if (attributes(p0)$type=="reg") {
+ curfix <- RegFix$values[p0[2],p0[1]]
+ curlab <- RegFix$labels[p0[2],p0[1]]
+ if (all(is.na(c(curfix,curlab))) | overwrite) {
+ count <- count+1
+## st <- ifelse(missing(labels),paste0("p",count),labels[count])
+ st <- ifelse(missing(labels),paste(p0[1],p0[2],sep=sym[1]),labels[count])
+ regfix(x,from=p0[2],to=p0[1]) <- st
+ }
+ } else if (attributes(p0)$type=="cov") {
+ curfix <- CovFix$values[p0[2],p0[1]]
+ curlab <- CovFix$labels[p0[2],p0[1]]
+ if (all(is.na(c(curfix,curlab))) | overwrite) {
+ count <- count+1
+## st <- ifelse(missing(labels),paste0("p",count),labels[count])
+## st <- paste0("p",count)
+ st <- ifelse(missing(labels),paste(p0[1],p0[2],sep=sym[2]),labels[count])
+ covfix(x,p0[2],p0[1],exo=FALSE) <- st
+ }
+ } else { ## Mean parameter
+ curfix <- MeanFix[[p0]]
+ if (length(curfix)>0)
+ if (is.na(curfix) | overwrite) {
+ count <- count+1
+ st <- ifelse(missing(labels),p0,labels[count])
+## st <- ifelse(missing(labels),paste0("m",count),labels[count])
+ intfix(x,p0) <- st
+ }
+ }
+ }
+ if (index(x)$npar.ex>0) {
+ x$exfix[is.na(x$exfix)] <- names(x$exfix)[is.na(x$exfix)]
+ index(x) <- reindex(x)
+ }
+ return(x)
+}
+
+###}}}
diff --git a/R/blockdiag.R b/R/blockdiag.R
new file mode 100644
index 0000000..fef87a9
--- /dev/null
+++ b/R/blockdiag.R
@@ -0,0 +1,24 @@
+##' Combine matrices to block diagonal structure
+##' @title Combine matrices to block diagonal structure
+##' @param x Matrix
+##' @param \dots Additional matrices
+##' @param pad Vyalue outside block-diagonal
+##' @author Klaus K. Holst
+##' @export
+##' @examples
+##' A <- diag(3)+1
+##' blockdiag(A,A,A,pad=NA)
+blockdiag <- function(x,...,pad=0) {
+ if (is.list(x)) xx <- x else xx <- list(x,...)
+ rows <- unlist(lapply(xx,nrow))
+ crows <- c(0,cumsum(rows))
+ cols <- unlist(lapply(xx,ncol))
+ ccols <- c(0,cumsum(cols))
+ res <- matrix(pad,nrow=sum(rows),ncol=sum(cols))
+ for (i in seq_len(length(xx))) {
+ idx1 <- seq_len(rows[i])+crows[i]; idx2 <- seq_len(cols[i])+ccols[i]
+ res[idx1,idx2] <- xx[[i]]
+ }
+ colnames(res) <- unlist(lapply(xx,colnames)); rownames(res) <- unlist(lapply(xx,rownames))
+ return(res)
+}
diff --git a/R/bootstrap.R b/R/bootstrap.R
new file mode 100644
index 0000000..7a794af
--- /dev/null
+++ b/R/bootstrap.R
@@ -0,0 +1,195 @@
+##' Generic method for calculating bootstrap statistics
+##'
+##' @title Generic bootstrap method
+##' @param x Model object
+##' @param \dots Additional arguments
+##' @seealso \code{bootstrap.lvm} \code{bootstrap.lvmfit}
+##' @author Klaus K. Holst
+##' @export
+bootstrap <- function(x,...) UseMethod("bootstrap")
+
+##' Calculate bootstrap estimates of a lvm object
+##'
+##' Draws non-parametric bootstrap samples
+##'
+##' @param x \code{lvm}-object.
+##' @param R Number of bootstrap samples
+##' @param fun Optional function of the (bootstrapped) model-fit defining the
+##' statistic of interest
+##' @param data The data to resample from
+##' @param control Options to the optimization routine
+##' @param p Parameter vector of the null model for the parametric bootstrap
+##' @param parametric If TRUE a parametric bootstrap is calculated. If FALSE a
+##' non-parametric (row-sampling) bootstrap is computed.
+##' @param bollenstine Bollen-Stine transformation (non-parametric bootstrap) for bootstrap hypothesis testing.
+##' @param constraints Logical indicating whether non-linear parameter
+##' constraints should be included in the bootstrap procedure
+##' @param estimator String definining estimator, e.g. 'gaussian' (see
+##' \code{estimator})
+##' @param weights Optional weights matrix used by \code{estimator}
+##' @param sd Logical indicating whether standard error estimates should be
+##' included in the bootstrap procedure
+##' @param silent Suppress messages
+##' @param parallel If TRUE parallel backend will be used
+##' @param mc.cores Number of threads (if NULL foreach::foreach will be used, otherwise parallel::mclapply)
+##' @param \dots Additional arguments, e.g. choice of estimator.
+##' @aliases bootstrap.lvmfit
+##' @usage
+##'
+##' \method{bootstrap}{lvm}(x,R=100,data,fun=NULL,control=list(),
+##' p, parametric=FALSE, bollenstine=FALSE,
+##' constraints=TRUE,sd=FALSE,silent=FALSE,
+##' parallel=lava.options()$parallel,
+##' mc.cores=NULL,
+##' ...)
+##'
+##' \method{bootstrap}{lvmfit}(x,R=100,data=model.frame(x),
+##' control=list(start=coef(x)),
+##' p=coef(x), parametric=FALSE, bollenstine=FALSE,
+##' estimator=x$estimator,weights=Weights(x),...)
+##'
+##' @return A \code{bootstrap.lvm} object.
+##' @author Klaus K. Holst
+##' @seealso \code{\link{confint.lvmfit}}
+##' @keywords models regression
+##' @examples
+##' m <- lvm(y~x)
+##' d <- sim(m,100)
+##' e <- estimate(y~x, d)
+##' \donttest{ ## Reduce Ex.Timings
+##' B <- bootstrap(e,R=50,parallel=FALSE)
+##' B
+##' }
+##' @export
+bootstrap.lvm <- function(x,R=100,data,fun=NULL,control=list(),
+ p, parametric=FALSE, bollenstine=FALSE,
+ constraints=TRUE,sd=FALSE,silent=FALSE,
+ parallel=lava.options()$parallel,
+ mc.cores=NULL,
+ ...) {
+
+ coefs <- sds <- c()
+ on.exit(list(coef=coefs[-1,], sd=sds[-1,], coef0=coefs[1,], sd0=sds[1,], model=x))
+ pb <- NULL
+ if (!silent) pb <- txtProgressBar(style=lava.options()$progressbarstyle,width=40)
+ pmis <- missing(p)
+ ##maxcount <- 0
+ bootfun <- function(i) {
+ ##maxcount <- max(i,maxcount)
+ if (i==0) {
+ d0 <- data
+ } else {
+ if (!parametric | pmis) {
+ d0 <- data[sample(seq_len(nrow(data)),replace=TRUE),]
+ } else {
+ d0 <- sim(x,p=p,n=nrow(data))
+ }
+ }
+ suppressWarnings(e0 <- estimate(x,data=d0,control=control,silent=TRUE,index=FALSE,...))
+ if (!silent && getTxtProgressBar(pb)<(i/R)) {
+ setTxtProgressBar(pb, i/R)
+ }
+
+ if (!is.null(fun)) {
+ coefs <- fun(e0)
+ newsd <- NULL
+ } else {
+ coefs <- coef(e0)
+ newsd <- c()
+ if (sd) {
+ newsd <- e0$coef[,2]
+ }
+ if (constraints & length(constrain(x))>0) {
+ cc <- constraints(e0,...)
+ coefs <- c(coefs,cc[,1])
+ names(coefs)[seq(length(coefs)-length(cc[,1])+1,length(coefs))] <- rownames(cc)
+ if (sd) {
+ newsd <- c(newsd,cc[,2])
+ }
+ }
+ }
+ return(list(coefs=coefs,sds=newsd))
+ }
+ if (bollenstine) {
+ e0 <- estimate(x,data=data,control=control,silent=TRUE,index=FALSE,...)
+ mm <- modelVar(e0)
+ mu <- mm$xi
+ Y <- t(t(data[,manifest(e0)])-as.vector(mu))
+ Sigma <- mm$C
+ S <- (ncol(Y)-1)/ncol(Y)*var(Y)
+ sSigma <- with(eigen(Sigma),vectors%*%diag(sqrt(values),ncol=ncol(vectors))%*%t(vectors))
+ isS <- with(eigen(S),vectors%*%diag(1/sqrt(values),ncol=ncol(vectors))%*%t(vectors))
+ data <- as.matrix(Y)%*%(isS%*%sSigma)
+ colnames(data) <- manifest(e0)
+ }
+
+ i <- 0
+ if (parallel) {
+ if (is.null(mc.cores) && requireNamespace("foreach",quietly=TRUE)) {
+ res <- foreach::"%dopar%"(foreach::foreach (i=0:R),bootfun(i))
+ } else {
+ if (is.null(mc.cores)) mc.cores <- 1
+ res <- parallel::mclapply(0:R,bootfun,mc.cores=mc.cores)
+ }
+ } else {
+ res <- lapply(0:R,bootfun)
+ }
+ if (!silent) {
+ setTxtProgressBar(pb, 1)
+ close(pb)
+ }
+ ## if (!silent) message("")
+ coefs <- matrix(unlist(lapply(res, function(x) x$coefs)),nrow=R+1,byrow=TRUE)
+ nn <- names(res[[1]]$coefs)
+ if (!is.null(nn)) colnames(coefs) <- nn
+ sds <- NULL
+ if (sd)
+ sds <- matrix(unlist(lapply(res, function(x) x$sds)),nrow=R+1,byrow=TRUE)
+
+ if (!is.null(fun)) {
+ rownames(coefs) <- c()
+ res <- list(coef=coefs[-1,,drop=FALSE],coef0=coefs[1,],model=x)
+ } else {
+ colnames(coefs) <- names(res[[1]]$coefs)
+ rownames(coefs) <- c(); if (sd) colnames(sds) <- colnames(coefs)
+ res <- list(coef=coefs[-1,,drop=FALSE], sd=sds[-1,,drop=FALSE], coef0=coefs[1,], sd0=sds[1,], model=x, bollenstine=bollenstine)
+ }
+ class(res) <- "bootstrap.lvm"
+ return(res)
+}
+
+##' @export
+bootstrap.lvmfit <- function(x,R=100,data=model.frame(x),
+ control=list(start=coef(x)),
+ p=coef(x), parametric=FALSE, bollenstine=FALSE,
+ estimator=x$estimator,weights=Weights(x),...)
+ bootstrap.lvm(Model(x),R=R,data=data,control=control,estimator=estimator,weights=weights,parametric=parametric,bollenstine=bollenstine,p=p,...)
+
+##' @export
+"print.bootstrap.lvm" <- function(x,idx,level=0.95,...) {
+ cat("Non-parametric bootstrap statistics (R=",nrow(x$coef),"):\n\n",sep="")
+ uplow <-(c(0,1) + c(1,-1)*(1-level)/2)
+ nn <- paste(uplow*100,"%")
+ c1 <- t(apply(x$coef,2,function(x) c(mean(x), sd(x), quantile(x,uplow))))
+
+ c1 <- cbind(x$coef0,c1[,1]-x$coef0,c1[,-1,drop=FALSE])
+ colnames(c1) <- c("Estimate","Bias","Std.Err",nn)
+ if (missing(idx)) {
+ print(format(c1,...),quote=FALSE)
+ } else {
+ print(format(c1[idx,,drop=FALSE],...),quote=FALSE)
+ }
+ if (length(x$sd)>0) {
+ c2 <- t(apply(x$sd,2,function(x) c(mean(x), sd(x), quantile(x,c(0.025,0.975)))))
+ c2 <- cbind(c2[,1],c2[,1]-x$sd0,c2[,-1])
+ colnames(c2) <- c("Estimate","Bias","Std.Err","2.5%","97.5%")
+ cat("\nStandard errors:\n")
+ if (missing(idx)) {
+ print(format(c2,...),quote=FALSE)
+ } else {
+ print(format(c2[idx,,drop=FALSE],...),quote=FALSE)
+ }
+ }
+ cat("\n")
+ invisible(x)
+}
diff --git a/R/cancel.R b/R/cancel.R
new file mode 100644
index 0000000..340b51a
--- /dev/null
+++ b/R/cancel.R
@@ -0,0 +1,53 @@
+##' Generic cancel method
+##'
+##' @title Generic cancel method
+##' @param x Object
+##' @param \dots Additioal arguments
+##' @author Klaus K. Holst
+##' @aliases cancel<-
+##' @export
+"cancel" <- function(x,...) UseMethod("cancel")
+
+##' @export
+"cancel<-" <- function(x,...,value) UseMethod("cancel<-")
+
+##' @export
+"cancel<-.lvm" <- function(x, ..., value) {
+ cancel(x,value,...)
+}
+
+
+##' @export
+cancel.lvm <- function(x,value,...) {
+ if (inherits(value,"formula")) {
+ ## yx <- all.vars(value)
+ lhs <- getoutcome(value)
+ if (length(lhs)==0) yy <- NULL else yy <- decomp.specials(lhs)
+ xf <- attributes(terms(value))$term.labels
+ if(identical(all.vars(value),xf))
+ return(cancel(x,xf))
+ res <- lapply(xf,decomp.specials)
+ xx <- unlist(lapply(res, function(z) z[1]))
+ for (i in yy) {
+ for (j in xx)
+ cancel(x) <- c(i,j)
+ }
+ index(x) <- reindex(x)
+ return(x)
+ }
+
+ for (v1 in value)
+ for (v2 in value)
+ if (v1!=v2)
+ {
+ if (all(c(v1,v2)%in%vars(x))) {
+ x$M[v1,v2] <- 0
+ x$par[v1,v2] <- x$fix[v1,v2] <-
+ x$covpar[v1,v2] <- x$covfix[v1,v2] <- NA
+ x$cov[v1,v2] <- 0
+ }
+ }
+ x$parpos <- NULL
+ index(x) <- reindex(x)
+ return(x)
+}
diff --git a/R/categorical.R b/R/categorical.R
new file mode 100644
index 0000000..66954c3
--- /dev/null
+++ b/R/categorical.R
@@ -0,0 +1,55 @@
+##' @export
+categorical <- function(x,formula,K,beta,p,liability=FALSE,regr.only=FALSE,exo=TRUE,...) {
+
+ if (is.character(formula)) {
+ regr <- FALSE
+ X <- formula
+ } else {
+ y <- getoutcome(formula)
+ X <- attributes(y)$x
+ regr <- TRUE
+ if (length(y)==0) regr <- FALSE
+ if (length(attributes(y)$x)==0) {
+ X <- y; regr <- FALSE
+ }
+ }
+ if (!missing(p)) {
+ if (!missing(K)) {
+ if (!(K==length(p) || K==length(p)+1)) stop("Wrong dimension of 'p'")
+ if (length(K)==length(p)) {
+ if (!identical(sum(p),1.0)) stop("Not a probability vector")
+ p <- p[-length(p)]
+ }
+ }
+ if (is.numeric(p) && sum(p)>1) warning("'p' sum > 1")
+ if (is.logical(all.equal(1.0,sum(p)))) p <- p[-length(p)]
+ }
+ if (missing(K)) {
+ if (!is.null(list(...)$labels)) K <- length(list(...)$labels)
+ if (!missing(beta)) K <- length(beta)
+ if (!missing(p)) K <- length(p)+1
+ }
+ if (!regr.only) {
+ if (missing(p)) p <- rep(1/K,K-1)
+ pname <- names(p)
+ if (is.null(pname)) pname <- rep(NA,K-1)
+ ordinal(x,K=K,liability=liability,p=p,constrain=pname,exo=exo,...) <- X
+ if (!regr) return(x)
+ }
+
+ if (missing(beta)) beta <- rep(0,K)
+ fname <- paste(gsub(" ","",deparse(formula)),seq(K)-1,sep=":")
+ fpar <- names(beta)
+ if (is.null(fpar)) fpar <- fname
+
+ parameter(x,fpar,start=beta) <- fname
+ val <- paste0("function(x,p,...) p[\"",fpar[1],"\"]*(x==0)")
+ for (i in seq(K-1)) {
+ val <- paste0(val,"+p[\"",fpar[i+1],"\"]*(x==",i,")")
+ }
+ functional(x,formula) <- eval(parse(text=val))
+ return(x)
+}
+
+##' @export
+'categorical<-' <- function(x,...,value) categorical(x,value,...)
diff --git a/R/children.R b/R/children.R
new file mode 100644
index 0000000..50d7c20
--- /dev/null
+++ b/R/children.R
@@ -0,0 +1,140 @@
+##' Generic method for memberships from object (e.g. a graph)
+##'
+##' @title Extract children or parent elements of object
+##' @export
+##' @aliases children parents ancestors descendants roots sinks adjMat edgeList
+##' @param object Object
+##' @param \dots Additional arguments
+##' @author Klaus K. Holst
+"children" <- function(object,...) UseMethod("children")
+##' @export
+"parents" <- function(object,...) UseMethod("parents")
+##' @export
+"roots" <- function(object,...) UseMethod("roots")
+##' @export
+"sinks" <- function(object,...) UseMethod("sinks")
+##' @export
+"descendants" <- function(object,...) UseMethod("descendants")
+##' @export
+"ancestors" <- function(object,...) UseMethod("ancestors")
+##' @export
+"adjMat" <- function(object,...) UseMethod("adjMat")
+##' @export
+"edgeList" <- function(object,...) UseMethod("edgeList")
+
+##' @export
+adjMat.lvm <- function(object,...) t(object$M)
+
+##' @export
+adjMat.lvmfit <- function(object,...) adjMat(Model(object),...)
+
+##' @export
+edgeList.lvmfit <- function(object,...) edgeList(Model(object),...)
+
+##' @export
+edgeList.lvm <- function(object,labels=FALSE,...) {
+ edgelist <- data.frame(from=NULL,to=NULL)
+ A <- adjMat(object)
+ for (i in 1:nrow(A)) {
+ ii <- which(A[,i]>0)
+ if (length(ii)>0)
+ edgelist <- rbind(edgelist,data.frame(from=ii,to=i))
+ }
+ if (labels) edgelist <- as.data.frame(apply(edgelist,2,function(x) vars(object)[x]))
+ edgelist
+}
+
+##' @export
+parents.lvmfit <- function(object,...) parents(Model(object),...)
+
+##' @export
+children.lvmfit <- function(object,...) children(Model(object),...)
+
+##' @export
+descendants.lvmfit <- function(object,...) descendants(Model(object),...)
+
+##' @export
+ancestors.lvmfit <- function(object,...) ancestors(Model(object),...)
+
+##' @export
+roots.lvmfit <- function(object,...) roots(Model(object),...)
+
+##' @export
+sinks.lvmfit <- function(object,...) sinks(Model(object),...)
+
+
+
+##' @export
+parents.lvm <- function(object,var,...) {
+ A <- index(object)$A
+ if (missing(var)) {
+ return(rownames(A))
+ }
+ if (inherits(var,"formula"))
+ var <- all.vars(var)
+ res <- lapply(var, function(v) rownames(A)[A[,v]!=0])
+ res <- unique(unlist(res))
+ if (length(res)==0) res <- NULL
+ res
+}
+
+##' @export
+children.lvm <- function(object,var,...) {
+ A <- index(object)$A
+ if (missing(var)) {
+ return(rownames(A))
+ }
+ if (inherits(var,"formula"))
+ var <- all.vars(var)
+ res <- lapply(var, function(v) rownames(A)[A[v,]!=0])
+ res <- unique(unlist(res))
+ if (length(res)==0) res <- NULL
+ res
+}
+
+
+##' @export
+ancestors.lvm <- function(object,x,...) {
+ if (inherits(x,"formula")) x <- all.vars(x)
+ res <- c()
+ left <- setdiff(vars(object),x)
+ count <- 0
+ child <- x
+ while (length(x)>0) {
+ count <- count+1
+ x <- parents(object,child)
+ child <- intersect(x,left)
+ res <- union(res,child)
+ left <- setdiff(left,child)
+ }
+ if (length(res)==0) res <- NULL
+ return(res)
+}
+
+##' @export
+descendants.lvm <- function(object,x,...) {
+ if (inherits(x,"formula")) x <- all.vars(x)
+ res <- c()
+ left <- setdiff(vars(object),x)
+ count <- 0
+ parent <- x
+ while (length(x)>0) {
+ count <- count+1
+ x <- children(object,parent)
+ parent <- intersect(x,left)
+ res <- union(res,parent)
+ left <- setdiff(left,parent)
+ }
+ if (length(res)==0) res <- NULL
+ return(res)
+}
+
+##' @export
+roots.lvm <- function(object,...) {
+ return(exogenous(object,index=FALSE,...))
+}
+
+##' @export
+sinks.lvm <- function(object,...) {
+ return(endogenous(object,top=TRUE,...))
+}
diff --git a/R/cluster.hook.R b/R/cluster.hook.R
new file mode 100644
index 0000000..5b5ac84
--- /dev/null
+++ b/R/cluster.hook.R
@@ -0,0 +1,87 @@
+cluster.post.hook <- function(x,...) {
+ if (class(x)[1]=="multigroupfit") {
+ if (is.null(x$cluster)) return(NULL)
+ if (any(unlist(lapply(x$cluster,is.null)))) return(NULL)
+ allclusters <- unlist(x$cluster)
+ uclust <- unique(allclusters)
+ K <- length(uclust)
+ G <- x$model$ngroup
+ S0 <- lapply(score(x,indiv=TRUE), function(x) { x[which(is.na(x))] <- 0; x })
+ S <- matrix(0,length(pars(x)),nrow=K)
+ aS <- c() ##matrix(0,S[[1]]
+ for (i in uclust) {
+ for (j in seq_len(G)) {
+ idx <- which(x$cluster[[j]]==i)
+ if (length(idx)>0)
+ S[i,] <- S[i,] + colSums(S0[[j]][idx,,drop=FALSE])
+ }
+ }
+ J <- crossprod(S)
+ I <- information(x,type="hessian",...)
+ iI <- Inverse(I)
+ asVar <- iI%*%J%*%iI
+ x$vcov <- asVar
+ return(x)
+ }
+
+ ## lvmfit:
+ if (!is.null(x$cluster)) {
+ uclust <- unique(x$cluster)
+ K <- length(uclust)
+ S <- score(x,indiv=TRUE) #,...)
+ I <- information(x,type="hessian") #,...)
+ iI <- Inverse(I)
+
+ S0 <- matrix(0,ncol=ncol(S),nrow=K)
+ count <- 0
+ ## J1 <- matrix(0,ncol=ncol(S),nrow=ncol(S))
+ for (i in uclust) {
+ count <- count+1
+ S0[count,] <- colSums(S[which(x$cluster==i),,drop=FALSE])
+ ## J1 <- J1+tcrossprod(S0[count,])
+ };
+ p <- ncol(S)
+ ## adj1 <- 1
+ adj1 <- K/(K-1)
+ ## adj1 <- K/(K-p) ## Mancl & DeRouen, 2001
+
+ J <- adj1*crossprod(S0)
+ col3 <- sqrt(diag(iI)); ## Naive se
+ nn <- c("Estimate","Robust SE", "Naive SE", "P-value")
+ asVar <- iI%*%J%*%iI
+ } else {
+ asVar <- x$vcov
+ }
+ diag(asVar)[diag(asVar)==0] <- NA
+ mycoef <- x$opt$estimate
+ x$vcov <- asVar
+ SD <- sqrt(diag(asVar))
+ Z <- mycoef/SD
+ pval <- 2*(pnorm(abs(Z),lower.tail=FALSE))
+ if (is.null(x$cluster)) {
+ col3 <- Z
+ nn <- c("Estimate","Std. Error", "Z-value", "P-value")
+ }
+ newcoef <- cbind(mycoef, SD, col3, pval);
+ nparall <- index(x)$npar + ifelse(x$control$meanstructure, index(x)$npar.mean,0)
+ if (!is.null(x$expar)) {
+ nparall <- nparall+length(x$expar)
+ }
+ mycoef <- matrix(NA,nrow=nparall,ncol=4)
+ mycoef[x$pp.idx,] <- newcoef
+ colnames(mycoef) <- nn
+ mynames <- c()
+ if (x$control$meanstructure) {
+ mynames <- vars(x)[index(x)$v1==1]
+ }
+ if (index(x)$npar>0) {
+ mynames <- c(mynames,paste0("p",seq_len(index(x)$npar)))
+ }
+ if (!is.null(x$expar)) {
+ mynames <- c(mynames,names(x$expar))
+ }
+
+ rownames(mycoef) <- mynames
+ x$coef <- mycoef
+ return(x)
+}
diff --git a/R/coef.R b/R/coef.R
new file mode 100644
index 0000000..8a91849
--- /dev/null
+++ b/R/coef.R
@@ -0,0 +1,765 @@
+###{{{ coef.lvm
+
+##' @export
+`coef.lvm` <-
+ function(object, mean=TRUE, fix=TRUE, symbol=lava.options()$symbol, silent=TRUE, p, data, vcov, level=9, labels=lava.options()$coef.names, ...) {
+ if (fix)
+ object <- fixsome(object,measurement.fix=FALSE)
+ if (!missing(p)) {
+ coefs <- matrix(NA,nrow=length(p),ncol=4); coefs[,1] <- p
+ rownames(coefs) <- c(coef(object,mean=TRUE,fix=FALSE)[c(seq_len(index(object)$npar.mean))],
+ {if (index(object)$npar>0) paste0("p",seq_len(index(object)$npar)) },
+ {if (index(object)$npar.ex>0) paste0("e",seq_len(index(object)$npar.ex))} )
+ if (missing(vcov)) {
+ if (!missing(data) && !is.null(data)) {
+ I <- information(object,p=p,data=data,type="E")
+ myvcov <- solve(I)
+ } else {
+ myvcov <- matrix(NA,length(p),length(p))
+ }
+ object$vcov <- myvcov
+ } else object$vcov <- vcov
+ coefs[,2] <- sqrt(diag(object$vcov))
+ coefs[,3] <- coefs[,1]/coefs[,2]
+ coefs[,4] <- 2*(pnorm(abs(coefs[,3]),lower.tail=FALSE))
+ colnames(coefs) <- c("Estimate","Std. Error", "Z value", "Pr(>|z|)")
+ object$coefficients <- coefs;
+ return(coef.lvmfit(object,level=level,labels=labels,symbol=symbol,...))
+ }
+
+
+ ## Free regression/covariance parameters
+ AP <- matrices(object, paste0("p",seq_len(index(object)$npar)))
+ A <- AP$A; A[index(object)$M1==0] <- "0" ## Only free parameters
+ P <- AP$P; P[index(object)$P1==0] <- "0"; P[upper.tri(P)] <- "0"
+ nn <- vars(object)
+
+ counter <- 0
+ res <- c()
+ resname <- c()
+
+ ## if (DEBUG) {
+ ii <- which(t(A)!="0",arr.ind=TRUE)
+ rname <- paste(nn[ii[,1]],nn[ii[,2]],sep=symbol[1])
+ if (labels) {
+ rname2 <- t(regfix(Model(object))$labels)[ii]
+ rname[which(!is.na(rname2))] <- rname2[which(!is.na(rname2))]
+ }
+ res <- rname
+ resname <- c(resname,t(A)[ii])
+ ## } else
+ ## for (i in seq_len(ncol(A)))
+ ## for (j in seq_len(nrow(A))) {
+ ## val <- A[j,i]
+ ## if (val!="0") {
+ ## if (labels & !is.na(regfix(Model(object))$labels[j,i]))
+ ## res <- c(res, regfix(Model(object))$labels[j,i])
+ ## else
+ ## res <- c(res, paste0(nn[i],symbol[1],nn[j]))
+ ## counter <- counter+1
+ ## resname <- c(resname, val)
+ ## }
+ ## }
+
+ ## if (DEBUG) {
+ ii <- which(P!="0",arr.ind=TRUE)
+ if (length(symbol)<2)
+ rname <- paste(nn[ii[,2]],nn[ii[,1]],sep=lava.options()$symbol[2])
+ else
+ rname <- paste(nn[ii[,2]],nn[ii[,1]],sep=symbol[2])
+ if (labels) {
+ rname2 <- (covfix(Model(object))$labels)[ii]
+ rname[which(!is.na(rname2))] <- rname2[which(!is.na(rname2))]
+ }
+ res <- c(res,rname)
+ resname <- c(resname,P[ii])
+ ## } else
+ ## for (i in seq_len(ncol(P)))
+ ## for (j in seq(i,nrow(P)))
+ ## {
+ ## val <- P[j,i]
+ ## if (val!="0") {
+ ## counter <- counter+1
+ ## if (length(symbol)<2) {
+ ## if (nn[i]!=nn[j]) {
+ ## part2 <- paste(nn[i],nn[j],sep=",")
+ ## } else part2 <- nn[i]
+ ## } else {
+ ## part2 <- paste0(nn[i],symbol[2],nn[j])
+ ## }
+ ## if (labels & !is.na(covfix(Model(object))$labels[j,i]))
+ ## res <- c(res, covfix(Model(object))$labels[j,i])
+ ## else
+ ## res <- c(res, part2)
+ ## resname <- c(resname, val)
+ ## }
+ ## }
+
+ names(res) <- resname
+ resnum <- sapply(resname, function(s) char2num(substr(s,2,nchar(s))))
+ res <- res[order(resnum)]
+ if (mean) {
+ nmean <- sum(index(object)$v1==1)
+ if (nmean>0) {
+
+ if (!labels)
+ res <- c(vars(object)[index(object)$v1==1], res)
+ else {
+ mres <- c()
+ for (i in seq_len(length(index(object)$v1))) {
+ val <- index(object)$v1[i]
+ if (val==1) {
+ if (!is.na(intfix(Model(object))[[i]])) {
+ mres <- c(mres, intfix(Model(object))[[i]])
+ }
+ else
+ mres <- c(mres, vars(object)[i])
+ }
+ }
+ res <- c(mres,res)
+ }
+ names(res)[seq_len(nmean)] <- paste0("m",seq_len(nmean))
+ }
+ }
+ if (!is.null(object$expar) && sum(index(object)$e1==1)>0) {
+ n2 <- names(object$expar)[index(object)$e1==1]
+ if (labels) {
+ count <- 0
+ for (i in seq_len(length(index(object)$e1))) {
+ if (index(object)$e1[i]==1) {
+ val <- object$exfix[[i]]
+ count <- count+1
+ if(!is.na(val)) n2[count] <- val
+ }
+ }
+ }
+ names(n2) <- paste0("e",seq_len(length(n2)))
+ res <- c(res,n2)
+ }
+
+ if (!silent) {
+ cat(paste(res, collapse="\n")); cat("\n")
+ }
+ if (!is.null(object$order)) res <- res[object$order]
+ res
+ }
+
+###}}}
+
+###{{{ coef.lvmfit
+
+##' @export
+`coef.lvmfit` <-
+function(object, level=ifelse(missing(type),-1,2),
+ symbol=lava.options()$symbol,
+ data, std=NULL,
+ labels=lava.options()$coef.names,
+ ##labels=TRUE,
+ vcov,
+ type, reliability=FALSE, second=FALSE, ...) {
+
+ res <- (pars.default(object,...))
+ if (level<0 && !is.null(names(res))) return(res)
+
+ if (is.null(object$control$meanstructure)) meanstructure <- TRUE
+ else meanstructure <- object$control$meanstructure
+ npar <- index(object)$npar; npar.mean <- index(object)$npar.mean*meanstructure
+ npar.ex <- index(object)$npar.ex
+
+ para <- parameter(Model(object))
+ para.idx <- which(vars(object)%in%para)
+
+
+ if (inherits(object,"lvm.missing")) {
+ if (length(object$cc)==0) {## No complete cases
+ coefs <- coef(object$estimate)
+ c1 <- coef(Model(object),mean=TRUE,fix=FALSE)
+ c1. <- coef(Model(object),mean=FALSE,fix=FALSE)
+ nn <- gsub("^[0-9]*@","",names(coefs))
+ myorder <- match(c1,nn)
+ myorder.reg <- order(na.omit(match(nn,c1.)))
+ myorder.extra <- c()
+ ##mp <-effect modelPar(object,seq_len(npar+npar.mean+npar.ex))
+ ## mp <- modelPar(object,seq_len(npar+npar.mean+npar.ex))
+ ## myorder <- c(mp$meanpar,mp$p)
+ ## myorder.reg <- seq_len(length(mp$p))
+ ## myorder.extra <- mp$p2
+ } else {
+ myorder <- na.omit(modelPar(object$multigroup,seq_len(npar+npar.mean))$p[[object$cc]])
+ myorder.reg <- na.omit(modelPar(object$multigroup,seq_len(npar))$p[[object$cc]])
+ myorder.extra <- seq_len(index(object)$npar.ex)+length(myorder)
+ myorder <- c(myorder,myorder.extra)
+
+ }
+ } else {
+ myorder <- seq_len(npar+npar.mean)
+ myorder.reg <- seq_len(npar)
+ myorder.extra <- seq_len(index(object)$npar.ex)+length(myorder)
+ myorder <- c(myorder,myorder.extra)
+ }
+ ## myorder <- seq_len(npar+npar.mean)
+ ## myorder.reg <- seq_len(npar)
+ ## myorder.extra <- seq_len(index(object)$npar.ex)+length(myorder)
+ ## myorder <- c(myorder,myorder.extra)
+
+
+ if (level<0) {
+ names(res)[seq_len(length(myorder))] <- coef(Model(object),fix=FALSE, mean=meanstructure, symbol=symbol)[order(myorder)]
+ return(res)
+ }
+
+
+ latent.var <- latent(object)
+ latent.idx <- which(vars(object)%in%latent.var)
+ Type <- Var <- From <- VarType <- FromType <- c()
+
+ Astd <- Pstd <- vstd <- mytype <- NULL
+ if (!is.null(std)) {
+ stdCoef <- stdcoef(object)
+ {
+ switch(tolower(std),
+ latent = {Astd=stdCoef$Astar; Pstd=stdCoef$Pstar; vstd=stdCoef$vstar},
+ y = {Astd=stdCoef$AstarY; Pstd=stdCoef$PstarY; vstd=stdCoef$vstarY},
+ xy = {Astd=stdCoef$AstarXY; Pstd=stdCoef$PstarXY; vstd=stdCoef$vstarXY},
+ yx = {Astd=stdCoef$AstarXY; Pstd=stdCoef$PstarXY; vstd=stdCoef$vstarXY}
+ )
+ }
+ }
+ myparnames <- paste0("p",seq_len(npar+npar.ex))[myorder.reg]
+
+ p <- matrices(Model(object), myparnames)
+ A <- p$A
+ P <- p$P
+ mycoef <- object$coef
+ if (!missing(type) | !missing(vcov)) {
+ if (!missing(vcov)) {
+ mycoef[,2] <- sqrt(diag(vcov))[myorder]
+ } else {
+ if (!missing(data))
+ myvcov <- information(object,type=type,data=data,inverse=TRUE)
+ else
+ myvcov <- information(object,type=type,inverse=TRUE)
+ mycoef[,2] <- sqrt(diag(myvcov))[myorder]
+ }
+ mycoef[,3] <- mycoef[,1]/mycoef[,2]
+ mycoef[,4] <- 2*(pnorm(abs(mycoef[,3]),lower.tail=FALSE))
+ }
+
+ coefs <- mycoef[myorder,,drop=FALSE]
+ nn <- colnames(A)
+
+ free <- A!="0"
+ free[index(object)$M1!=1] <- FALSE
+ nlincon <- matrix(Model(object)$par%in%names(constrain(Model(object))),nrow(A))
+ if (missing(data)) {
+ data <- matrix(0,ncol=length(index(Model(object))$manifest)); colnames(data) <- index(Model(object))$manifest
+ }
+ nlincon.estimates.full<- constraints(object,second=second,data=data)
+ nlincon.estimates <- nlincon.estimates.full[,-(5:6),drop=FALSE]
+ matched <- c()
+ res <- c()
+ for (i in seq_len(ncol(A)))
+ for (j in seq_len(nrow(A))) {
+ val <- A[j,i]
+ if (val!="0") {
+ matching <- match(val,rownames(coefs))
+ matched <- c(matched,matching)
+ if (!is.na(matching)) {
+ if (free[j,i])
+ newrow <- matrix(coefs[matching,],nrow=1)
+ else {
+ newrow <- matrix(c(coefs[matching,1],NA,NA,NA), nrow=1)
+ }
+ } else {
+ Debug(list("(i,j)", i, ",", j))
+ if (nlincon[j,i]) {
+ newrow <- matrix(nlincon.estimates[Model(object)$par[j,i],],nrow=1)
+ } else {
+ newrow <- matrix(c(Model(object)$fix[j,i], NA, NA, NA), nrow=1)
+ }
+ }
+ if (!is.null(std)) {
+ newrow <- cbind(newrow,Astd[j,i])
+ }
+ if (labels & !is.na(regfix(Model(object))$labels[j,i])) {
+ rownames(newrow) <- regfix(Model(object))$labels[j,i]
+ if (labels>1) {
+ newst <- paste0(nn[i],symbol[1],nn[j])
+ if (rownames(newrow)!=newst)
+ rownames(newrow) <- paste(rownames(newrow),newst,sep=":")
+ }
+ } else {
+ rownames(newrow) <- paste0(nn[i],symbol[1],nn[j])
+ }
+ if (free[j,i] | level>2) {
+ res <- rbind(res, newrow)
+ Type <- c(Type,"regression")
+ Var <- c(Var, nn[i])
+ From <- c(From, nn[j])
+ }
+ }
+ }
+ free.var <- P!="0"
+ free.var[index(object)$P1!=1] <- FALSE
+ nlincon.var <- matrix(Model(object)$covpar%in%names(constrain(Model(object))),nrow(P))
+
+ if (level>0)
+ ## Variance estimates:
+ for (i in seq_len(ncol(p$P)))
+ for (j in seq(i,nrow(p$P))) {
+ val <- p$P[j,i]
+
+ if (!(i%in%para.idx))
+ if (val!="0" & !any(vars(object)[c(i,j)]%in%index(Model(object))$exogenous))
+ if (level>1 | !all(vars(object)[c(i,j)]%in%index(Model(object))$manifest))
+ {
+ matching <- match(val,rownames(coefs))
+ matched <- c(matched,matching)
+
+ if (!is.na(matching)) {
+ if (free.var[j,i])
+ newrow <- matrix(coefs[matching,],nrow=1)
+ else
+ newrow <- matrix(c(coefs[matching,1],NA,NA,NA), nrow=1)
+ ## We don't want to report p-values of tests on the boundary of the parameter space
+ if (i==j)
+ newrow[,4] <- NA
+ } else {
+ Debug(list("(i,j)", i, ",", j))
+ if (nlincon.var[j,i]) {
+ newrow <- matrix(nlincon.estimates[Model(object)$covpar[j,i],],nrow=1)
+ } else {
+ newrow <- matrix(c(Model(object)$covfix[j,i], NA, NA, NA), nrow=1)
+ }
+ }
+ if (!missing(std)) {
+ newrow <- cbind(newrow,Pstd[i,j])
+ }
+ if (length(symbol)<2) {
+ if (nn[i]!=nn[j]) {
+ part2 <- paste(nn[i],nn[j],sep=lava.options()$symbol[2])
+ } else part2 <- nn[i]
+ } else {
+ part2 <- paste0(nn[i],symbol[2],nn[j])
+ }
+ if (labels & !is.na(covfix(Model(object))$labels[j,i])) {
+ rownames(newrow) <- covfix(Model(object))$labels[j,i]
+ if (labels>1) {
+ if (rownames(newrow)!=part2)
+ rownames(newrow) <- paste(rownames(newrow),part2,sep=":")
+ }
+ } else {
+ rownames(newrow) <- part2
+ }
+ if ((free.var[j,i]) | level>2) {
+ res <- rbind(res, newrow)
+ Type <- c(Type,"variance")
+ Var <- c(Var, nn[i])
+ From <- c(From, nn[j])
+ }
+ }
+ }
+ res0 <- res
+
+ ## Mean parameter:
+ nlincon.mean <- lapply(Model(object)$mean, function(x) x%in%names(constrain(Model(object))) )
+
+ if (level>0 & npar.mean>0) {
+ midx <- seq_len(npar.mean)
+ rownames(coefs)[midx] <- paste0("m",myorder[midx])
+ munames <- rownames(coefs)[seq_len(npar.mean)]
+ meanpar <- matrices(Model(object), myparnames, munames)$v
+ for (i in seq_len(length(meanpar))) {
+ if (!index(Model(object))$vars[i]%in%index(Model(object))$exogenous) {
+ val <- meanpar[i]
+ matching <- match(val,rownames(coefs))
+ if (!is.na(matching)) {
+ if (index(object)$v1[i]==1) ## if free-parameter
+ newrow <- matrix(coefs[matching,],nrow=1)
+ else
+ newrow <- matrix(c(coefs[matching,1],NA,NA,NA), nrow=1)
+ } else {
+ if (nlincon.mean[[i]]) {
+ newrow <- matrix(nlincon.estimates[Model(object)$mean[[i]],],nrow=1)
+ } else {
+ newrow <- matrix(c(as.numeric(meanpar[i]), NA, NA, NA), nrow=1) }
+ }
+ if (!missing(std)) {
+ newrow <- cbind(newrow,vstd[i])
+ }
+ if (labels & !(is.na(intfix(Model(object))[[i]]) | is.numeric(intfix(Model(object))[[i]]))) {
+ rownames(newrow) <- intfix(Model(object))[[i]]
+ if (labels>1) {
+ if (rownames(newrow)!=index(Model(object))$vars[i])
+ rownames(newrow) <- paste(rownames(newrow),index(Model(object))$vars[i],sep=":")
+ }
+ } else {
+ rownames(newrow) <- index(Model(object))$vars[i]
+ }
+ if ((index(object)$v1[i]==1) | level>2) {
+ res <- rbind(res, newrow)
+ Type <- c(Type,ifelse(!(i%in%para.idx),"intercept","parameter"))
+ Var <- c(Var, index(Model(object))$vars[i])
+ From <- c(From, NA)
+ }
+ }
+ }
+ }
+
+ if (level>0 && length(myorder.extra>0)) {
+ cc <- coefs[myorder.extra,,drop=FALSE]
+ rownames(cc) <- rownames(index(object)$epar)[which(index(object)$e1==1)]
+ cc <- cbind(cc,rep(NA,ncol(res)-ncol(cc)))
+ res <- rbind(res,cc)
+ Type <- c(Type,rep("extra",length(myorder.extra)))
+ Var <- c(Var,rep(NA,length(myorder.extra)))
+ From <- c(From,rep(NA,length(myorder.extra)))
+ }
+
+ mycolnames <- colnames(coefs)
+ if (!is.null(std)) mycolnames <- c(mycolnames, paste("std",std,sep="."))
+ colnames(res) <- mycolnames
+ attributes(res)$type <- Type
+ attributes(res)$var <- Var
+ attributes(res)$from <- From
+ attributes(res)$latent <- latent.var
+ attributes(res)$nlincon <- nlincon.estimates.full
+
+ return(res)
+}
+
+###}}} coef.lvmfit
+
+###{{{ coef.multigroup
+
+##' @export
+coef.multigroup <- function(object,...) {
+ return(object$parpos)
+}
+
+###}}} coef.multigroup
+
+###{{{ coef.multigroupfit
+
+##' @export
+coef.multigroupfit <-
+ function(object, level=0,vcov, ext=FALSE,
+ labels=lava.options()$coef.names,
+ symbol=lava.options()$symbol,
+ covsymb=NULL,groups=NULL,...) {
+
+ if (level==0) {
+ res <- pars(object);
+ if (is.null(names(res))) names(res) <- object$model$name
+ return(res)
+ }
+ if (level==1) {
+ theta <- pars(object)
+ if (missing(vcov))
+ theta.sd <- sqrt(diag(object$vcov))
+ else
+ theta.sd <- sqrt(diag(vcov))
+ res <- cbind(theta,theta.sd,(Z <- theta/theta.sd),2*(pnorm(abs(Z),lower.tail=FALSE)))
+ if (is.null(rownames(res)))
+ rownames(res) <- object$model$name
+ colnames(res) <- c("Estimate","Std. Error", "Z value", "Pr(>|z|)")
+ return(res)
+ }
+
+ cc <- coef(object, level=1, symbol=symbol, ...)
+ model <- Model(object)
+ parpos <- modelPar(model, seq_len(nrow(cc)))$p
+ npar.mean <- object$model$npar.mean
+ npar <- object$model$npar
+ mynames <- c()
+ if (npar.mean>0) {
+ mynames <- unlist(object$model$meanlist)
+ mynames <- names(mynames)[!duplicated(mynames)]
+ }
+ if (npar>0) {
+ mynames <- c(mynames,object$model$par)
+ }
+
+ res <- list()
+ misrow <- list()
+ parpos2 <- list()
+ if (is.null(groups)) groups <- seq(model$ngroup)
+ if (length(groups)==0) groups <- seq(model$ngroup)
+ for (i in groups) {
+ orignames <- coef(object$model0$lvm[[i]],fix=FALSE,mean=object$meanstructure, silent=TRUE, symbol=lava.options()$symbol)
+ if (ext) {
+ newnames. <- coef(Model(model)[[i]],fix=FALSE, mean=object$meanstructure, silent=TRUE, labels=labels, symbol=symbol)
+ newnames <- coef(Model(model)[[i]],fix=FALSE, mean=object$meanstructure, silent=TRUE, labels=labels,symbol=lava.options()$symbol)
+ newcoef <- matrix(NA,ncol=4,nrow=length(newnames))
+ rownames(newcoef) <- newnames.
+ idx <- match(orignames,newnames)
+ newcoef[idx,] <- cc[parpos[[i]],,drop=FALSE]
+ newparpos <- rep(NA,length(newnames))
+ newparpos[idx] <- parpos[[i]]
+ parpos2 <- c(parpos2, list(newparpos))
+ misrow <- c(misrow, list(setdiff(seq_len(length(newnames)),idx)))
+ } else {
+ newcoef <- cc[parpos[[i]],,drop=FALSE]
+ rownames(newcoef) <- orignames
+ }
+ colnames(newcoef) <- colnames(cc)
+ ## Position of variance parameters:
+ varpos <- variances(Model(model)[[i]],mean=FALSE)
+ ## Number of parameters resp mean-parameters
+ p <- nrow(newcoef); p0 <- length(coef(Model(model)[[i]],fix=FALSE, mean=FALSE, silent=TRUE))
+ newcoef[(p-p0) + varpos,4] <- NA
+ res <- c(res, list(newcoef))
+ }
+
+ if (ext) {
+ for (i in seq(length(groups))) {
+ if (length(misrow[[i]])>0) {
+ nn <- rownames(res[[i]])[misrow[[i]]]
+ for (j in setdiff(seq_len(length(groups)),i)) {
+ nn2 <- rownames(res[[j]])
+ matching <- na.omit(match(nn,nn2))
+ matching <- setdiff(matching,misrow[[j]])
+ if (length(matching)>0) {
+ idxj <- match(nn2[matching],nn2)
+ idxi <- match(nn2[matching],rownames(res[[i]]))
+ res[[i]][nn2[matching],] <- res[[j]][nn2[matching],]
+ parpos2[[i]][idxi] <- parpos2[[j]][idxj]
+ nn <- setdiff(nn,nn2[matching])
+ }
+ if (length(nn)<1) break;
+ }
+ }
+ }
+ attributes(res)$parpos <- parpos2
+ }
+ return(res)
+}
+
+###}}}
+
+###{{{ CoefMat
+
+##' @export
+CoefMat.multigroupfit <- function(x,level=9,
+ labels=lava.options()$coef.names,
+ symbol=lava.options()$symbol[1],
+ data=NULL,groups=seq(Model(x)$ngroup),...) {
+
+ cc <- coef(x,level=level,ext=TRUE,symbol=symbol,data=data,groups=groups)
+ parpos <- attributes(cc)$parpos
+ res <- c()
+ nlincon.estimates <- c()
+ nlincon.names <- c()
+ count <- k <- 0
+
+ for (i in groups) {
+ k <- k+1
+ m0 <- Model(Model(x))[[i]]
+ mycoef <- cc[[k]]
+ npar <- index(m0)$npar
+ npar.mean <- index(m0)$npar.mean
+ if (npar>0)
+ rownames(mycoef)[(seq(npar))+npar.mean] <- paste0("p",seq(npar))
+ m0$coefficients <- mycoef
+ m0$opt$estimate <- mycoef[,1]
+ Vcov <- vcov(x)[parpos[[k]],parpos[[k]],drop=FALSE]; colnames(Vcov) <- rownames(Vcov) <- rownames(mycoef)
+ m0$vcov <- Vcov
+ cc0 <- coef.lvmfit(m0,level=level,labels=labels,symbol=symbol)
+ attributes(cc0)$dispname <- x$opt$dispname
+ res <- c(res, list(CoefMat(cc0)))
+ newnlin <- attributes(cc0)$nlincon
+ if (length(newnlin)>0)
+ if (count==0) {
+ count <- count+1
+ nlincon.estimates <- newnlin
+ nlincon.names <- rownames(newnlin)
+ } else {
+ for (j in seq_len(NROW(newnlin))) {
+ if (!(rownames(newnlin)[j]%in%nlincon.names)) {
+ nlincon.estimates <- rbind(nlincon.estimates,newnlin[j,,drop=FALSE])
+ nlincon.names <- c(nlincon.names,rownames(newnlin)[j])
+ }
+ }
+ }
+ }
+ rownames(nlincon.estimates) <- nlincon.names
+ attributes(res)$nlincon <- nlincon.estimates
+ return(res)
+}
+
+
+##' @export
+CoefMat <- function(x,
+ digits = max(3, getOption("digits") - 2),
+ level=9,
+ symbol=lava.options()$symbol[1],...) {
+ cc <- x
+ if (!is.matrix(x)) {
+ cc <- coef(x,level=level,symbol=symbol,...)
+ }
+ res <- c()
+ mycoef <- format(round(cc,max(1,digits)),digits=digits)
+ mycoef[,4] <- formatC(cc[,4],digits=digits-1,format="g",
+ preserve.width="common",flag="")
+ mycoef[is.na(cc)] <- ""
+ mycoef[cc[,4]<1e-12,4] <- " <1e-12"
+
+ M <- ncol(cc)
+ N <- nrow(cc)
+ Nreg <- sum(attributes(cc)$type=="regression")
+ Nvar <- sum(attributes(cc)$type=="variance")
+ Nint <- sum(attributes(cc)$type=="intercept")
+ Nextra <- sum(attributes(cc)$type=="extra")
+
+ latent.var <- attributes(cc)$latent
+
+
+ if (Nreg>0) {
+ reg.idx <- which(attributes(cc)$type=="regression")
+ latent.from <- which(attributes(cc)$from[reg.idx]%in%latent.var)
+ latent.from <- latent.from[which(is.na(match(attributes(cc)$var[latent.from],latent.var)))]
+
+ reg.idx <- setdiff(reg.idx,latent.from)
+ Nmeas <- length(latent.from)
+ if (Nmeas>0) {
+ first.entry <- c()
+ for (i in latent.var) {
+ pos <- match(i,attributes(cc)$from[latent.from])
+ if (!is.na(pos))
+ first.entry <- c(first.entry, pos)
+ }
+ res <- rbind(res, c("Measurements:",rep("",M)))
+ count <- 0
+ Delta <- FALSE
+ for (i in latent.var) {
+ count <- count+1
+ Delta <- !Delta
+ Myidx <- which(attributes(cc)$from==i & attributes(cc)$type=="regression" & !(attributes(cc)$var%in%latent.var))
+
+ prefix <- ifelse(Delta," "," ")
+ for (j in Myidx) {
+ newrow <- mycoef[j,]
+ newname <- rownames(cc)[j]
+ res <- rbind(res,c(paste(prefix,newname),newrow))
+ }
+ }
+ }
+ if ((Nreg-Nmeas)>0) {
+ responses <- unique(attributes(cc)$var[reg.idx])
+ first.entry <- c()
+ for (i in responses) {
+ pos <- match(i,attributes(cc)$var[reg.idx])
+ first.entry <- c(first.entry, pos)
+ }
+ res <- rbind(res, c("Regressions:",rep("",M)))
+ count <- 0
+ Delta <- FALSE
+ for (i in reg.idx) {
+ count <- count+1
+ newrow <- mycoef[i,]
+ newname <- rownames(cc)[i]
+ if (count%in%first.entry) Delta <- !Delta
+ prefix <- ifelse(Delta," "," ")
+ res <- rbind(res,c(paste(prefix,newname),newrow))
+ }
+ }
+ }
+
+
+ if (Nint>0) {
+ int.idx <- which(attributes(cc)$type=="intercept")
+ res <- rbind(res, c("Intercepts:",rep("",M)))
+ for (i in int.idx) {
+ newrow <- mycoef[i,]
+ newname <- rownames(cc)[i]
+ res <- rbind(res,c(paste(" ",newname),newrow))
+ }
+ }
+ par.idx <- which(attributes(cc)$type=="parameter")
+ parres <- rbind(c("Additional Parameters:",rep("",M)))
+ for (i in par.idx) {
+ newrow <- mycoef[i,]
+ newname <- rownames(cc)[i]
+ parres <- rbind(parres,c(paste(" ",newname),newrow))
+ }
+ extra.idx <- which(attributes(cc)$type=="extra")
+ for (i in extra.idx) {
+ newrow <- mycoef[i,]
+ newname <- rownames(cc)[i]
+ parres <- rbind(parres,c(paste(" ",newname),newrow))
+ }
+ if (nrow(parres)>1) res <- rbind(res,parres)
+
+
+
+ if (Nvar>0) {
+ var.idx <- which(attributes(cc)$type=="variance")
+ vname <- "Residual Variances:"
+ if (!is.list(x)) {
+ if (!is.null(attributes(x)$dispname)) vname <- attributes(x)$dispname
+ } else if (!is.null(x$opt$dispname)) vname <- x$opt$dispname
+ res <- rbind(res, c(vname,rep("",M)))
+ for (i in var.idx) {
+ newrow <- mycoef[i,]
+ newname <- rownames(cc)[i]
+ res <- rbind(res,c(paste(" ",newname),newrow))
+ }
+}
+ res0 <- res[,-1]
+ rownames(res0) <- format(res[,1],justify="left")
+ res0
+}
+
+###}}} CoefMat
+
+###{{{ standardized coefficients
+
+stdcoef <- function(x,p=coef(x),...) {
+ M0 <- moments(x,p=p,...)
+ A <- t(M0$A)
+ P <- M0$P
+ v <- M0$v
+ C <- M0$Cfull
+ N <- diag(sqrt(diag(C)),ncol=nrow(C)); colnames(N) <- rownames(N) <- vars(x)
+ iN <- N; diag(iN)[diag(N)>0] <- 1/diag(iN)[diag(N)>0]
+ diag(iN)[diag(N)==0] <- NA
+ Nn <- N; Nn[] <- 0; diag(Nn) <- 1
+ Nn[latent(x),latent(x)] <- N[latent(x),latent(x)]
+ iNn <- Nn; diag(iNn) <- 1/diag(Nn)
+ Ny <- Nn;
+ Ny[endogenous(x),endogenous(x)] <- N[endogenous(x),endogenous(x)]
+ iNy <- Ny; diag(iNy) <- 1/diag(Ny)
+ ## Standardized w.r.t. latent,y and x:
+ AstarXY <- t(iN%*%A%*%N)
+ PstarXY <- iN%*%P%*%iN
+ if (!is.null(v))
+ vstarXY <- iN%*%v
+ else
+ vstarXY <- NULL
+ pstdXY <- pars(Model(x),A=AstarXY,P=PstarXY,v=vstarXY)
+ ## Standardized w.r.t. latent, y:
+ AstarY <- t(iNy%*%A%*%Ny)
+ PstarY <- iNy%*%P%*%iNy
+ if (!is.null(v))
+ vstarY <- iNy%*%v
+ else
+ vstarY <- NULL
+ pstdY <- pars(Model(x),A=AstarY,P=PstarY,v=vstarY)
+ ## Standardized w.r.t. latent only:
+ Astar <- t(iNn%*%A%*%Nn)
+ Pstar <- iNn%*%P%*%iNn
+ if (!is.null(v))
+ vstar <- iNn%*%v
+ else
+ vstar <- NULL
+ pstd <- pars(Model(x),A=Astar,Pstar,v=vstar)
+ k <- length(p)-length(pstd)
+
+ res <- list(par=cbind(p,c(pstd,rep(NA,k)),c(pstdXY,rep(NA,k))),
+ AstarXY=AstarXY, PstarXY=PstarXY, vstarXY=vstarXY,
+ AstarY=AstarY, PstarY=PstarY, vstarY=vstarY,
+ Astar=Astar, Pstar=Pstar, vstar=vstar)
+ return(res)
+}
+
+###}}} standardized coefficients
diff --git a/R/combine.R b/R/combine.R
new file mode 100644
index 0000000..c3cb888
--- /dev/null
+++ b/R/combine.R
@@ -0,0 +1,65 @@
+
+excoef <- function(x,digits=2,p.digits=3,format=FALSE,fun,se=FALSE,ci=TRUE,pvalue=TRUE,...) {
+ cc <- coef(summary(x))
+ res <- round(cbind(cc[,1:3,drop=FALSE],confint(x)),max(1,digits))
+ pvalround <- round(cc[,4], max(1, p.digits))
+ if (format) {
+ res <- base::format(res,digits=digits,...)
+ pval <- format(pvalround,p.digits=p.digits,...)
+ } else {
+ ## res <- format(res)
+ pval <- format(pvalround)
+ }
+ pval <- paste0("p=",pvalround)
+ pval[which(pvalround<10^(-p.digits))] <- paste0("p<0.",paste(rep("0",p.digits-1),collapse=""),"1")
+ res <- cbind(res,pval)
+ nc <- apply(res,2,function(x) max(nchar(x))-nchar(x))
+ res2 <- c()
+ for (i in seq(nrow(res))) {
+ row <- paste0(if(res[i,1]>=0) " " else "", res[i,1], paste(rep(" ",nc[i,1]),collapse=""), if (res[i,1]<0) " ",
+ if (se) paste0(" (", res[i,2], ")", paste(rep(" ",nc[i,2]), collapse="")),
+ if (ci) paste0(" [", res[i,4], ";", res[i,5], "]", paste(rep(" ",nc[i,4]+nc[i,5]),collapse="")),
+ if (pvalue) paste0(" ", res[i,6]))
+ res2 <- rbind(res2," "=row)
+ }
+ names(res2) <- names(coef(x))
+ if (!missing(fun)) {
+ res2 <- c(res2,fun(x))
+ }
+ res2
+}
+
+##' Report estimates across different models
+##'
+##' @title Report estimates across different models
+##' @param x list of model objects
+##' @param ... additional arguments to lower level functions
+##' @author Klaus K. Holst
+##' @examples
+##' data(serotonin)
+##' m1 <- lm(cau ~ age*gene1 + age*gene2,data=serotonin)
+##' m2 <- lm(cau ~ age + gene1,data=serotonin)
+##' m3 <- lm(cau ~ age*gene2,data=serotonin)
+##'
+##' Combine(list(A=m1,B=m2,C=m3),fun=function(x)
+##' c("_____"="",R2=" "%++%format(summary(x)$r.squared,digits=2)))
+##' @export
+Combine <- function(x,...) {
+ ll <- lapply(x,excoef,...)
+ nn <- lapply(ll,names)
+ n0 <- unique(unlist(nn,use.names=FALSE))
+ res <- matrix(NA,ncol=length(ll),nrow=length(n0))
+ colnames(res) <- seq(length(ll))
+ rownames(res) <- n0
+ for (i in seq(length(ll))) {
+ res[match(names(ll[[i]]),n0),i] <- ll[[i]]
+ }
+ colnames(res) <- names(ll)
+ class(res) <- c("Combine","matrix")
+ return(res)
+}
+
+##' @export
+print.Combine <- function(x,...) {
+ print(as.table(x),...)
+}
diff --git a/R/commutation.R b/R/commutation.R
new file mode 100644
index 0000000..ef7ecf7
--- /dev/null
+++ b/R/commutation.R
@@ -0,0 +1,24 @@
+##' Finds the unique commutation matrix K:
+##' \eqn{K vec(A) = vec(A^t)}
+##'
+##' @title Finds the unique commutation matrix
+##' @param m rows
+##' @param n columns
+##' @author Klaus K. Holst
+##' @export
+commutation <- function(m, n=m) {
+ if (inherits(m,"matrix")) {
+ n <- ncol(m)
+ m <- nrow(m)
+ }
+ H <- function(i,j) { ## mxn-matrix with 1 at (i,j)
+ Hij <- matrix(0, nrow=m, ncol=n)
+ Hij[i,j] <- 1
+ Hij
+ }
+ K <- matrix(0,m*n,m*n)
+ for (i in seq_len(m))
+ for (j in seq_len(n))
+ K <- K + H(i,j)%x%t(H(i,j))
+ K
+}
diff --git a/R/compare.R b/R/compare.R
new file mode 100644
index 0000000..77c23f9
--- /dev/null
+++ b/R/compare.R
@@ -0,0 +1,187 @@
+##' Performs Likelihood-ratio, Wald and score tests
+##' @title Statistical tests
+##' @aliases compare
+##' @export
+##' @param object \code{lvmfit}-object
+##' @param \dots Additional arguments to low-level functions
+##' @return Matrix of test-statistics and p-values
+##' @author Klaus K. Holst
+##' @seealso \code{\link{modelsearch}}, \code{\link{equivalence}}
+##' @keywords htest
+##' @examples
+##' m <- lvm();
+##' regression(m) <- c(y1,y2,y3) ~ eta; latent(m) <- ~eta
+##' regression(m) <- eta ~ x
+##' m2 <- regression(m, c(y3,eta) ~ x)
+##' set.seed(1)
+##' d <- sim(m,1000)
+##' e <- estimate(m,d)
+##' e2 <- estimate(m2,d)
+##'
+##' compare(e)
+##'
+##' compare(e,e2) ## LRT, H0: y3<-x=0
+##' compare(e,scoretest=y3~x) ## Score-test, H0: y3~x=0
+##' compare(e2,par=c("y3~x")) ## Wald-test, H0: y3~x=0
+##'
+##' B <- diag(2); colnames(B) <- c("y2~eta","y3~eta")
+##' compare(e2,contrast=B,null=c(1,1))
+##'
+##' B <- rep(0,length(coef(e2))); B[1:3] <- 1
+##' compare(e2,contrast=B)
+##'
+##' compare(e,scoretest=list(y3~x,y2~x))
+compare <- function(object,...) UseMethod("compare")
+
+##' @export
+compare.default <- function(object,...,par,contrast,null,scoretest,Sigma,level=.95,df=NULL) {
+ if (!missing(par) || (!missing(contrast) && is.character(contrast))) {
+ if (!missing(contrast) && is.character(contrast)) par <- contrast
+ contrast <- rep(0,length(coef(object)))
+ myidx <- parpos(Model(object),p=par)
+ contrast[myidx] <- 1
+ contrast <- diag(contrast,nrow=length(contrast))[which(contrast!=0),,drop=FALSE]
+ if (!missing(null) && length(null)>1) null <- null[attributes(myidx)$ord]
+ }
+ ### Wald test
+ if (!missing(contrast)) {
+ B <- contrast
+ p <- coef(object)
+ pname <- names(p)
+ B <- rbind(B);
+ colnames(B) <- if (is.vector(contrast)) names(contrast) else colnames(contrast)
+ if (missing(Sigma)) {
+ Sigma <- vcov(object)
+ }
+ if (ncol(B)<length(p)) {
+ nn <- colnames(B)
+ myidx <- parpos(Model(object),p=nn)
+ B0 <- matrix(0,nrow=nrow(B),ncol=length(coef(object)))
+ B0[,myidx] <- B[,attributes(myidx)$ord]
+ B <- B0
+ }
+ if (missing(null)) null <- rep(0,nrow(B))
+ if (length(null)==1) null <- rep(null,nrow(B))
+ Bp <- B%*%p
+ V <- B%*%Sigma%*%t(B)
+ ct <- cbind(Bp,diag(V)^.5)
+ p <- 1-(1-level)/2
+ qp <- if(!is.null(df)) qt(p,df=df) else qnorm(p)
+ ct <- cbind(ct,ct[,1] + qp*cbind(-1,1)%x%ct[,2])
+ colnames(ct) <- c("Estimate","Std.Err",paste0(c(1-p,p)*100,"%"))
+ rownames(ct) <- rep("",nrow(ct))
+ Q <- t(Bp-null)%*%Inverse(V)%*%(Bp-null)
+ df <- qr(B)$rank; names(df) <- "df"
+ attributes(Q) <- NULL; names(Q) <- "chisq";
+ pQ <- ifelse(df==0,NA,pchisq(Q,df,lower.tail=FALSE))
+
+ method = "- Wald test -";
+ cnames <- c()
+ if (!is.null(pname)) {
+ msg <- c()
+ for (i in seq_len(nrow(B))) {
+ Bidx <- which(B[i,]!=0)
+ Bval <- abs(B[i,Bidx]); Bval[Bval==1] <- ""
+ sgn <- rep(" + ",length(Bval)); sgn[sign(B[i,Bidx])==-1] <- " - ";
+ if (sgn[1]==" + ") sgn[1] <- "" else sgn[1] <- "-"
+ cnames <- c(cnames,paste0(sgn,Bval,paste0("[",pname[Bidx],"]"),collapse=""))
+ msg <- c(msg,paste0(cnames[i]," = ",null[i]))
+ }
+ method <- c(method,"","Null Hypothesis:",msg)
+## method <- c(method,"","Observed:",paste(formatC(as.vector(Bp)),collapse=" "))
+ }
+ rownames(ct) <- cnames
+ res <- list(##data.name=hypothesis,
+ statistic = Q, parameter = df,
+ p.value=pQ, method = method, estimate=ct, vcov=V, coef=ct[,1],
+ null=null, cnames=cnames
+ )
+ class(res) <- "htest"
+ attributes(res)$B <- B
+ return(res)
+ }
+
+ ### Score test
+ if (!missing(scoretest)) {
+ altmodel <- Model(object)
+ if (inherits(scoretest,"formula")) scoretest <- list(scoretest)
+ for (i in scoretest) {
+ regression(altmodel) <- i
+ }
+ p0 <- numeric(length(coef(altmodel)))
+ idx <- match(coef(Model(object)),coef(altmodel))
+ p0[idx] <- coef(object)
+ Sc2 <- score(altmodel,p=p0,data=model.frame(object),weigth=Weights(altmodel),
+ estimator=object$estimator,...)
+ I <- information(altmodel,p=p0,n=object$data$n,
+ data=model.frame(object),weigth=Weights(object),
+ estimator=object$estimator,...
+ )
+ iI <- try(solve(I), silent=TRUE)
+ Q <- ifelse (inherits(iI, "try-error"), NA, ## Score test
+ ## rbind(Sc)%*%iI%*%cbind(Sc)
+ (Sc2)%*%iI%*%t(Sc2)
+ )
+ attributes(Q) <- NULL; names(Q) <- "chisq"
+ df <- length(p0)-length(coef(object)); names(df) <- "df"
+ pQ <- ifelse(df==0,NA,pchisq(Q,df,lower.tail=FALSE))
+ res <- list(data.name=as.character(scoretest),
+ statistic = Q, parameter = df,
+ p.value=pQ, method = "- Score test -")
+ class(res) <- "htest"
+ return(res)
+ }
+
+ ### Likelihood ratio test
+ objects <- list(object,...)
+ if (length(objects)<2) {
+ if (!(inherits(object,"lvmfit"))) {
+ cc <- rbind(logLik(object),AIC(object))
+ rownames(cc) <- c("logLik","AIC")
+ colnames(cc) <- ""
+ return(cc)
+ }
+ L0 <- logLik(object)
+ L1 <- satmodel(object,logLik=TRUE)
+ df <- attributes(L1)$df-attributes(L0)$df; names(df) <- "df"
+ Q <- abs(2*(L0-L1));
+ attributes(Q) <- NULL; names(Q) <- "chisq";
+ pQ <- ifelse(df==0,NA,pchisq(Q,df,lower.tail=FALSE))
+
+ values <- c(L0,L1); names(values) <- c("log likelihood (model)", "log likelihood (saturated model)")
+ res <- list(statistic = Q, parameter = df,
+ p.value=pQ, method = "- Likelihood ratio test -",
+ estimate = values)
+ class(res) <- "htest"
+ return(res)
+ }
+ if (length(objects)==2)
+ return(comparepair(objects[[1]],objects[[2]]))
+ res <- list()
+ for (i in seq_len(length(objects)-1)) {
+ res <- c(res, list(comparepair(objects[[i]],objects[[i+1]])))
+ }
+ return(res)
+}
+
+
+comparepair <- function(x1,x2) {
+ l1 <- do.call("logLik",list(x1),envir=parent.frame(2))
+ l2 <- do.call("logLik",list(x2),envir=parent.frame(2))
+ df1 <- attributes(l1)$df; df2 <- attributes(l2)$df;
+ if (is.null(df1)) {
+ df1 <- length(do.call("coef",list(x1),envir=parent.frame(2)))
+ df2 <- length(do.call("coef",list(x2),envir=parent.frame(2)))
+ }
+ Q <- abs(2*(l1-l2))
+ names(Q) <- "chisq"
+ df <- abs(df1-df2); names(df) <- "df"
+ p <- pchisq(Q,df=df,lower.tail=FALSE)
+ values <- c(l1,l2); names(values) <- c("log likelihood (model 1)", "log likelihood (model 2)")
+
+ res <- list(statistic = Q, parameter = df,
+ p.value= p, method = "- Likelihood ratio test -",
+ estimate = values)
+ class(res) <- "htest"
+ return(res)
+}
diff --git a/R/complik.R b/R/complik.R
new file mode 100644
index 0000000..83d73d7
--- /dev/null
+++ b/R/complik.R
@@ -0,0 +1,129 @@
+##' Composite Likelihood for probit latent variable models
+##'
+##' Estimate parameters in a probit latent variable model via a composite
+##' likelihood decomposition.
+##' @param x \code{lvm}-object
+##' @param data data.frame
+##' @param k Size of composite groups
+##' @param type Determines number of groups. With \code{type="nearest"} (default)
+##' only neighboring items will be grouped, e.g. for \code{k=2}
+##' (y1,y2),(y2,y3),... With \code{type="all"} all combinations of size \code{k}
+##' are included
+##' @param pairlist A list of indices specifying the composite groups. Optional
+##' argument which overrides \code{k} and \code{type} but gives complete
+##' flexibility in the specification of the composite likelihood
+##' @param silent Turn output messsages on/off
+##' @param \dots Additional arguments parsed on to lower-level functions
+##' @param estimator Model (pseudo-likelihood) to use for the pairs/groups
+##' @return An object of class \code{clprobit} inheriting methods from \code{lvm}
+##' @author Klaus K. Holst
+##' @seealso estimate
+##' @keywords models regression
+##' @export
+complik <- function(x,data,k=2,type=c("nearest","all"),pairlist,silent=TRUE,estimator="normal",
+ ...) {
+ y <- setdiff(endogenous(x),latent(x))
+ x.idx <- index(x)$exo.idx
+ binsurv <- rep(FALSE,length(y))
+ for (i in 1:length(y)) {
+ z <- try(data[,y[i]],silent=TRUE)
+ ## binsurv[i] <- is.Surv(z) | (is.factor(z) && length(levels(z))==2)
+ if (!inherits(z,"try-error"))
+ binsurv[i] <- inherits(z,"Surv") | (is.factor(z))
+ }
+
+ ord <- ordinal(x)
+ binsurv <- unique(c(y[binsurv],ord)) ## ,binary(x))
+ ## binsurvpos <- which(colnames(data)%in%binsurv)
+ if (!missing(pairlist)) {
+ binsurvpos <- which(colnames(data)%in%endogenous(x))
+ } else {
+ binsurvpos <- which(colnames(data)%in%binsurv)
+ }
+
+ if (missing(pairlist)) {
+ #if (length(binsurv)<(k+1)) stop("No need for composite likelihood analysis.")
+ if (type[1]=="all") {
+ mypar <- combn(length(binsurv),k) ## all pairs (or multiplets), k=2: k*(k-1)/2
+ } else {
+ mypar <- sapply(0:(length(binsurv)-k), function(x) x+1:k)
+ }
+ } else {
+ mypar <- pairlist
+ }
+
+ if (is.matrix(mypar)) {
+ mypar0 <- mypar; mypar <- c()
+ for (i in seq(ncol(mypar0)))
+ mypar <- c(mypar, list(mypar0[,i]))
+ }
+
+ nblocks <- length(mypar)
+ mydata0 <- data[,,drop=FALSE]
+ mydata <- as.data.frame(matrix(NA, nblocks*nrow(data), ncol=ncol(data)))
+ names(mydata) <- names(mydata0)
+ for (i in 1:ncol(mydata)) {
+ if (is.factor(data[,i])) {
+ mydata[,i] <- factor(mydata[,i],levels=levels(mydata0[,i]))
+ }
+ if (survival::is.Surv(data[,i])) {
+ S <- data[,i]
+ for (j in 2:nblocks) S <- rbind(S,data[,i])
+ S[,1] <- NA
+ mydata[,i] <- S
+ }
+ }
+ for (ii in 1:nblocks) {
+ data0 <- data;
+ for (i in binsurvpos[-mypar[[ii]]]) {
+ if (survival::is.Surv(data[,i])) {
+ S <- data0[,i]; S[,1] <- NA
+ data0[,i] <- S
+ } else {
+ data0[,i] <- NA
+ if (is.factor(data[,i])) data0[,i] <- factor(data0[,i],levels=levels(data[,i]))
+ }
+ }
+ mydata[(1:nrow(data))+(ii-1)*nrow(data),] <- data0
+ }
+ suppressWarnings(e0 <- estimate(x,data=mydata,estimator=estimator,missing=TRUE,silent=silent,
+ ...))
+
+ S <- score(e0,indiv=TRUE)
+ nd <- nrow(data)
+ block1 <- which((1:nd)%in%(rownames(S)))
+ blocks <- sapply(1:nblocks, function(x) 1:length(block1)+length(block1)*(x-1))
+ if (nblocks==1) {
+ Siid <- S
+ } else {
+ Siid <- matrix(0,nrow=length(block1),ncol=ncol(S))
+ for (j in 1:ncol(blocks)) {
+ Siid <- Siid+S[blocks[,j],]
+ }
+ }
+ iI <- solve(information(e0,type="hessian"))
+ J <- t(Siid)%*%(Siid)
+ e0$iidscore <- Siid
+ e0$blocks <- blocks
+ e0$vcov <- iI%*%J%*%iI ## thetahat-theta0 :=(asymp) I^-1*S => var(thetahat) = iI*var(S)*iI
+ cc <- e0$coef; cc[,2] <- sqrt(diag(e0$vcov))
+ cc[,3] <- cc[,1]/cc[,2]; cc[,4] <- 2*(1-pnorm(abs(cc[,3])))
+ e0$coef <- cc
+ e0$bread <- iI
+ class(e0) <- c("estimate.complik",class(e0))
+ return(e0)
+}
+
+
+score.estimate.complik <- function(x,indiv=FALSE,...) {
+ if (!indiv)
+ return(colSums(x$iidscore))
+ x$iidscore
+}
+
+iid.estimate.complik <- function(x,...) {
+ iid.default(x,bread=x$bread,...)
+}
+
+
+
diff --git a/R/confband.R b/R/confband.R
new file mode 100644
index 0000000..1a75e63
--- /dev/null
+++ b/R/confband.R
@@ -0,0 +1,283 @@
+##' Add Confidence limits bar to plot
+##'
+##' @title Add Confidence limits bar to plot
+##' @param x Position (x-coordinate if vert=TRUE, y-coordinate otherwise)
+##' @param lower Lower limit (if NULL no limits is added, and only the
+##' center is drawn (if not NULL))
+##' @param upper Upper limit
+##' @param center Center point
+##' @param line If FALSE do not add line between upper and lower bound
+##' @param delta Length of limit bars
+##' @param centermark Length of center bar
+##' @param pch Center symbol (if missing a line is drawn)
+##' @param blank If TRUE a white ball is plotted before the center is
+##' added to the plot
+##' @param vert If TRUE a vertical bar is plotted. Otherwise a horizontal
+##' bar is used
+##' @param polygon If TRUE polygons are added between 'lower' and 'upper'.
+##' @param step Type of polygon (step-function or piecewise linear)
+##' @param ... Additional low level arguments (e.g. col, lwd, lty,...)
+##' @seealso \code{confband}
+##' @export
+##' @keywords iplot
+##' @aliases confband forestplot
+##' @author Klaus K. Holst
+##' @examples
+##' plot(0,0,type="n",xlab="",ylab="")
+##' confband(0.5,-0.5,0.5,0,col="darkblue")
+##' confband(0.8,-0.5,0.5,0,col="darkred",vert=FALSE,pch=1,cex=1.5)
+##'
+##' set.seed(1)
+##' K <- 20
+##' est <- rnorm(K)
+##' se <- runif(K,0.2,0.4)
+##' x <- cbind(est,est-2*se,est+2*se,runif(K,0.5,2))
+##' x[c(3:4,10:12),] <- NA
+##' rownames(x) <- unlist(lapply(letters[seq(K)],function(x) paste(rep(x,4),collapse="")))
+##' rownames(x)[which(is.na(est))] <- ""
+##' signif <- sign(x[,2])==sign(x[,3])
+##' forestplot(x,text.right=FALSE)
+##' forestplot(x[,-4],sep=c(2,15),col=signif+1,box1=TRUE,delta=0.2,pch=16,cex=1.5)
+##' forestplot(x,vert=TRUE,text=FALSE)
+##' forestplot(x,vert=TRUE,text=FALSE,pch=NA)
+##' ##forestplot(x,vert=TRUE,text.vert=FALSE)
+##' ##forestplot(val,vert=TRUE,add=TRUE)
+##'
+##' z <- seq(10)
+##' zu <- c(z[-1],10)
+##' plot(z,type="n")
+##' confband(z,zu,rep(0,length(z)),col=Col("darkblue"),polygon=TRUE,step=TRUE)
+##' confband(z,zu,zu-2,col=Col("darkred"),polygon=TRUE,step=TRUE)
+##'
+##' z <- seq(0,1,length.out=100)
+##' plot(z,z,type="n")
+##' confband(z,z,z^2,polygon="TRUE",col=Col("darkblue"))
+##'
+##' set.seed(1)
+##' k <- 10
+##' x <- seq(k)
+##' est <- rnorm(k)
+##' sd <- runif(k)
+##' val <- cbind(x,est,est-sd,est+sd)
+##' par(mfrow=c(1,2))
+##' plot(0,type="n",xlim=c(0,k+1),ylim=range(val[,-1]),axes=FALSE,xlab="",ylab="")
+##' axis(2)
+##' confband(val[,1],val[,3],val[,4],val[,2],pch=16,cex=2)
+##' plot(0,type="n",ylim=c(0,k+1),xlim=range(val[,-1]),axes=FALSE,xlab="",ylab="")
+##' axis(1)
+##' confband(val[,1],val[,3],val[,4],val[,2],pch=16,cex=2,vert=FALSE)
+confband <- function(x,lower,upper,center=NULL,line=TRUE,delta=0.07,centermark=0.03,
+ pch,blank=TRUE,vert=TRUE,polygon=FALSE,step=FALSE,...) {
+ if (polygon) {
+ if (step) {
+ x1 <- rep(x,each=2)[-1]
+ y1 <- rep(lower, each=2); y1 <- y1[-length(y1)]
+ x2 <- rep(rev(x),each=2); x2 <- x2[-length(x2)]
+ y2 <- rep(rev(upper),each=2)[-1]
+ xx <- c(x1,x2)
+ if (!is.null(center))
+ center <- rep(center,each=2)[-1]
+ yy <- c(y1,y2)
+ } else {
+ xx <- c(x,rev(x))
+ yy <- c(lower,rev(upper))
+ }
+ polygon(xx,yy,...)
+ if (line && !is.null(center)) {
+ mlines <- function(x,y,...,density,angle,border,fillOddEven)
+ lines(x,y,...)
+ mlines(xx[seq(length(xx)/2)],center,...)
+ }
+ return(invisible(NULL))
+ }
+ if (vert) {
+ ## lower <- lower[length(x)]
+ ## upper <- upper[length(x)]
+ ## center <- center[length(x)]
+ if (line && !missing(lower) && !missing(upper))
+ segments(x,lower,x,upper,...)
+ if (!missing(lower))
+ segments(x-delta,lower,x+delta,lower,...)
+ if (!missing(upper))
+ segments(x-delta,upper,x+delta,upper,...)
+ if (!is.null(center)) {
+ if (!missing(pch)) {
+ if (blank)
+ points(x,center,pch=16,col="white")
+ points(x,center,pch=pch,...)
+ } else {
+ segments(x-centermark,center,x+centermark,center,...)
+ }
+ }
+ } else {
+ if (line && !missing(lower) && !missing(upper))
+ segments(lower,x,upper,x,...)
+ if (!missing(lower))
+ segments(lower,x-delta,lower,x+delta,...)
+ if (!missing(upper))
+ segments(upper,x-delta,upper,x+delta,...)
+
+ if (!is.null(center)) {
+ if (!missing(pch)) {
+ if (blank)
+ points(center,x,pch=16,col="white")
+ points(center,x,pch=pch,...)
+ } else {
+ segments(center,x-centermark,center,x+centermark,...)
+ }
+ }
+ }
+ if (missing(lower)) lower <- NULL
+ if (missing(upper)) upper <- NULL
+ invisible(c(x,lower,upper,center))
+}
+
+
+##' @export
+forestplot <- function(x,lower,upper,line=0,labels,
+ text=TRUE,text.right=text,text.fixed=NULL,text.vert=TRUE,
+ adj=NULL,
+ delta=0,axes=TRUE,cex=1,pch=15,
+ xlab="",ylab="",sep,air,
+ xlim,ylim,mar,box1=FALSE,box2=FALSE,
+ vert=FALSE,cex.axis=1,cex.estimate=0.6,
+ add=FALSE,
+ reset.par=FALSE,...) {
+ if (is.matrix(x)) {
+ lower <- x[,2]; upper <- x[,3]
+ if (ncol(x)>3) cex <- x[,4]
+ x <- x[,1]
+ }
+ if (missing(mar) && !add) {
+ if (vert) {
+ mar <- c(8,4,1,1)
+ } else {
+ mar <- c(4,8,1,1)
+ }
+ }
+ if (missing(labels)) labels <- names(x)
+ K <- length(x)
+ onelayout <- FALSE
+ if (!add) {
+ def.par <- par(no.readonly=TRUE)
+ if (reset.par) on.exit(par(def.par))
+ if (text.right) {
+ if (vert) {
+ layout(rbind(1,2),heights=c(0.2,0.8))
+ } else {
+ layout(cbind(2,1),widths=c(0.8,0.2))
+ }
+ } else {
+ onelayout <- TRUE
+ layout(1)
+ }
+ }
+ if (vert) {
+ if (missing(ylim)) {
+ if (missing(air)) air <- max(upper-lower,na.rm=TRUE)*0.4
+ ylim <- range(c(x,lower-air,upper+air),na.rm=TRUE)
+ }
+ if (missing(xlim)) xlim <- c(1,K)
+ } else {
+ if (missing(ylim)) ylim <- c(1,K)
+ if (missing(xlim)) {
+ if (missing(air)) air <- max(upper-lower,na.rm=TRUE)*0.4
+ xlim <- range(c(x,lower-air,upper+air),na.rm=TRUE)
+ }
+ }
+ args0 <- list(...)
+ formatCargsn <- names(formals(args(formatC)))[-1]
+ nn <- setdiff(names(args0),formatCargsn)
+ plotargs <- args0[nn]
+
+ mainplot <- function(...) {
+ par(mar=mar) ## bottom,left,top,right
+ do.call("plot",c(list(x=0,type="n",axes=FALSE,xlab=xlab,ylab=ylab,xlim=xlim,ylim=ylim),plotargs))
+ if (box1) box()
+ if (axes) {
+ if (vert) {
+ axis(2,cex.axis=cex.axis)
+ } else {
+ axis(1,cex.axis=cex.axis)
+ }
+ }
+ }
+ if (onelayout && !add) mainplot()
+
+ if (text) {
+ xpos <- upper
+ if (text.right && !add) {
+ if (vert) {
+ par(mar=c(0,mar[2],0,mar[4]))
+ } else {
+ par(mar=c(mar[1],0,mar[3],0))
+ }
+ plot.new()
+ if (vert) {
+ plot.window(xlim=xlim,ylim=c(0,0.5))
+ } else {
+ plot.window(ylim=ylim,xlim=c(0,0.5))
+ }
+ if (box2) box()
+ xpos[] <- 0
+ }
+ if (!is.null(text.fixed)) {
+ if (is.logical(text.fixed) && text.fixed) text.fixed <- max(xpos)
+ xpos <- rep(text.fixed,length.out=K)
+ }
+ nn <- intersect(names(args0),formatCargsn)
+ args <- args0[nn]
+ for (i in seq_len(K)) {
+ st <- c(do.call(formatC,c(list(x=x[i]),args)),
+ paste0("(",
+ do.call(formatC,c(list(x=lower[i]),args)),"; ",
+ do.call(formatC,c(list(x=upper[i]),args)),")"))
+ if (text.vert) {
+ st <- paste0(" ",st[1]," ",st[2],collapse="")
+ st <- paste(" ", st)
+ }
+ if (vert) {
+ if (!is.na(x[i])) {
+ if (!text.vert) {
+ if (text.right) xpos[i] <- xpos[i]+0.025
+ graphics::text(i,xpos[i],paste(st,collapse="\n"),xpd=TRUE, offset=3, cex=cex.estimate, adj=adj)
+ } else {
+ if (!is.na(x[i])) graphics::text(i,xpos[i],st,xpd=TRUE, srt=90, offset=0, pos=4, cex=cex.estimate, adj=adj)
+ }
+ }
+ } else {
+ if (!is.na(x[i])) graphics::text(xpos[i],i,st,xpd=TRUE,pos=4,cex=cex.estimate, adj=adj)
+ }
+ }
+ }
+
+ if (!onelayout && !add) mainplot()
+
+ if (!is.null(line)) {
+ if (vert) {
+ abline(h=line,lty=2,col="lightgray")
+ } else {
+ abline(v=line,lty=2,col="lightgray")
+ }
+ }
+ if (!missing(sep)) {
+ if (vert) {
+ abline(v=sep+.5,col="gray")
+ } else {
+ abline(h=sep+.5,col="gray")
+ }
+ }
+ do.call("confband",
+ c(list(x=seq(K),lower=lower,upper=upper,x,
+ pch=pch,cex=cex,vert=vert,blank=FALSE),
+ plotargs))
+ if (!add) {
+ if (is.null(adj)) adj <- NA
+ if (vert) {
+ mtext(labels,1,at=seq(K),las=2,line=1,cex=cex.axis, adj=adj)
+ } else {
+ mtext(labels,2,at=seq(K),las=2,line=1,cex=cex.axis, adj=adj)
+ }
+ }
+}
+
diff --git a/R/confint.R b/R/confint.R
new file mode 100644
index 0000000..19adde2
--- /dev/null
+++ b/R/confint.R
@@ -0,0 +1,72 @@
+##' Calculate Wald og Likelihood based (profile likelihood) confidence intervals
+##'
+##' Calculates either Wald confidence limits: \deqn{\hat{\theta} \pm
+##' z_{\alpha/2}*\hat\sigma_{\hat\theta}} or profile likelihood confidence
+##' limits, defined as the set of value \eqn{\tau}:
+##' \deqn{logLik(\hat\theta_{\tau},\tau)-logLik(\hat\theta)< q_{\alpha}/2}
+##'
+##' where \eqn{q_{\alpha}} is the \eqn{\alpha} fractile of the \eqn{\chi^2_1}
+##' distribution, and \eqn{\hat\theta_{\tau}} are obtained by maximizing the
+##' log-likelihood with tau being fixed.
+##'
+##' @title Calculate confidence limits for parameters
+##' @param object \code{lvm}-object.
+##' @param parm Index of which parameters to calculate confidence limits for.
+##' @param level Confidence level
+##' @param profile Logical expression defining whether to calculate confidence
+##' limits via the profile log likelihood
+##' @param curve if FALSE and profile is TRUE, confidence limits are
+##' returned. Otherwise, the profile curve is returned.
+##' @param n Number of points to evaluate profile log-likelihood in
+##' over the interval defined by \code{interval}
+##' @param interval Interval over which the profiling is done
+##' @param lower If FALSE the lower limit will not be estimated (profile intervals only)
+##' @param upper If FALSE the upper limit will not be estimated (profile intervals only)
+##' @param \dots Additional arguments to be passed to the low level functions
+##' @return A 2xp matrix with columns of lower and upper confidence limits
+##' @author Klaus K. Holst
+##' @seealso \code{\link{bootstrap}{lvm}}
+##' @keywords models regression
+##' @examples
+##'
+##' m <- lvm(y~x)
+##' d <- sim(m,100)
+##' e <- estimate(y~x, d)
+##' confint(e,3,profile=TRUE)
+##' confint(e,3)
+##' \donttest{ ## Reduce Ex.timings
+##' B <- bootstrap(e,R=50)
+##' B
+##' }
+##' @aliases confint.multigroupfit
+##' @export
+##' @method confint lvmfit
+confint.lvmfit <- function(object,parm=seq_len(length(coef(object))),level=0.95,profile=FALSE,curve=FALSE,n=20,interval=NULL,lower=TRUE,upper=TRUE,...) {
+ if (is.character(parm)) {
+ parm <- parpos(Model(object),p=parm)
+ parm <- parm[attributes(parm)$ord]
+ }
+ if (!profile) {
+ return(confint.default(object,parm=parm,level=level,...))
+ }
+ res <- c()
+ for (i in parm) {
+ res <- rbind(res, profci.lvmfit(object,parm=i,level=level,profile=profile,n=n,curve=curve,interval=interval,lower=lower,upper=upper,...))
+ if (curve) return(res)
+ }
+ rownames(res) <- names(coef(object))[parm]
+ colnames(res) <- paste((c(0,1) + c(1,-1)*(1-level)/2)*100,"%")
+ return(res)
+}
+
+
+##' @export
+confint.multigroupfit <- function(object,parm=seq_along(pars(object)),level=0.95,
+ estimates=TRUE,...) {
+ p <- 1-(1-level)/2
+ res <- cbind(pars(object),pars(object)) + qnorm(p)*cbind(-1,1)%x%diag(vcov(object))^0.5
+ colnames(res) <- paste0(c(1-p,p)*100,"%")
+ rownames(res) <- parpos(object); rownames(res)[is.na(rownames(res))] <- ""
+ if (estimates) res <- cbind(coef(object,level=0)[,c(1,2,4)],res)
+ res[parm,,drop=FALSE]
+}
diff --git a/R/confpred.R b/R/confpred.R
new file mode 100644
index 0000000..9056130
--- /dev/null
+++ b/R/confpred.R
@@ -0,0 +1,68 @@
+##' Conformal predicions
+##'
+##' @title Conformal prediction
+##' @param object Model object (lm, glm or similar with predict method) or formula (lm)
+##' @param data data.frame
+##' @param newdata New data.frame to make predictions for
+##' @param alpha Level of prediction interval
+##' @param mad Conditional model (formula) for the MAD (locally-weighted CP)
+##' @param ... Additional arguments to lower level functions
+##' @return data.frame with fitted (fit), lower (lwr) and upper (upr) predictions bands.
+##' @examples
+##' set.seed(123)
+##' n <- 200
+##' x <- seq(0,6,length.out=n)
+##' delta <- 3
+##' ss <- exp(-1+1.5*cos((x-delta)))
+##' ee <- rnorm(n,sd=ss)
+##' y <- (x-delta)+3*cos(x+4.5-delta)+ee
+##' d <- data.frame(y=y,x=x)
+##'
+##' newd <- data.frame(x=seq(0,6,length.out=50))
+##' ## cc <- confpred(lm(y~ns(x,knots=c(1,3,5)),d),newdata=newd)
+##' cc <- confpred(lm(y~poly(x,3),d),data=d,newdata=newd)
+##' if (interactive()) { ##'
+##' plot(y~x,pch=16,col=lava::Col("black"),ylim=c(-10,15),xlab="X",ylab="Y")
+##' with(cc,
+##' lava::confband(newd$x,lwr,upr,fit,
+##' lwd=3,polygon=TRUE,col=Col("blue"),border=FALSE))
+##' }
+##' @export
+confpred <- function(object,data,newdata=data,alpha=0.05,mad,...) { ## Split algorithm
+ if (inherits(object,"formula")) {
+ object <- do.call("lm",list(object,data=data,...))
+ }
+ dd <- csplit(data,0.5)
+ muhat.new <- predict(object,newdata=newdata) ## New predictions
+ muhat.1 <- predict(object,newdata=dd[[1]]) ## Training
+ R1 <- abs(dd[[1]][,1]-muhat.1)
+ muhat.2 <- predict(object,newdata=dd[[2]]) ## Ranking
+ R2 <- abs(dd[[2]][,1]-muhat.2)
+ if (missing(mad)) mad <- formula(object)
+ if (is.null(mad)) {
+ mad.new <- rep(1,nrow(newdata))
+ } else { ## Locally-weighted conformal ffinference
+ if (names(dd[[2]])[1] %ni% names(newdata)) {
+ newdata <- cbind(0,newdata); names(newdata)[1] <- names(dd[[2]])[1]
+ }
+ X0 <- model.matrix(mad,data=newdata)
+ if (inherits(mad,"formula")) {
+ X2 <- model.matrix(mad,dd[[2]])
+ mad.obj <- stats::lm.fit(x=X2,y=R2)
+ mad2 <- X2%*%mad.obj$coefficients
+ mad.new <- X0%*%mad.obj$coefficients
+ } else {
+ mad.obj <- do.call(mad,list(y=R2,x=dd[[2]]))
+ mad2 <- predict(mad.obj,newdata=dd[[2]])
+ mad.new <- predict(mad.obj,newdata=newdata)
+ }
+ R2 <- R2/mad2
+ }
+ k <- ceiling((nrow(data)/2+1)*(1-alpha))
+ if (k==0) k <- 1
+ if (k>length(R2)) k <- length(R2)
+ q <- sort(R2)[k] ## 1-alpha quantile
+ lo <- muhat.new - q*mad.new
+ up <- muhat.new + q*mad.new
+ data.frame(fit=muhat.new,lwr=lo,upr=up)
+}
diff --git a/R/constrain.R b/R/constrain.R
new file mode 100644
index 0000000..c0d166f
--- /dev/null
+++ b/R/constrain.R
@@ -0,0 +1,423 @@
+##' Define range constraints of parameters
+##'
+##' @aliases Range.lvm
+##' @title Define range constraints of parameters
+##' @param a Lower bound
+##' @param b Upper bound
+##' @return function
+##' @author Klaus K. Holst
+##' @export
+Range.lvm <- function(a=0,b=1) {
+ if (b==Inf) {
+ f <- function(x) {
+ res <- a+exp(x)
+ attributes(res)$grad <- exp
+ res
+ }
+ return(f)
+ }
+ if (a==-Inf) {
+ f <- function(x) {
+ res <- -exp(x)+b
+ attributes(res)$grad <- function(x) -exp(x)
+ res
+ }
+ return(f)
+ }
+ f <- function(x) {
+ res <- (a+b*exp(x))/(1+exp(x))
+ attributes(res)$grad <- function(x) exp(x)*(b-a-a*b*exp(x))/(1+exp(x))^2
+ res
+ }
+ return(f)
+}
+
+##' Add non-linear constraints to latent variable model
+##'
+##' Add non-linear constraints to latent variable model
+##'
+##' Add non-linear parameter constraints as well as non-linear associations
+##' between covariates and latent or observed variables in the model (non-linear
+##' regression).
+##'
+##' As an example we will specify the follow multiple regression model:
+##'
+##' \deqn{E(Y|X_1,X_2) = \alpha + \beta_1 X_1 + \beta_2 X_2} \deqn{V(Y|X_1,X_2)
+##' = v}
+##'
+##' which is defined (with the appropiate parameter labels) as
+##'
+##' \code{m <- lvm(y ~ f(x,beta1) + f(x,beta2))}
+##'
+##' \code{intercept(m) <- y ~ f(alpha)}
+##'
+##' \code{covariance(m) <- y ~ f(v)}
+##'
+##' The somewhat strained parameter constraint \deqn{ v =
+##' \frac{(beta1-beta2)^2}{alpha}}
+##'
+##' can then specified as
+##'
+##' \code{constrain(m,v ~ beta1 + beta2 + alpha) <- function(x)
+##' (x[1]-x[2])^2/x[3] }
+##'
+##' A subset of the arguments \code{args} can be covariates in the model,
+##' allowing the specification of non-linear regression models. As an example
+##' the non-linear regression model \deqn{ E(Y\mid X) = \nu + \Phi(\alpha +
+##' \beta X)} where \eqn{\Phi} denotes the standard normal cumulative
+##' distribution function, can be defined as
+##'
+##' \code{m <- lvm(y ~ f(x,0)) # No linear effect of x}
+##'
+##' Next we add three new parameters using the \code{parameter} assigment
+##' function:
+##'
+##' \code{parameter(m) <- ~nu+alpha+beta}
+##'
+##' The intercept of \eqn{Y} is defined as \code{mu}
+##'
+##' \code{intercept(m) <- y ~ f(mu)}
+##'
+##' And finally the newly added intercept parameter \code{mu} is defined as the
+##' appropiate non-linear function of \eqn{\alpha}, \eqn{\nu} and \eqn{\beta}:
+##'
+##' \code{constrain(m, mu ~ x + alpha + nu) <- function(x)
+##' pnorm(x[1]*x[2])+x[3]}
+##'
+##' The \code{constraints} function can be used to show the estimated non-linear
+##' parameter constraints of an estimated model object (\code{lvmfit} or
+##' \code{multigroupfit}). Calling \code{constrain} with no additional arguments
+##' beyound \code{x} will return a list of the functions and parameter names
+##' defining the non-linear restrictions.
+##'
+##' The gradient function can optionally be added as an attribute \code{grad} to
+##' the return value of the function defined by \code{value}. In this case the
+##' analytical derivatives will be calculated via the chain rule when evaluating
+##' the corresponding score function of the log-likelihood. If the gradient
+##' attribute is omitted the chain rule will be applied on a numeric
+##' approximation of the gradient.
+##' @aliases constrain constrain<- constrain.default constrain<-.multigroup
+##' constrain<-.default constraints parameter<-
+##' @return A \code{lvm} object.
+##' @author Klaus K. Holst
+##' @seealso \code{\link{regression}}, \code{\link{intercept}},
+##' \code{\link{covariance}}
+##' @keywords models regression
+##' @examples
+##' ##############################
+##' ### Non-linear parameter constraints 1
+##' ##############################
+##' m <- lvm(y ~ f(x1,gamma)+f(x2,beta))
+##' covariance(m) <- y ~ f(v)
+##' d <- sim(m,100)
+##' m1 <- m; constrain(m1,beta ~ v) <- function(x) x^2
+##' ## Define slope of x2 to be the square of the residual variance of y
+##' ## Estimate both restricted and unrestricted model
+##' e <- estimate(m,d,control=list(method="NR"))
+##' e1 <- estimate(m1,d)
+##' p1 <- coef(e1)
+##' p1 <- c(p1[1:2],p1[3]^2,p1[3])
+##' ## Likelihood of unrestricted model evaluated in MLE of restricted model
+##' logLik(e,p1)
+##' ## Likelihood of restricted model (MLE)
+##' logLik(e1)
+##'
+##' ##############################
+##' ### Non-linear regression
+##' ##############################
+##'
+##' ## Simulate data
+##' m <- lvm(c(y1,y2)~f(x,0)+f(eta,1))
+##' latent(m) <- ~eta
+##' covariance(m,~y1+y2) <- "v"
+##' intercept(m,~y1+y2) <- "mu"
+##' covariance(m,~eta) <- "zeta"
+##' intercept(m,~eta) <- 0
+##' set.seed(1)
+##' d <- sim(m,100,p=c(v=0.01,zeta=0.01))[,manifest(m)]
+##' d <- transform(d,
+##' y1=y1+2*pnorm(2*x),
+##' y2=y2+2*pnorm(2*x))
+##'
+##' ## Specify model and estimate parameters
+##' constrain(m, mu ~ x + alpha + nu + gamma) <- function(x) x[4]*pnorm(x[3]+x[1]*x[2])
+##' \donttest{ ## Reduce Ex.Timings
+##' e <- estimate(m,d,control=list(trace=1,constrain=TRUE))
+##' constraints(e,data=d)
+##' ## Plot model-fit
+##' plot(y1~x,d,pch=16); points(y2~x,d,pch=16,col="gray")
+##' x0 <- seq(-4,4,length.out=100)
+##' lines(x0,coef(e)["nu"] + coef(e)["gamma"]*pnorm(coef(e)["alpha"]*x0))
+##' }
+##'
+##' ##############################
+##' ### Multigroup model
+##' ##############################
+##' ### Define two models
+##' m1 <- lvm(y ~ f(x,beta)+f(z,beta2))
+##' m2 <- lvm(y ~ f(x,psi) + z)
+##' ### And simulate data from them
+##' d1 <- sim(m1,500)
+##' d2 <- sim(m2,500)
+##' ### Add 'non'-linear parameter constraint
+##' constrain(m2,psi ~ beta2) <- function(x) x
+##' ## Add parameter beta2 to model 2, now beta2 exists in both models
+##' parameter(m2) <- ~ beta2
+##' ee <- estimate(list(m1,m2),list(d1,d2),control=list(method="NR"))
+##' summary(ee)
+##'
+##' m3 <- lvm(y ~ f(x,beta)+f(z,beta2))
+##' m4 <- lvm(y ~ f(x,beta2) + z)
+##' e2 <- estimate(list(m3,m4),list(d1,d2),control=list(method="NR"))
+##' e2
+##' @export
+##' @usage
+##'
+##' \method{constrain}{default}(x,par,args,...) <- value
+##'
+##' \method{constrain}{multigroup}(x,par,k=1,...) <- value
+##'
+##' constraints(object,data=model.frame(object),vcov=object$vcov,level=0.95,
+##' p=pars.default(object),k,idx,...)
+##'
+##' @param x \code{lvm}-object
+##' @param par Name of new parameter. Alternatively a formula with lhs
+##' specifying the new parameter and the rhs defining the names of the
+##' parameters or variable names defining the new parameter (overruling the
+##' \code{args} argument).
+##' @param args Vector of variables names or parameter names that are used in
+##' defining \code{par}
+##' @param k For multigroup models this argument specifies which group to
+##' add/extract the constraint
+##' @param value Real function taking args as a vector argument
+##' @param object \code{lvm}-object
+##' @param data Data-row from which possible non-linear constraints should be
+##' calculated
+##' @param vcov Variance matrix of parameter estimates
+##' @param level Level of confidence limits
+##' @param p Parameter vector
+##' @param idx Index indicating which constraints to extract
+##' @param \dots Additional arguments to be passed to the low level functions
+"constrain<-" <- function(x,...,value) UseMethod("constrain<-")
+##' @export
+"constrain" <- function(x,...) UseMethod("constrain")
+
+##' @export
+constrain.default <- function(x,fun, idx, level=0.95, vcov, estimate=FALSE, ...) {
+ if (estimate) {
+ return(constraints(x,...))
+ }
+ if (missing(fun)) {
+ if (inherits(Model(x),"multigroup")) {
+ res <- list()
+ for (m in Model(x)$lvm) {
+ if (length(constrain(m))>0)
+ res <- c(res, constrain(m))
+ }
+ return(res)
+ }
+ return(Model(x)$constrain)
+ }
+ if (is.numeric(x)) {
+ b <- x
+ } else {
+ b <- pars(x)
+ }
+ if (missing(vcov)) {
+ S <- stats::vcov(x)
+ } else {
+ S <- vcov
+ }
+ if (!missing(idx)) {
+ b <- b[idx]; S <- S[idx,idx,drop=FALSE]
+ }
+ fb <- fun(b)
+ pl <- 1-(1-level)/2
+ D <- rbind(numDeriv::grad(fun,b))
+ se <- (D%*%S%*%t(D))^0.5
+ res <- c(fb,se,fb+c(-1,1)*qnorm(pl)*c(se))
+ pstr <- paste0(format(c(round(1000-1000*pl),round(pl*1000))/10),"%")
+ names(res) <- c("Estimate","Std.Err",pstr)
+ res
+}
+
+##' @export
+"constrain<-.multigroupfit" <-
+ "constrain<-.multigroup" <- function(x,par,k=1,...,value) {
+ constrain(Model(x)$lvm[[k]],par=par,...) <- value
+ return(x)
+}
+
+##' @export
+"constrain<-.default" <- function(x,par,args,...,value) {
+ if (inherits(par,"formula")) {
+ lhs <- getoutcome(par)
+ xf <- attributes(terms(par))$term.labels
+ par <- lhs
+ if (par%in%vars(x)) {
+ if (is.na(x$mean[[par]])) {
+ intercept(x,par) <- par
+ } else {
+ par <- x$mean[[par]]
+ }
+ }
+ args <- xf
+ }
+ if (is.null(value) || suppressWarnings(is.na(value))) {
+ if (!is.null(par)) {
+ Model(x)$constrain[[par]] <- NULL
+ Model(x)$constrainY[[par]] <- NULL
+ } else {
+ Model(x)$constrain[[args]] <- NULL
+ }
+ return(x)
+ }
+ for (i in args) {
+ if (!(i%in%c(parlabels(Model(x)),vars(Model(x)),
+ names(constrain(x))))) {
+ if (!lava.options()$silent)
+ message("\tAdding parameter '", i,"'\n",sep="")
+ parameter(x,silent=TRUE) <- i
+ }
+ }
+
+ if (par%in%vars(x)) {
+ if (!"..."%in%names(formals(value))) {
+ formals(value) <- c(formals(value),alist(...=))
+ }
+ Model(x)$constrainY[[par]] <- list(fun=value,args=args)
+ } else {
+ ## Wrap around do.call, since functions are not really
+ ## parsed as call-by-value in R, and hence setting
+ ## attributes to e.g. value=cos, will be overwritten
+ ## if value=cos is used again later with new args.
+ Model(x)$constrain[[par]] <- function(x) do.call(value,list(x))
+ attributes(Model(x)$constrain[[par]])$args <- args
+ index(Model(x)) <- reindex(Model(x))
+ }
+ return(x)
+}
+
+##' @export
+constraints <- function(object,data=model.frame(object),vcov=object$vcov,level=0.95,
+ p=pars.default(object),k,idx,...) {
+ if (class(object)[1]=="multigroupfit") {
+ if (!missing(k)) {
+ if (class(data)[1]=="list") data <- data[[k]]
+ parpos <- modelPar(object, seq_len(length(p)))$p[[k]]
+ if (nrow(data)>1 & !missing(idx)) {
+ res <- t(apply(data,1,function(x) constraints(Model(object)$lvm[[k]],data=x,p=p[parpos],vcov=vcov[parpos,parpos],level=level)[idx,]))
+ return(res)
+ }
+ return(constraints(Model(object)$lvm[[k]],data=data,p=p[parpos],vcov=vcov[parpos,parpos],level=level))
+ }
+ return(attributes(CoefMat.multigroupfit(object,data=data,vcov=vcov,...))$nlincon)
+ }
+
+ if (NROW(data)>1 & !missing(idx)) {
+ res <- t(apply(data,1,function(x) constraints(object,data=x,p=p,vcov=vcov,level=level)[idx,],...))
+ return(res)
+ }
+
+ if (length(index(object)$constrain.par)<1) return(NULL)
+ parpos <- Model(object)$parpos
+ if (is.null(parpos)) {
+ parpos <- with(index(object),matrices2(Model(object),seq_len(npar+npar.mean+npar.ex)))
+ parpos$A[index(object)$M0==0] <- 0
+ parpos$P[index(object)$P0==0] <- 0
+ parpos$v[index(object)$v1==0] <- 0
+ parpos$e[index(object)$e1==0] <- 0
+ }
+ myidx <- unlist(lapply(parpos$parval, function(x) {
+ if (!is.null(attributes(x)$reg.idx)) {
+ return(parpos$A[attributes(x)$reg.idx[1]])
+ } else if (!is.null(attributes(x)$cov.idx)) {
+ return(parpos$P[attributes(x)$cov.idx[1]])
+ } else if (!is.null(attributes(x)$m.idx)) {
+ return(parpos$v[attributes(x)$m.idx[1]])
+ } else if (!is.null(attributes(x)$e.idx))
+ return(parpos$e[attributes(x)$e.idx[1]])
+ else NA
+ }))
+ names(myidx) <- names(parpos$parval)
+ mynames <- c()
+ N <- length(index(object)$constrain.par)
+ if (N>0)
+ res <- c()
+ count <- 0
+ mydata <- rbind(numeric(length(manifest(object))))
+ colnames(mydata) <- manifest(object)
+ data <- rbind(data)
+ iname <- intersect(colnames(mydata),colnames(data))
+ mydata[1,iname] <- unlist(data[1,iname])
+ for (pp in index(object)$constrain.par) {
+ count <- count+1
+ myc <- constrain(Model(object))[[pp]]
+ mycoef <- numeric(6)
+ val.idx <- myidx[attributes(myc)$args]
+ val.idx0 <- na.omit(val.idx)
+ M <- modelVar(Model(object),p=p,data=as.data.frame(mydata))
+ vals <- with(M,c(parval,constrainpar))[attributes(myc)$args]
+ fval <- try(myc(unlist(vals)),silent=TRUE)
+ fmat <- inherits(fval,"try-error")
+ if (fmat) {
+ fval <- myc(rbind(unlist(vals)))
+ }
+ mycoef[1] <- fval
+ myc0 <- function(theta) {
+ theta0 <- unlist(vals);
+## theta0[val.idx0] <- theta[val.idx0];
+ theta0[!is.na(val.idx)] <- theta
+ if (fmat) {
+ res <- myc(rbind(theta0))
+ } else {
+ res <- myc(theta0)
+ }
+ return(res)
+ }
+ vals0 <- unlist(vals)[!is.na(val.idx)]
+## vals0 <- unlist(vals)[na.omit(val.idx)]
+ if (length(vals0)==0)
+ mycoef[2] <- NA
+ else {
+ if (!is.null(attributes(fval)$grad)) {
+ if (fmat) {
+ Gr <- cbind(attributes(fval)$grad(rbind(unlist(vals0))))
+ } else {
+ Gr <- cbind(attributes(fval)$grad(unlist(vals0)))
+ }
+ } else {
+ if (fmat) {
+ Gr <- cbind(as.numeric(numDeriv::jacobian(myc0, unlist(vals0))))
+ } else {
+ Gr <- cbind(as.numeric(numDeriv::jacobian(myc0, rbind(unlist(vals0)))))
+ }
+ }
+ V <- vcov[val.idx0,val.idx0]
+ mycoef[2] <- (t(Gr)%*%V%*%Gr)^0.5
+ }
+ ## if (second) {
+ ## if (!is.null(attributes(fval)$hessian)) {
+ ## H <- attributes(fval)$hessian(unlist(vals))
+ ## } else {
+ ## H <- hessian(myc, unlist(vals))
+ ## }
+ ## HV <- H%*%vcov[val.idx,val.idx]
+ ## mycoef[1] <- mycoef[1] + 0.5*sum(diag(HV))
+ ## mycoef[2] <- mycoef[2] + 0.5*sum(diag(HV%*%HV))
+ ## }
+ mycoef[3] <- mycoef[1]/mycoef[2]
+ mycoef[4] <- 2*(pnorm(abs(mycoef[3]),lower.tail=FALSE))
+ mycoef[5:6] <- mycoef[1] + c(1,-1)*qnorm((1-level)/2)*mycoef[2]
+ res <- rbind(res,mycoef)
+ mynames <- c(mynames,pp)
+ if (!is.null(attributes(fval)$inv)){
+ res2 <- attributes(fval)$inv(mycoef[c(1,5,6)])
+ res <- rbind(res, c(res2[1],NA,NA,NA,res2[2],res2[3]))
+ mynames <- c(mynames,paste0("inv(",pp,")"))
+ }
+ }
+ rownames(res) <- mynames
+ colnames(res) <- c("Estimate","Std. Error", "Z value", "Pr(>|z|)", "2.5%", "97.5%")
+ return(res)
+}
diff --git a/R/contr.R b/R/contr.R
new file mode 100644
index 0000000..ea2aea2
--- /dev/null
+++ b/R/contr.R
@@ -0,0 +1,36 @@
+##' Create contrast matrix
+##'
+##' Create contrast matrix typically for use with 'estimate' (Wald tests).
+##' @export
+##' @param p index of non-zero entries (see example)
+##' @param n Total number of parameters (if omitted the max number in p will be used)
+##' @param diff If FALSE all non-zero entries are +1, otherwise the second non-zero element in each row will be -1.
+##' @param ... Additional arguments to lower level functions
+##' @aliases contr parsedesign
+##' @examples
+##' contr(2,n=5)
+##' contr(as.list(2:4),n=5)
+##' contr(list(1,2,4),n=5)
+##' contr(c(2,3,4),n=5)
+##' contr(list(c(1,3),c(2,4)),n=5)
+##' contr(list(c(1,3),c(2,4),5))
+##'
+##' parsedesign(c("aa","b","c"),"?","?",diff=c(FALSE,TRUE))
+contr <- function(p,n,diff=TRUE,...) {
+ if (missing(n)) n <- max(unlist(p))
+ if (is.character(p)) {
+ return(parsedesign(n,p,...))
+ }
+ if (is.list(p)) {
+ return(Reduce(rbind,lapply(p, function(x) do.call(contr, list(x,n,diff[1L])))))
+ }
+ if (is.character(n)) n <- length(n)
+ if (!is.numeric(n)) {
+ try(n <- length(coef(n)),silent=TRUE)
+ }
+ B <- matrix(0,ncol=n,nrow=max(1L,length(p)-1L))
+ B[,p[1]] <- 1L
+ if (length(p)>1L)
+ B[cbind(seq(nrow(B)),p[-1])] <- ifelse(diff[1L],-1,1)
+ return(B)
+}
diff --git a/R/correlation.R b/R/correlation.R
new file mode 100644
index 0000000..6751398
--- /dev/null
+++ b/R/correlation.R
@@ -0,0 +1,103 @@
+##' Generic correlation method
+##'
+##' @title Generic method for extracting correlation coefficients of model object
+##' @param x Object
+##' @param \dots Additional arguments
+##' @author Klaus K. Holst
+##' @export
+"correlation" <- function(x,...) UseMethod("correlation")
+
+##' @export
+correlation.lvmfit <- function(x,z=TRUE,iid=FALSE,back.transform=TRUE,...) {
+ pp <- matrices2(Model(x), with(index(x),seq_len(npar+npar.mean+npar.ex)))$P
+ pos <- pp[lower.tri(pp)][(index(x)$P0)[lower.tri(pp)]==1]
+ if (length(pos)<1) return(NULL)
+ pp0 <- pp
+ pp0[index(x)$P0!=1] <- 0; pp0[lower.tri(pp0)] <- 0
+ coords <- c()
+ mynames <- vars(x)
+ n <- nrow(pp0)
+ ff <- function(p) {
+ res <- numeric(length(pos))
+ nn <- character(length(pos))
+ for (i in seq_along(pos)) {
+ p0 <- pos[i]
+ idx <- which(pp0==p0)
+ rowpos <- (idx-1)%%n + 1
+ colpos <- ceiling(idx/n)
+ coefpos <- c(p0,pp0[rbind(c(rowpos,rowpos),c(colpos,colpos))])
+ pval <- pp[rbind(c(rowpos,rowpos),c(colpos,colpos))]
+ phi.v1.v2 <- numeric(3);
+ newval <- p[coefpos]
+ phi.v1.v2[coefpos!=0] <- newval
+ phi.v1.v2[coefpos==0] <- pval[tail(coefpos==0,2)]
+ rho <- atanh(phi.v1.v2[1]/sqrt(prod(phi.v1.v2[-1])))
+ res[i] <- rho
+ nn[i] <- paste(mynames[c(rowpos,colpos)],collapse="~")
+ }
+ structure(res,names=nn)
+ }
+ V <- NULL
+ if (!iid) V <- vcov(x)
+ if (back.transform) {
+ back.transform <- tanh
+ } else {
+ back.transform <- NULL
+ }
+ estimate(x,coef=coef(x),vcov=V,f=ff,back.transform=back.transform,iid=iid,...)
+}
+
+
+##' @export
+correlation.matrix <- function(x,z=TRUE,back.transform=TRUE,mreg=FALSE,return.all=FALSE,...) {
+ if (mreg) {
+ m <- lvm()
+ covariance(m,pairwise=TRUE) <- colnames(x)
+ try(e <- estimate(m,as.data.frame(x),...),silent=TRUE)
+ res <- correlation(e,...)
+ if (return.all) {
+ return(list(model=m,estimate=e,correlation=res))
+ }
+ return(res)
+ }
+ if (ncol(x)==2) {
+ ii <- iid(x)
+ ee <- estimate(coef=attributes(ii)$coef[3:5], iid=ii[,3:5])
+ if (z) {
+ if (back.transform) {
+ ee <- estimate(ee, function(x) atanh(x[2]/sqrt(x[1]*x[3])), back.transform=tanh)
+ } else {
+ ee <- estimate(ee, function(x) atanh(x[2]/sqrt(x[1]*x[3])))
+ }
+ } else {
+ ee <- estimate(ee, function(x) x[2]/sqrt(x[1]*x[3]))
+ }
+ return(ee)
+ }
+
+ e <- c()
+ R <- diag(nrow=ncol(x))
+ dimnames(R) <- list(colnames(x),colnames(x))
+ for (i in seq(ncol(x)-1))
+ for (j in seq(i+1,ncol(x))) {
+ e <- c(e,list(correlation(x[,c(i,j)],z=z,back.transform=FALSE,...)))
+ R[j,i] <- coef(e[[length(e)]])
+ if (z) R[j,i] <- tanh(R[j,i])
+ }
+ R <- R[-1,-ncol(R),drop=FALSE]
+ res <- do.call(merge, c(e, paired=TRUE))
+ if (z && back.transform) {
+ res <- estimate(res,back.transform=tanh, print=function(x,digits=1,...) {
+ print(x$coefmat[,-2,drop=FALSE],...)
+ cat("\n")
+ print(offdiag(R,type=4),digits=digits,...)
+ })
+ }
+ return(res)
+}
+
+##' @export
+correlation.data.frame <- function(x,...) {
+ correlation(as.matrix(x),...)
+}
+
diff --git a/R/covariance.R b/R/covariance.R
new file mode 100644
index 0000000..d442073
--- /dev/null
+++ b/R/covariance.R
@@ -0,0 +1,304 @@
+
+##' Add covariance structure to Latent Variable Model
+##'
+##' Define covariances between residual terms in a \code{lvm}-object.
+##'
+##' The \code{covariance} function is used to specify correlation structure
+##' between residual terms of a latent variable model, using a formula syntax.
+##'
+##' For instance, a multivariate model with three response variables,
+##'
+##' \deqn{Y_1 = \mu_1 + \epsilon_1}
+##'
+##' \deqn{Y_2 = \mu_2 + \epsilon_2}
+##'
+##' \deqn{Y_3 = \mu_3 + \epsilon_3}
+##'
+##' can be specified as
+##'
+##' \code{m <- lvm(~y1+y2+y3)}
+##'
+##' Pr. default the two variables are assumed to be independent. To add a
+##' covariance parameter \eqn{r = cov(\epsilon_1,\epsilon_2)}, we execute the
+##' following code
+##'
+##' \code{covariance(m) <- y1 ~ f(y2,r)}
+##'
+##' The special function \code{f} and its second argument could be omitted thus
+##' assigning an unique parameter the covariance between \code{y1} and
+##' \code{y2}.
+##'
+##' Similarily the marginal variance of the two response variables can be fixed
+##' to be identical (\eqn{var(Y_i)=v}) via
+##'
+##' \code{covariance(m) <- c(y1,y2,y3) ~ f(v)}
+##'
+##' To specify a completely unstructured covariance structure, we can call
+##'
+##' \code{covariance(m) <- ~y1+y2+y3}
+##'
+##' All the parameter values of the linear constraints can be given as the right
+##' handside expression of the assigment function \code{covariance<-} if the
+##' first (and possibly second) argument is defined as well. E.g:
+##'
+##' \code{covariance(m,y1~y1+y2) <- list("a1","b1")}
+##'
+##' \code{covariance(m,~y2+y3) <- list("a2",2)}
+##'
+##' Defines
+##'
+##' \deqn{var(\epsilon_1) = a1}
+##'
+##' \deqn{var(\epsilon_2) = a2}
+##'
+##' \deqn{var(\epsilon_3) = 2}
+##'
+##' \deqn{cov(\epsilon_1,\epsilon_2) = b1}
+##'
+##' Parameter constraints can be cleared by fixing the relevant parameters to
+##' \code{NA} (see also the \code{regression} method).
+##'
+##' The function \code{covariance} (called without additional arguments) can be
+##' used to inspect the covariance constraints of a \code{lvm}-object.
+##'
+#
+##'
+##' @aliases covariance covariance<- covariance.lvm covariance<-.lvm
+##' covfix<- covfix covfix<-.lvm covfix.lvm
+##' variance variance<- variance.lvm variance<-.lvm
+##' @param object \code{lvm}-object
+##' @param var1 Vector of variables names (or formula)
+##' @param var2 Vector of variables names (or formula) defining pairwise
+##' covariance between \code{var1} and \code{var2})
+##' @param constrain Define non-linear parameter constraints to ensure positive definite structure
+##' @param pairwise If TRUE and \code{var2} is omitted then pairwise correlation is added between all variables in \code{var1}
+##' @param \dots Additional arguments to be passed to the low level functions
+##' @param value List of parameter values or (if \code{var1} is unspecified)
+##' @usage
+##' \method{covariance}{lvm}(object, var1=NULL, var2=NULL, constrain=FALSE, pairwise=FALSE,...) <- value
+##' @return A \code{lvm}-object
+##' @author Klaus K. Holst
+##' @seealso \code{\link{regression<-}}, \code{\link{intercept<-}},
+##' \code{\link{constrain<-}} \code{\link{parameter<-}}, \code{\link{latent<-}},
+##' \code{\link{cancel<-}}, \code{\link{kill<-}}
+##' @keywords models regression
+##' @export
+##' @examples
+##'
+##' m <- lvm()
+##' ### Define covariance between residuals terms of y1 and y2
+##' covariance(m) <- y1~y2
+##' covariance(m) <- c(y1,y2)~f(v) ## Same marginal variance
+##' covariance(m) ## Examine covariance structure
+##'
+##'
+`covariance` <- function(object,...) UseMethod("covariance")
+
+##' @export
+"variance<-" <- function(object,...,value) UseMethod("covariance<-")
+
+##' @export
+`variance` <- function(object,...) UseMethod("variance")
+
+##' @export
+"variance.lvm" <- function(object,...) covariance(object,...)
+
+##' @export
+"variance.formula" <- function(object,...) covariance(lvm(),object,...)
+
+##' @export
+"covariance.formula" <- function(object,...) covariance(lvm(),object,...)
+
+
+##' @export
+"variance<-.lvm" <- function(object,...,value) {
+ covariance(object,...) <- value
+ return(object)
+}
+
+##' @export
+"covariance<-" <- function(object,...,value) UseMethod("covariance<-")
+
+##' @export
+"covariance<-.lvm" <- function(object, var1=NULL, var2=NULL, constrain=FALSE, pairwise=FALSE, ..., value) {
+
+ if (!is.null(var1)) {
+ if (inherits(var1,"formula")) {
+ lhs <- getoutcome(var1)
+ xf <- attributes(terms(var1))$term.labels
+ xx <- unlist(lapply(xf, function(x) x[1]))
+ if (length(lhs)==0) {
+ covfix(object,var1,var2,pairwise=pairwise,...) <- value
+ object$parpos <- NULL
+ return(object)
+ }
+ else {
+ yy <- decomp.specials(lhs)
+ }
+ } else {
+ yy <- var1; xx <- var2
+ }
+ covfix(object,var1=yy,var2=xx,pairwise=pairwise,...) <- value
+ object$parpos <- NULL
+ return(object)
+ }
+
+ if (is.list(value)) {
+ for (v in value) {
+ covariance(object,pairwise=pairwise,constrain=constrain,...) <- v
+ }
+ return(object)
+ }
+
+ if (inherits(value,"formula")) {
+ lhs <- getoutcome(value)
+ if (length(lhs)==0) {
+ return(covariance(object,all.vars(value),constrain=constrain,pairwise=pairwise,...))
+ }
+ yy <- decomp.specials(lhs)
+
+ tt <- terms(value, specials=c("f","v"))
+ xf <- attributes(terms(tt))$term.labels
+ res <- lapply(xf,decomp.specials)
+ nx <- length(xf)
+ if (nx==1) {
+ if(is.null(attr(tt,"specials")$f) | length(res[[1]])<2) {
+ if(is.null(attr(tt,"specials")$v) & is.null(attr(tt,"specials")$f))
+
+ {
+ for (i in yy)
+ for (j in res[[1]])
+ object <- covariance(object, c(i,j), pairwise=TRUE, constrain=constrain, ...)
+ } else {
+ covfix(object,var1=yy,var2=NULL) <- res[[1]]
+ }
+ } else {
+ covfix(object,var1=yy,var2=res[[1]][1]) <- res[[1]][2]
+ }
+ object$parpos <- NULL
+ return(object)
+ }
+
+ xx <- unlist(lapply(res, function(z) z[1]))
+ for (y in yy)
+ for (i in seq_along(xx)) {
+ if (length(res[[i]])>1) {
+ covfix(object, var1=y, var2=res[[i]][1]) <- res[[i]][2]
+ } else if ((i+1)%in%attr(tt,"specials")$f | (i+1)%in%attr(tt,"specials")$v) {
+ covfix(object, var1=y, var2=NULL) <- res[[i]]
+ } else {
+ object <- covariance(object,c(y,xx[i]),pairwise=TRUE,...)
+ }
+ }
+
+ object$parpos <- NULL
+ return(object)
+ }
+ else covariance(object,value,pairwise=pairwise,...)
+}
+
+##' @export
+`covariance.lvm` <-
+ function(object,var1=NULL,var2=NULL,exo=FALSE,pairwise=FALSE,constrain=FALSE,value,...) {
+
+ if (!missing(value)) {
+ covariance(object,var1=var1,var2,exo=exo,pariwise=pairwise,constrain=constrain,...) <- value
+ return(object)
+ }
+ if (!is.null(var1)) {
+ if (inherits(var1,"formula")) {
+ covariance(object,constrain=constrain,
+ pairwise=pairwise,exo=exo,...) <- var1
+ return(object)
+ }
+ allvars <- var1
+ if (!missing(var2)) {
+ if (inherits(var2,"formula"))
+ var2 <- all.vars(var2)
+ allvars <- c(allvars,var2)
+ }
+ if (constrain) {
+ if (length(allvars)!=2) stop("Constraints only implemented for pairs")
+ return(covarianceconst(object,allvars[1],allvars[2],...))
+ }
+
+ object <- addvar(object, allvars, silent=TRUE, reindex=FALSE)
+
+ xorg <- exogenous(object)
+ exoset <- setdiff(xorg,allvars)
+ if (!exo & length(exoset)<length(xorg)) {
+ exogenous(object) <- exoset
+ }
+
+ if (!missing(var2)) {
+ for (i in seq_len(length(var1))) {
+ c1 <- var1[i]
+ for (j in seq_len(length(var2))) {
+ c2 <- var2[j]
+ object$cov[c1,c2] <- object$cov[c2,c1] <- 1
+ object$parpos <- NULL
+ index(object) <- reindex(object)
+ }
+ }
+ }
+ else {
+ if (pairwise) {
+ for (i in seq_len(length(var1))) {
+ c1 <- var1[i]
+ for (j in seq_len(length(var1))) {
+ c2 <- var1[j]
+ object$cov[c1,c2] <- object$cov[c2,c1] <- 1
+ object$parpos <- NULL
+ index(object) <- reindex(object)
+ }
+ }
+ }
+ }
+ return(object)
+ }
+ else
+ return(covfix(object))
+}
+
+covarianceconst <- function(object,var1,var2,cname=NA,rname=NA,vname=NA,v2name=vname,lname=NA,l2name=lname,...) {
+ if (inherits(var1,"formula")) {
+ var1 <- getoutcome(var1)
+ var2 <- attributes(var1)$x
+ }
+ curpar <- parlabels(object)
+ if (is.na(cname)) {
+ cname <- object$covpar[var1,var2]
+ }
+
+ if (is.na(v2name)) {
+ v2name <- object$covpar[var2,var2]
+ }
+ if (is.na(vname)) {
+ vname <- object$covpar[var1,var1]
+ }
+
+ nvarname <- c("rname","cname","vname","v2name","lname","l2name")[is.na(c(rname,cname,vname,v2name,lname,l2name))]
+
+ nprefix <- sapply(nvarname, function(x) substr(x,1,1))
+ for (i in seq_len(length(nvarname))) {
+ count <- 0
+ repeat {
+ count <- count+1
+ curname <- paste0(nprefix[i],count)
+ if (!(curname%in%curpar)) break;
+ }
+ curpar <- c(curname,curpar)
+ assign(nvarname[i],curname)
+ }
+ covariance(object,c(var1,var2)) <- c(vname,v2name)
+ ff <- function(x) exp(x)
+ constrain(object,vname,lname) <- ff
+ if (vname!=v2name)
+ constrain(object,v2name,l2name) <- ff
+ covariance(object,var1,var2) <- cname
+ cpar <- unique(c(lname,l2name,rname))
+ constrain(object,cname,cpar) <- function(x) {
+ prod(exp(x[seq(length(cpar)-1)]))^(1/(length(cpar)-1))*tanh(x[length(cpar)])
+ }
+ return(structure(object,rname=rname,cname=cname))
+}
diff --git a/R/csplit.R b/R/csplit.R
new file mode 100644
index 0000000..fc03cce
--- /dev/null
+++ b/R/csplit.R
@@ -0,0 +1,44 @@
+##' Split data into folds
+##'
+##' @title Split data into folds
+##' @param x Data or integer (size)
+##' @param p Number of folds, or if a number between 0 and 1 is given two folds of size p and (1-p) will be returned
+##' @param replace With or with-out replacement
+##' @param return.index If TRUE index of folds are returned otherwise the actual data splits are returned (default)
+##' @param k (Optional, only used when p=NULL) number of folds without shuffling
+##' @param ... additional arguments to lower level functions
+##' @export
+##' @aliases csplit foldr
+##' @examples
+##' foldr(5,2,rep=2)
+##' csplit(10,3)
+##' csplit(iris[1:10,]) ## Split in two sets 1:(n/2) and (n/2+1):n
+##' csplit(iris[1:10,],0.5)
+##' @author Klaus K. Holst
+csplit <- function(x,p=NULL,replace=FALSE,return.index=FALSE,k=2,...) {
+ if (length(x)==1 & is.numeric(x)) x <- seq(x)
+ N <- NROW(x)
+ if (is.null(p)) { ##
+ K <- base::round(N/k)
+ idx <- split(seq(N),sort(rep(seq(k),length.out=N,each=K)))
+ } else {
+ if (p<1) { ## two folds (size N*p and N*(1-p))
+ idx1 <- base::sample(N,base::round(p*N),replace=replace)
+ idx <- list(idx1,
+ base::sample(setdiff(seq(N),idx1),replace=replace))
+ } else { ## Number of folds (equal size)
+ idx <- split(sample(seq(N)), rep(seq(p), length=N))
+ }
+ }
+ if (return.index)
+ return(idx)
+ if (!is.vector(x)) {
+ return(lapply(idx,function(ii) x[ii,,drop=FALSE]))
+ }
+ return(lapply(idx,function(ii) x[ii]))
+}
+
+##' @export
+foldr <- function(n,K=5,rep=10) {
+ replicate(rep,split(sample(seq(n)), rep(seq(K), length=n)),simplify=FALSE)
+}
diff --git a/R/curly.R b/R/curly.R
new file mode 100644
index 0000000..a491418
--- /dev/null
+++ b/R/curly.R
@@ -0,0 +1,88 @@
+##' Adds curly brackets to plot
+##'
+##' @title Adds curly brackets to plot
+##' @param x center of the x axis of the curly brackets (or start end coordinates (x1,x2))
+##' @param y center of the y axis of the curly brackets (or start end coordinates (y1,y2))
+##' @param len Length of the curly brackets
+##' @param theta angle (in radians) of the curly brackets orientation
+##' @param wid Width of the curly brackets
+##' @param shape shape (curvature)
+##' @param col color (passed to lines/grid.lines)
+##' @param lwd line width (passed to lines/grid.lines)
+##' @param lty line type (passed to lines/grid.lines)
+##' @param grid If TRUE use grid graphics (compatability with ggplot2)
+##' @param npoints Number of points used in curves
+##' @param text Label
+##' @param offset Label offset (x,y)
+##' @export
+##' @examples
+##' if (interactive()) {
+##' plot(0,0,type="n",axes=FALSE,xlab="",ylab="")
+##' curly(x=c(1,0),y=c(0,1),lwd=2,text="a")
+##' curly(x=c(1,0),y=c(0,1),lwd=2,text="b",theta=pi)
+##' curly(x=-0.5,y=0,shape=1,theta=pi,text="c")
+##' curly(x=0,y=0,shape=1,theta=0,text="d")
+##' curly(x=0.5,y=0,len=0.2,theta=pi/2,col="blue",lty=2)
+##' curly(x=0.5,y=-0.5,len=0.2,theta=-pi/2,col="red",shape=1e3,text="e")
+##' }
+curly <- function(x,y,len=1,theta=0,
+ wid,shape=1,
+ col=1,lwd=1,lty=1,
+ grid=FALSE,npoints=50,text=NULL,offset=c(0.05,0)) {
+ if (length(x)==2 || length(y)==2) {
+ x <- rep(x,length.out=2)
+ y <- rep(y,length.out=2)
+ v <- c(x[1]-x[2],y[1]-y[2])
+ v0 <- c(1,0)-v
+ len <- sum(v^2)^.5
+ innerprod <- sum(v0)
+ theta <- acos(innerprod/len)+theta
+ len <- len/2
+ x <- (x[1]-x[2])/2
+ y <- (y[2]-y[1])/2
+ }
+ ii <- seq(0, pi/2, length.out=npoints)
+ if (missing(wid)) {
+ wid <- with(devcoords(),
+ (fig.y2-fig.y1)/50)
+ }
+ x1 <- c(wid*(sin(ii)-1),
+ c(0,0),
+ wid*(1 - sin(rev(ii))),
+ wid*(1 - sin(ii)),
+ c(0,0),
+ wid*(sin(rev(ii)) - 1))
+ y1 <- c(-cos(ii),
+ c(0,shape),
+ shape+(cos(rev(ii))),
+ shape+(2 - cos(ii)),
+ c(shape+2, 2*shape+2),
+ 2*shape+2+cos(rev(ii)))
+
+ x1 <- x1 + x + wid
+ idx.max <- which.max(x1)
+ max.y <- max(y1)
+ y1 <- y1+1-(max.y+1)/2
+ min.y <- min(y1)
+ y1 <- y1*len/min.y+y
+ ## Rotation
+ x2 <- cos(theta) * (x1 - x) - sin(theta) * (y1 - y) + x
+ y2 <- cos(theta) * (y1 - y) + sin(theta) * (x1 - x) + y
+ x0 <- x1[idx.max]+offset[1]
+ y0 <- y1[idx.max]+offset[2]
+ xm <- cos(theta) * (x0 - x) - sin(theta) * (y0 - y) + x
+ ym <- cos(theta) * (y0 - y) + sin(theta) * (x0 - x) + y
+ if(grid){
+ grid::grid.lines(grid::unit(x2,"npc"), grid::unit(y2,"npc"),
+ gp=grid::gpar(col=col,lwd=lwd,lty=lty))
+ }
+ else{
+ points(x2,y2,type='l',col=col,lwd=lwd,lty=lty,xpd=TRUE)
+ }
+ theta <- acos(abs(cos(theta)))
+ deg <- ((theta-pi/2)*180/pi)
+ if (!is.null(text)) {
+ text(xm,ym,text,srt=deg)
+ }
+}
+
diff --git a/R/cv.R b/R/cv.R
new file mode 100644
index 0000000..4bba1df
--- /dev/null
+++ b/R/cv.R
@@ -0,0 +1,102 @@
+rmse1 <- function(fit,data,response=NULL,...) {
+ yhat <- predict(fit,newdata=data)
+ if (is.null(response)) response <- endogenous(fit)
+ y <- data[,response]
+ c(RMSE=mean(as.matrix(y-yhat)^2))
+}
+
+##' Cross-validation
+##'
+##' Generic cross-validation function
+##' @title Cross-validation
+##' @param modelList List of fitting functions or models
+##' @param data data.frame
+##' @param K Number of folds (default 5)
+##' @param rep Number of repetitions (default 1)
+##' @param perf Performance measure (default RMSE)
+##' @param seed Optional random seed
+##' @param mc.cores Number of cores used for parallel computations
+##' @param ... Additional arguments parsed to models in modelList and perf
+##' @author Klaus K. Holst
+##' @examples
+##' f0 <- function(data,...) lm(...,data)
+##' f1 <- function(data,...) lm(Sepal.Length~Species,data)
+##' f2 <- function(data,...) lm(Sepal.Length~Species+Petal.Length,data)
+##' x <- cv(list(m0=f0,m1=f1,m2=f2),rep=10, data=iris, formula=Sepal.Length~.)
+##' x2 <- cv(list(f0(iris),f1(iris),f2(iris)),rep=10, data=iris)
+##' @export
+cv <- function(modelList, data, K=5, rep=1, perf, seed=NULL, mc.cores=1, ...) {
+ if (missing(perf)) perf <- rmse1
+ if (!is.list(modelList)) modelList <- list(modelList)
+ nam <- names(modelList)
+ if (is.null(nam)) nam <- paste0("model",seq_along(modelList))
+ args <- list(...)
+ ## Models run on full data:
+ if (is.function(modelList[[1]])) {
+ fit0 <- lapply(modelList, function(f) do.call(f,c(list(data),args)))
+ } else {
+ fit0 <- modelList
+ }
+ ## In-sample predictive performance:
+ perf0 <- lapply(fit0, function(fit) do.call(perf,c(list(fit,data=data),args)))
+ namPerf <- names(perf0[[1]])
+ names(fit0) <- names(perf0) <- nam
+ n <- nrow(data)
+ M <- length(perf0) # Number of models
+ P <- length(perf0[[1]]) # Number of performance measures
+ if (!is.null(seed)) {
+ if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE))
+ runif(1)
+ R.seed <- get(".Random.seed", envir = .GlobalEnv)
+ set.seed(seed)
+ RNGstate <- structure(seed, kind = as.list(RNGkind()))
+ on.exit(assign(".Random.seed", R.seed, envir = .GlobalEnv))
+ }
+
+ dim <- c(rep,K,M,P)
+ PerfArr <- array(0,dim)
+ dimnames(PerfArr) <- list(NULL,NULL,nam,namPerf)
+ folds <- foldr(n,K,rep)
+ arg <- expand.grid(R=seq(rep),K=seq(K)) #,M=seq_along(modelList))
+
+ ff <- function(i) {
+ R <- arg[i,1]
+ k <- arg[i,2]
+ fold <- folds[[R]]
+ dtest <- data[fold[[k]],]
+ dtrain <- data[unlist(fold[-k]),]
+ if (is.function(modelList[[1]])) {
+ fits <- lapply(modelList, function(f) do.call(f,c(list(dtrain),args)))
+ } else {
+ fits <- lapply(modelList, function(m) do.call(update,c(list(m,data=dtrain),args)))
+ }
+ perfs <- lapply(fits, function(fit) do.call(perf,c(list(fit,data=dtest),args)))
+ do.call(rbind,perfs)
+ }
+ if (mc.cores>1) {
+ val <- parallel::mcmapply(ff,seq(nrow(arg)),SIMPLIFY=FALSE,mc.cores=mc.cores)
+ } else {
+ val <- mapply(ff,seq(nrow(arg)),SIMPLIFY=FALSE)
+ }
+ for (i in seq(nrow(arg))) {
+ R <- arg[i,1]
+ k <- arg[i,2]
+ PerfArr[R,k,,] <- val[[i]]
+ }
+
+ structure(list(cv=PerfArr,
+ call=match.call(),
+ names=nam,
+ rep=rep, folds=K,
+ fit=fit0),
+ class="CrossValidated")
+}
+
+##' @export
+print.CrossValidated <- function(x,...) {
+ ##print(drop(x$cv))
+ res <- apply(x$cv,3:4,function(x) mean(x))
+ if (length(x$names)==nrow(res)) rownames(res) <- x$names
+ print(res,quote=FALSE)
+}
+
diff --git a/R/deriv.R b/R/deriv.R
new file mode 100644
index 0000000..231a405
--- /dev/null
+++ b/R/deriv.R
@@ -0,0 +1,222 @@
+##' @export
+deriv.lvm <- function(expr, p, mom, conditional=FALSE, meanpar=TRUE, mu=NULL, S=NULL, second=FALSE, zeroones=FALSE, all=!missing(mom),...) {
+
+ if (missing(mom) & !missing(p)) {
+ mom <- modelVar(expr,p,conditional=conditional,...)
+ all <- TRUE
+ if (mom$npar==length(p))
+ meanpar <- NULL
+ }
+
+ ii <- index(expr)
+ npar.total <- npar <- ii$npar; npar.reg <- ii$npar.reg
+ npar.mean <- ifelse(is.null(meanpar),0,ii$npar.mean)
+ npar.ex <- ii$npar.ex
+ meanpar <- seq_len(npar.mean)
+ epar <- seq_len(npar.ex)
+ nn <- expr$parpos
+
+ if (is.null(nn))
+ {
+ nn <- matrices2(expr, seq_len(npar+npar.mean+npar.ex));
+ nn$A[ii$M0!=1] <- 0
+ nn$P[ii$P0!=1] <- 0
+ nn$v[ii$v0!=1] <- 0
+ nn$e[ii$e0!=1] <- 0
+ }
+
+ regr.idx <- seq_len(npar.reg) + npar.mean
+ var.idx <- seq_len(npar-npar.reg) + (npar.mean + npar.reg)
+ mean.idx <- seq_len(npar.mean)
+ npar.total <- npar+length(mean.idx)
+ epar.idx <- seq_len(npar.ex)+npar.total
+ npar.total <- npar.total+length(epar.idx)
+
+ if (zeroones | is.null(ii$dA)) {
+ dimA <- length(ii$A)
+ if (ii$sparse) { ## Not used yet...
+ if (!requireNamespace("Matrix",quietly=TRUE)) stop("package Matrix not available")
+ dP <- dA <- Matrix::Matrix(0, nrow=dimA, ncol=npar.total)
+ } else {
+ dP <- dA <- matrix(0, nrow=dimA, ncol=npar.total)
+ }
+ if (npar.reg>0) {
+## dA[,regr.idx] <- sapply(regr.idx, function(i) izero(ii$reg[ii$reg[,2]==i,1],nrow(dA)))
+ dA[,regr.idx] <- sapply(regr.idx, function(i) izero(which(t(nn$A)==i),nrow(dA)) )
+ }
+ if (npar>npar.reg) {
+ ## dP[,var.idx] <- sapply(var.idx, function(i) izero(ii$cov[ii$cov[,2]==i,1],nrow(dA)) )
+ dP[,var.idx] <- sapply(var.idx, function(i) izero(which(nn$P==i),nrow(dA)) )
+
+ }
+ res <- list(dA=dA, dP=dP)
+
+ {
+ if (ii$sparse) {
+ dv <- Matrix::Matrix(0, nrow=length(expr$mean), ncol=npar.total)
+ } else {
+ dv <- matrix(0, nrow=length(expr$mean), ncol=npar.total)
+ }
+ if (!is.null(meanpar) & npar.mean>0)
+ ## dv[,mean.idx] <- sapply(mean.idx, function(i) izero(ii$mean[ii$mean[,2]==i,1],length(expr$mean)) )
+ dv[,mean.idx] <- sapply(mean.idx, function(i) izero(which(nn$v==i),length(expr$mean)) )
+ res <- c(res, list(dv=dv))
+ }
+ } else {
+ res <- with(ii, list(dA=dA, dP=dP, dv=dv))
+ for (pp in nn$parval) {
+ res$dP[attributes(pp)$cov.idx,pp] <- 1
+ res$dv[attributes(pp)$m.idx,pp] <- 1
+ }
+ }
+
+ if (!all) return(res)
+ ## Non-linear constraints:
+ cname <- constrainpar <- c()
+ if (!missing(p) && length(index(expr)$constrain.par)>0) {
+ for (pp in index(expr)$constrain.par) {
+ myc <- constrain(expr)[[pp]]
+ if (!is.null(myc)) {
+ parval <- mom$parval
+ vals <- c(parval,constrainpar,mom$v,mom$e)[attributes(myc)$args]
+ fval <- try(myc(unlist(vals)),silent=TRUE)
+ fmat <- inherits(fval,"try-error")
+ if (fmat) fval <- myc(rbind(unlist(vals)))
+ if (!is.null(attributes(fval)$grad)) {
+ if (fmat) {
+ Gr <- attributes(fval)$grad(rbind(unlist(vals)))
+ } else {
+ Gr <- attributes(fval)$grad(unlist(vals))
+ }
+ } else {
+ ## if (!requireNamespace("numDeriv")) stop("numDeriv or analytical derivatives needed!")
+ if (fmat) {
+ Gr <- as.numeric(numDeriv::jacobian(myc, rbind(unlist(vals))))
+ } else {
+ Gr <- as.numeric(numDeriv::jacobian(myc, unlist(vals)))
+ }
+ }
+ mat.idx <- mom$constrain.idx[[pp]]
+ cname <- c(cname,pp)
+ attributes(fval)$grad <- Gr
+ attributes(fval)$vals <- vals
+ constrainpar <- c(constrainpar,list(fval)); names(constrainpar) <- cname
+
+ for (jj in seq_len(length(vals))) {
+ allpars <- c(nn$A[attributes(vals[[jj]])$reg.idx[1]],
+ nn$P[attributes(vals[[jj]])$cov.idx[1]],
+ nn$v[attributes(vals[[jj]])$m.idx[1]],
+ nn$e[attributes(vals[[jj]])$e.idx[1]]
+ )
+ if (!is.null(mat.idx$cov.idx))
+ res$dP[mat.idx$cov.idx,allpars] <- Gr[jj]
+ if (!is.null(mat.idx$reg.idx))
+ res$dA[mat.idx$reg.tidx,allpars] <- Gr[jj]
+ if (!is.null(res$dv) & !is.null(mat.idx$m.idx))
+ res$dv[mat.idx$m.idx,allpars] <- Gr[jj]
+ }
+ }
+ }
+ }
+
+ if (is.null(ii$Kkk)) {
+ nobs <- nrow(mom$J)
+ ii$Ik <- diag(nrow=nobs)
+ ii$Im <- diag(nrow=ncol(ii$A))
+ ## ii$Kkk <- commutation(nobs,sparse=FALSE)
+ }
+
+ N <- NCOL(ii$A)
+ K <- nobs
+ ## if (N>10) {
+ if (!lava.options()$devel) {
+ dG <- with(mom, kronprod(t(IAi),G,res$dA))
+ G3 <- with(mom, kronprod(G,G,res$dP))
+ GP <- with(mom,G%*%P)
+ G1 <- with(mom, kronprod(GP,ii$Ik,dG))
+ G2 <- G1[as.vector(matrix(seq_len(K^2),K,byrow=TRUE)),]
+ dS <- G1+G2+G3
+ } else {
+ dG <- with(mom, kronprod(t(IAi),G,res$dA[,ii$parBelongsTo$reg,drop=FALSE]))
+ G3 <- with(mom, kronprod(G,G,res$dP[,ii$parBelongsTo$cov,drop=FALSE]))
+ GP <- with(mom,G%*%P)
+ G1 <- with(mom, kronprod(GP,ii$Ik,dG))
+ G2 <- G1[as.vector(matrix(seq_len(K^2),K,byrow=TRUE)),]
+ dS <- matrix(0,nrow=nrow(G1),ncol=ncol(res$dA))
+ dS[,ii$parBelongsTo$reg] <- G1+G2; dS[,ii$parBelongsTo$cov] <- G3
+ }
+
+ ## } else {
+ ## dG <- suppressMessages(with(mom, (t(IAi) %x% G) %*% (res$dA)))
+ ## MM <- suppressMessages(with(mom, (G%*%P %x% ii$Ik)))
+ ## G1<- MM %*% (dG)
+ ## ## Commutatation product K*X:
+ ## ## G2 <- with(mom, ii$Kkk%*%(G1))
+ ## G2 <- G1[as.vector(matrix(seq_len(K^2),K,byrow=TRUE)),]
+ ## G3 <- with(mom, (G%x%G)%*%(res$dP))
+ ## dS <- G1+G2+G3
+ ## }
+ ## }
+ res <- c(res, list(dG=dG, dS=dS))
+
+ if (!is.null(mom$v)) {
+ if (lava.options()$devel) {
+ dG <- with(mom, kronprod(t(IAi),G,res$dA[,with(ii$parBelongsTo,c(mean,reg)),drop=FALSE]))
+ }
+ dxi <-
+ with(mom, kronprod(rbind(v),dG))
+ ## with(mom, kronprod(rbind(v),ii$Ik,dG))
+ if (is.matrix(mom$v) && nrow(mom$v)>1) {
+ ## reorder
+ k <- nrow(dxi)/nrow(mom$v)
+ idx0 <- seq(nrow(mom$v))*k-k+1
+ idx <- unlist(lapply(1:k,function(x) idx0+x-1))
+ dxi <- dxi[idx,,drop=FALSE]
+ }
+
+ if (!is.null(res$dv)) {
+ if (!(lava.options()$devel)) {
+ if (is.matrix(mom$v) && nrow(mom$v)>1) {
+ ##dxi <- dxi + cbind(rep(1,nrow(mom$v)))%x%(mom$G%*%res$dv)
+ dxi <- dxi + (mom$G%*%res$dv)%x%cbind(rep(1,nrow(mom$v)))
+ } else {
+ dxi <- dxi+ mom$G%*%res$dv
+ }
+ } else {
+ dxi <- dxi+ mom$G%*%res$dv[,with(ii$parBelongsTo,c(mean,reg))]
+ }
+ }
+ res <- c(res, list(dxi=dxi))
+ if (!is.null(mu)) {
+ muv <- rbind(mu-mom$xi)
+ dT <- suppressMessages(-t(ii$Ik%x%muv + muv%x%ii$Ik) %*% dxi)
+ res <- c(res, list(dT=dT))
+ }
+ }
+
+
+ if (second) {
+ k <- nrow(ii$A)
+ K <- ii$Kkk ## commutation(k,k)
+ I <- ii$Ik ## diag(k)
+ I2 <- diag(nrow=k*k)
+ ## KI <- I[as.vector(matrix(seq_len(K^2),K,byrow=TRUE)),]
+ d2S1 <- t(
+ (I %x% K %x% I) %*% (
+ ( I2 %x% as.vector(mom$G) )%*% dG +
+ ( as.vector(mom$P) %x% I2 )%*% (dP)
+ ) %*% t(dG)
+ )
+ d2S2 <- K%*%d2S1 ### HK?
+ d2S3 <- t(
+ (I %x% K %x% I) %*% (
+ ( I2 %x% as.vector(mom$G) )%*% dG +
+ ( as.vector(mom$G) %x% I2 )%*% dG
+ ) %*% t(dP)
+ )
+ vec.d2S <- d2S1+d2S3+d2S3
+ res <- c(res, list(d2vecS=vec.d2S))
+ }
+
+ return(res)
+}
diff --git a/R/describecoef.R b/R/describecoef.R
new file mode 100644
index 0000000..f13f9b7
--- /dev/null
+++ b/R/describecoef.R
@@ -0,0 +1,28 @@
+##' @export
+describecoef <- function(x,par,from,to,mean=TRUE) {
+ p <- coef(x, mean=mean)
+ if (!missing(from)) {
+ st1 <- paste0(to,lava.options()$symbol[1],from)
+ st2 <- paste0(to,lava.options()$symbol[2],from)
+ st3 <- paste0(from,lava.options()$symbol[2],to)
+ pos <- na.omit(match(unique(c(st1,st2,st3)),p))
+ attributes(pos) <- NULL
+ return(pos)
+ }
+ res <- strsplit(p,lava.options()$symbol[2])
+ var.idx <- which(unlist(lapply(res,length))>1) ## Variance parameters
+ rest.idx <- setdiff(seq_along(p),var.idx)
+ res[rest.idx] <- strsplit(p[rest.idx],lava.options()$symbol[1])
+ mean.idx <- which(unlist(lapply(res,length))==1) ## Mean parameters
+ reg.idx <- setdiff(rest.idx,mean.idx)
+ names(res)[mean.idx] <- paste0("m",seq_along(mean.idx))
+ for (i in var.idx)
+ attr(res[[i]],"type") <- "cov"
+ for (i in mean.idx)
+ attr(res[[i]],"type") <- "mean"
+ for (i in reg.idx)
+ attr(res[[i]],"type") <- "reg"
+ if (missing(par))
+ return(res)
+ return(res[par])
+}
diff --git a/R/devcoords.R b/R/devcoords.R
new file mode 100644
index 0000000..fbc66da
--- /dev/null
+++ b/R/devcoords.R
@@ -0,0 +1,30 @@
+##' Returns device-coordinates and plot-region
+##'
+##' @title Returns device-coordinates and plot-region
+##' @return A \code{list} with elements
+##' \item{dev.x1}{Device: Left x-coordinate}
+##' \item{dev.x2}{Device: Right x-coordinate}
+##' \item{dev.y1}{Device Bottom y-coordinate}
+##' \item{dev.y2}{Device Top y-coordinate}
+##' \item{fig.x1}{Plot: Left x-coordinate}
+##' \item{fig.x2}{Plot: Right x-coordinate}
+##' \item{fig.y1}{Plot: Bottom y-coordinate}
+##' \item{fig.y2}{Plot: Top y-coordinate}
+##' @author Klaus K. Holst
+##' @export
+##' @keywords hplot
+`devcoords` <-
+function() {
+ cc <- par("usr") ## extremes of coordinates of plotting region (x1,x2,y1,y2)
+ plotinch <- par("pin") ## Plot dimensions (width,height) in inches
+ margininch <- par("mai") ## Margin sizes in inches (bottom, left, top ,right)
+ plotlenX <- cc[2]-cc[1]
+ unitinchX <- plotlenX/plotinch[1]
+ plotlenY <- cc[4]-cc[3]
+ unitinchY <- plotlenY/plotinch[2]
+ deviceXleft <- cc[1]-unitinchX*margininch[2]
+ deviceXright <- cc[2]+unitinchX*margininch[4]
+ deviceYtop <- cc[4]+unitinchY*margininch[3]
+ deviceYbottom <- cc[3]-unitinchY*margininch[1]
+ return(list(dev.x1=deviceXleft, dev.x2=deviceXright, dev.y1=deviceYbottom, dev.y2=deviceYtop, fig.x1=cc[1], fig.x2=cc[2], fig.y1=cc[3], fig.y2=cc[4]))
+}
diff --git a/R/diagtest.R b/R/diagtest.R
new file mode 100644
index 0000000..8531a03
--- /dev/null
+++ b/R/diagtest.R
@@ -0,0 +1,208 @@
+##' @export
+logit <- function(p) log(p/(1-p))
+
+##' @export
+expit <- function(z) 1/(1+exp(-z))
+
+##' @export
+tigol <- expit
+##' Calculate prevalence, sensitivity, specificity, and positive and
+##' negative predictive values
+##'
+##' @title Calculate diagnostic tests for 2x2 table
+##' @aliases diagtest odds riskcomp OR Ratio Diff
+##' @param table Table or (matrix/data.frame with two columns)
+##' @param positive Switch reference
+##' @param exact If TRUE exact binomial proportions CI/test will be used
+##' @param p0 Optional null hypothesis (test prevalenc, sensitivity, ...)
+##' @param confint Type of confidence limits
+##' @param ... Additional arguments to lower level functions
+##' @author Klaus Holst
+##' @details Table should be in the format with outcome in columns and
+##' test in rows. Data.frame should be with test in the first
+##' column and outcome in the second column.
+##' @examples
+##' M <- as.table(matrix(c(42,12,
+##' 35,28),ncol=2,byrow=TRUE,
+##' dimnames=list(rater=c("no","yes"),gold=c("no","yes"))))
+##' diagtest(M,exact=TRUE)
+##' @export
+diagtest <- function(table,positive=2,exact=FALSE,p0=NA,confint=c("logit","arcsin","pseudoscore","exact"),...) {
+ if (!inherits(table,c("table","data.frame","matrix","multinomial")))
+ stop("Expecting a table or data.frame.")
+ if (is.table(table)) {
+ lev <- dimnames(table)[[2]]
+ }
+ if (inherits(table,"multinomial")) {
+ lev <- dimnames(table$P)[[2]]
+ }
+ if (!is.table(table) & (is.matrix(table) || is.data.frame(table))) {
+ if (is.factor(table[,2])) {
+ lev <- levels(table[,2])
+ } else
+ lev <- unique(table[,2])
+ }
+ if (is.character(positive)) {
+ positive <- match(positive,lev)
+ }
+ if (!(positive%in%c(1,2))) stop("Expecting and index of 1 or 2.")
+ negative <- positive%%2+1L
+ if (!is.null(confint) && confint[1]=="exact") exact <- TRUE
+ if (exact) {
+ if (!is.table(table) && (is.matrix(table) || is.data.frame(table))) {
+ table <- base::table(table[,c(1,2),drop=FALSE])
+ ##names(dimnames(table)) <- colnames(table)[1:2]
+ }
+ if (!is.table(table) || nrow(table)!=2 || ncol(table)!=2) stop("2x2 table expected")
+ n <- sum(table)
+ nc <- colSums(table)
+ nr <- rowSums(table)
+ test <- TRUE
+ if (is.na(p0)) {
+ test <- FALSE
+ p0 <- 0.5
+ }
+ ## Prevalence
+ p1 <- with(stats::binom.test(nc[positive],n,p=p0),c(estimate,conf.int,p.value))
+ ## Test marginal
+ p2 <- with(stats::binom.test(nr[positive],n,p=p0),c(estimate,conf.int,p.value))
+ ## Sensitivity/Specificity
+ sens <- with(stats::binom.test(table[positive,positive],nc[positive],p=p0),c(estimate,conf.int,p.value))
+ spec <- with(stats::binom.test(table[negative,negative],nc[negative],p=p0),c(estimate,conf.int,p.value))
+ ## PPV,NPV
+ ppv <- with(stats::binom.test(table[positive,positive],nr[positive],p=p0),c(estimate,conf.int,p.value))
+ npv <- with(stats::binom.test(table[negative,negative],nr[negative],p=p0),c(estimate,conf.int,p.value))
+ ## Accuracy
+ acc <- with(stats::binom.test(table[positive,positive]+table[negative,negative],n,p=p0),c(estimate,conf.int,p.value))
+ ## Symmetry (McNemar):
+ ## number of discordant pairs under null: b~bin(b+c,0.5)
+ sym <- with(stats::binom.test(table[positive,negative],table[positive,negative]+table[negative,positive],p=0.5),c(estimate,conf.int,p.value))
+ coefmat <- rbind(Prevalence=p1,
+ Test=p2,
+ Sensitivity=sens,
+ Specificity=spec,
+ PositivePredictiveValue=ppv,
+ NegativePredictiveValue=npv,
+ Accuracy=acc,
+ Homogeneity=sym)
+ if (!test) coefmat[seq(nrow(coefmat)-1),4] <- NA
+ coefmat <- cbind(coefmat[,1,drop=FALSE],NA,coefmat[,-1,drop=FALSE])
+ colnames(coefmat) <- c("Estimate","Std.Err","2.5%","97.5%","P-value")
+ res <- list(table=table, prop.table=table/sum(table),
+ coefmat=coefmat)
+ } else {
+ if (inherits(table,"table"))
+ M <- multinomial(table)
+ else {
+ if (inherits(table,"multinomial")) {
+ M <- table
+ table <- round(M$P*nrow(M$data))
+ } else {
+ M <- multinomial(table[,1:2],...)
+ table <- base::table(table)
+ }
+ }
+ calc_diag <- function(p,...) {
+ P <- matrix(p[1:4],2)
+ p1 <- sum(P[,positive])
+ p2 <- sum(P[positive,])
+ res <- c(Prevalence=p1, ##(p[1]+p[2]),
+ Test=p2, ##(p[1]+p[3]),
+ Sensitivity=P[positive,positive]/p1, ## p[1]/(p[1]+p[2]), # Prob test + | given (true) disease (True positive rate)
+ Specificity=P[negative,negative]/(1-p1), ## p[4]/(1-p[1]-p[2]), # Prob test - | given no disease (True negative rate)
+ PositivePredictiveValue=P[positive,positive]/p2, ## p[1]/(p[1]+p[3]), # Prob disease | test +
+ NegativePredictiveValue=P[negative,negative]/(1-p2), ## p[4]/(1-p[1]-p[3]), # Prob disease free | test -
+ Accuracy=(P[1,1]+P[2,2])/sum(P),
+ Homogeneity=P[negative,positive]-P[positive,negative]
+ )
+ if (!is.null(confint)) {
+ if (tolower(confint[1])=="logit") {
+ res[seq(length(res)-1)] <- logit(res[seq(length(res)-1)])
+ } else if (tolower(confint[1])=="arcsin") {
+ res[seq(length(res)-1)] <- asin(sqrt(res[seq(length(res)-1)]))
+ }
+ }
+ return(res)
+ }
+
+ names(dimnames(table)) <- paste0(c("Test:","Outcome:"),names(dimnames(table)))
+ prfun <- function(x,...) {
+ printCoefmat(x$coefmat[,c(-2)],na.print="",...)
+ printline()
+ cat("\n")
+ cat("Prevalence: Prob( outcome+ )\n")
+ cat("Test: Prob( test+ )\n")
+ cat("Sensitivity (True positive rate): Prob( test+ | outcome+ )\n")
+ cat("Specificity (True negative rate): Prob( test- | outcome- )\n")
+ cat("Positive predictive value (Precision): Prob( outcome+ | test+ )\n")
+ cat("Negative predictive value: Prob( outcome- | test- )\n")
+ cat("Accuracy: Prob( correct classification )\n")
+ cat("Homogeneity/Symmetry: Prob( outcome+ ) - Prob( test+ )\n")
+ }
+
+ btransform <- NULL
+ if (!is.null(confint)) {
+ if (tolower(confint[1])=="logit") {
+ btransform <- function(x) {
+ rbind(expit(x[seq(nrow(x)-1),,drop=FALSE]),
+ x[nrow(x),,drop=FALSE])
+ }
+ } else if (tolower(confint[1])=="pseudoscore") {
+ ## TODO, agresti-ryu, biometrika 2010
+ } else if (tolower(confint[1])=="arcsin") {
+ btransform <- function(x) {
+ rbind(sin(x[seq(nrow(x)-1),,drop=FALSE])^2,
+ x[nrow(x),,drop=FALSE])
+ }
+ }
+ }
+ res <- estimate(M,calc_diag,print=prfun,null=c(rep(p0,7),0),back.transform=btransform,...)
+ }
+
+ CI <- confint[1]
+ if (exact) CI <- "exact"
+ if (is.null(CI)) CI <- "wald"
+ res <- structure(c(res,
+ list(table=table, prop.table=table/sum(table),
+ confint=CI,
+ positive=positive,
+ negative=negative,
+ levels=dimnames(table)
+ )),
+ class=c("diagtest","estimate"))
+ res$call <- match.call()
+ rownames(res$coefmat) <- gsub("\\[|\\]","",rownames(res$coefmat))
+ names(res$coef) <- rownames(res$coefmat)
+ return(res)
+}
+
+print.diagtest <- function(x,...) {
+ cat("Call: "); print(x$call)
+ cat("Confidence limits: ", x$confint,"\n",sep="")
+ printline()
+ printmany(x$table,x$prop.table,nspace=2,...)
+ cat("\nPositive outcome: '", x$levels[[2]][x$positive],"'\n",sep="")
+ ##cat("\tNegative outcome: '", x$levels[[2]][x$positive%%2+1],"'\n",sep="")
+ printline()
+ printCoefmat(x$coefmat[,c(-2)],na.print="",...)
+ printline()
+ cat("\n")
+ cat("Prevalence: Prob( outcome+ )\n")
+ cat("Test: Prob( test+ )\n")
+ cat("Sensitivity (True positive rate): Prob( test+ | outcome+ )\n")
+ cat("Specificity (True negative rate): Prob( test- | outcome- )\n")
+ cat("Positive predictive value (Precision): Prob( outcome+ | test+ )\n")
+ cat("Negative predictive value: Prob( outcome- | test- )\n")
+ cat("Accuracy: Prob( correct classification )\n")
+ if (x$confint=="exact") {
+ cat("Homogeneity/Symmetry: Prob( outcome+, test- | discordant ), H0: p=0.5 \n")
+ } else {
+ cat("Homogeneity/Symmetry: H0: Prob( outcome+ ) - Prob( test+ ), H0: p=0\n")
+ }
+ cat("\n")
+}
+
+summary.diagtest <- function(x,...) {
+ x[c("iid","print","id","compare")] <- NULL
+ return(x)
+}
diff --git a/R/distribution.R b/R/distribution.R
new file mode 100644
index 0000000..dd70e08
--- /dev/null
+++ b/R/distribution.R
@@ -0,0 +1,459 @@
+
+###{{{ distribution
+
+##' @export
+"distribution<-" <- function(x,...,value) UseMethod("distribution<-")
+
+##' @export
+"distribution" <- function(x,...,value) UseMethod("distribution")
+
+##' @export
+"distribution<-.lvm" <- function(x,variable,parname=NULL,init,mdist=FALSE,...,value) {
+ if (inherits(variable,"formula")) variable <- all.vars(variable)
+ dots <- list(...)
+
+ if (!missing(value)) {
+ for (obj in c("variable","parname","init","mdist"))
+ if (!is.null(attr(value,obj)) && eval(substitute(missing(a),list(a=obj))))
+ assign(obj,attr(value,obj))
+ }
+ ## Generator <- (is.function(value) && inherits(try(do.call(value,list()),silent=TRUE),"try-error"))
+ ## if (Generator && length(variable)==1) value <- list(value)
+ if (!is.null(parname) || length(dots)>0) { ## || Generator) {
+ if (length(parname)>1 || (is.character(parname))) {
+ if (missing(init)) {
+ parameter(x,start=rep(1,length(parname))) <- parname
+ } else {
+ parameter(x,start=init) <- parname
+ }
+ ## if ("..."%ni%names(formals(value))) formals(value) <- c(formals(value),alist(...=))
+ ## formals(value) <- modifyList(formals(value),dots)
+ gen <- function(n,p,...) {
+ args <- c(n,as.list(p[parname]),dots)
+ names(args) <- names(formals(value))[seq(length(parname)+1)]
+ do.call(value,args)
+ }
+ } else {
+ gen <- value
+ if ("..."%ni%names(formals(gen))) formals(gen) <- c(formals(gen),alist(...=))
+ formals(gen) <- modifyList(formals(gen),dots)
+ ## gen <- function(n,p,...) {
+ ## args <- c(n=n,dots)
+ ## names(args)[1] <- names(formals(value))[1]
+ ## do.call(value,args)
+ ## }
+ }
+ ## if (length(variable)>1)
+ {
+ gen <- list(gen)
+ }
+ distribution(x,variable,mdist=TRUE) <- gen
+ return(x)
+ }
+
+ if (length(variable)==1 && !mdist) {
+ addvar(x) <- as.formula(paste("~",variable))
+ if (is.numeric(value)) value <- list(value)
+ if (!is.null(attributes(value)$mean)) intercept(x,variable) <- attributes(value)$mean
+ if (!is.null(attributes(value)$variance)) variance(x,variable,exo=TRUE) <- attributes(value)$variance
+## if (is.function(value) && "..."%ni%names(formals(value))) formals(value) <- c(formals(value),alist(...=))
+ x$attributes$distribution[[variable]] <- value
+ ## Remove from 'mdistribution'
+ vars <- which(names(x$attributes$mdistribution$var)%in%variable)
+ for (i in vars) {
+ pos <- x$attributes$mdistribution$var[[i]]
+ x$attributes$mdistribution$fun[pos] <- NULL
+ x$attributes$mdistribution$var[which(x$attributes$mdistribution$var==pos)] <- NULL
+ above <- which(x$attributes$mdistribution$var>pos)
+ if (length(above)>0)
+ x$attributes$mdistribution$var[above] <- lapply(x$attributes$mdistribution$var[above],function(x) x-1)
+ }
+ return(x)
+ }
+
+ if (is.list(value) && length(value)==1 && (is.function(value[[1]]) || is.null(value[[1]]))) {
+ addvar(x) <- variable
+ ## Multivariate distribution
+ if (is.null(x$attributes$mdistribution)) x$attributes$mdistribution <- list(var=list(), fun=list())
+ vars <- x$attributes$mdistribution$var
+
+ if (any(ii <- which(names(vars)%in%variable))) {
+ num <- unique(unlist(vars[ii]))
+ vars[which(unlist(vars)%in%num)] <- NULL
+ newfunlist <- list()
+ numleft <- unique(unlist(vars))
+ for (i in seq_along(numleft)) {
+ newfunlist <- c(newfunlist, x$attributes$mdistribution$fun[[numleft[i]]])
+ ii <- which(unlist(vars)==numleft[i])
+ vars[ii] <- i
+ }
+ K <- length(numleft)
+ x$attributes$mdistribution$var <- vars
+ x$attributes$mdistribution$fun <- newfunlist
+ } else {
+ K <- length(x$attributes$mdistribution$fun)
+ }
+ if (length(distribution(x))>0)
+ distribution(x,variable) <- rep(list(NULL),length(variable))
+
+ x$attributes$mdistribution$var[variable] <- K+1
+ x$attributes$mdistribution$fun <- c(x$attributes$mdistribution$fun,value)
+
+ return(x)
+ }
+
+ if ((length(value)!=length(variable) & length(value)!=1))
+ stop("Wrong number of values")
+## if (length(value)==1 && "..."%ni%names(formals(value))) formals(value) <- c(formals(value),alist(...=))
+ for (i in seq_along(variable))
+ if (length(value)==1) {
+ distribution(x,variable[i],...) <- value
+ } else {
+## if ("..."%ni%names(formals(value[[i]]))) formals(value[[i]]) <- c(formals(value[[i]]),alist(...=))
+ distribution(x,variable[i],...) <- value[[i]]
+ }
+ return(x)
+
+}
+
+##' @export
+"distribution.lvm" <- function(x,var,value,multivariate=FALSE,...) {
+ if (!missing(value)) {
+ distribution(x,var,...) <- value
+ return(x)
+ }
+ if (multivariate) return(x$attributes$mdistribution)
+ x$attributes$distribution[var]
+}
+
+###}}} distribution
+
+###{{{ normal/gaussian
+
+##' @export
+normal.lvm <- function(link="identity",mean,sd,log=FALSE,...) {
+ rnormal <- if(log) rlnorm else rnorm
+ fam <- stats::gaussian(link); fam$link <- link
+ f <- function(n,mu,var,...) rnormal(n,fam$linkinv(mu),sqrt(var))
+ if (!missing(mean)) attr(f,"mean") <- mean
+ if (!missing(sd)) attr(f,"variance") <- sd^2
+ attr(f,"family") <- fam
+ return(f)
+}
+
+##' @export
+gaussian.lvm <- normal.lvm
+
+##' @export
+lognormal.lvm <- function(...) structure(normal.lvm(...,log=TRUE),family=list(family="log-normal",...))
+
+###}}} normal/gaussian
+
+###{{{ poisson
+
+##' @export
+poisson.lvm <- function(link="log",lambda,...) {
+ fam <- stats::poisson(link); fam$link <- link
+ f <- function(n,mu,...) {
+ if (missing(n)) {
+ return(fam)
+ }
+ rpois(n,fam$linkinv(mu))
+ }
+ if (!missing(lambda)) attr(f,"mean") <- fam$linkfun(lambda)
+ attr(f,"family") <- fam
+ attr(f,"var") <- FALSE
+ return(f)
+}
+
+###}}} poisson
+
+###{{{ pareto
+
+## @examples
+## m <- lvm()
+## categorical(m,K=3) <- ~x
+## distribution(m,~y) <- pareto.lvm(lambda=1)
+## regression(m,additive=FALSE) <- y~x
+## regression(m) <- y~z
+## d <- sim(m,1e4,p=c("y~x:0"=1,"y~x:1"=1,"y~x:2"=exp(1)))
+##
+## X <- model.matrix(y~-1+factor(x)+z,data=d)
+## mlogL <- function(theta) {
+## lambda <- exp(theta[1])
+## mu <- exp(X%*%theta[-1])
+## -sum(log(lambda*mu*(1+mu*d$y)^{-lambda-1}))
+## }
+## nlminb(rep(0,ncol(X)+1),mlogL)
+##' @export
+pareto.lvm <- function(lambda=1,...) { ## shape: lambda, scale: mu
+ ## Density f(y): lambda*mu*(1+mu*y)^{-lambda-1}
+ ## Survival S(y): (1+mu*y)^{-lambda}
+ ## Inverse CDF: u -> ((1-u)^{-1/lambda}-1)/mu
+ f <- function(n,mu,var,...) {
+ ((1-runif(n))^(-1/lambda)-1)/exp(mu)
+ }
+ attr(f,"family") <- list(family="pareto",
+ par=c(lambda=lambda))
+ return(f)
+}
+
+###}}} pareto
+
+###{{{ threshold
+
+##' @export
+threshold.lvm <- function(p,labels=NULL,...) {
+ if (sum(p)>1 || any(p<0 | p>1)) stop("wrong probability vector") ;
+ if (!is.null(labels))
+ return(function(n,...) {
+ return(cut(rnorm(n),breaks=c(-Inf,qnorm(cumsum(p)),Inf),labels=labels))
+ })
+ function(n,...)
+ cut(rnorm(n),breaks=c(-Inf,qnorm(cumsum(p)),Inf))
+}
+
+###}}} threshold
+
+###{{{ binomial
+
+##' @export
+binomial.lvm <- function(link="logit",p,size=1) {
+ if (substitute(link)==quote(identity)) {
+ link <- "identity"
+ }
+ fam <- stats::binomial(link); fam$link <- link
+ f <- function(n,mu,var,...) {
+ if (missing(n)) {
+ return(fam)
+ }
+ rbinom(n,size,fam$linkinv(mu))
+ }
+ attr(f,"family") <- fam
+ attr(f,"var") <- FALSE
+ if (!missing(p)) attr(f,"mean") <- fam$linkfun(p)
+ ## f <- switch(link,
+ ## logit =
+ ## function(n,mu,var,...) rbinom(n,1,tigol(mu)),
+ ## cloglog =
+ ## function(n,mu,var,...) rbinom(n,1,1-exp(-exp(1-mu))),
+ ## function(n,mu,var=1,...) rbinom(n,1,pnorm(mu,sd=sqrt(var)))
+ ## ### function(n,mu=0,var=1,...) (rnorm(n,mu,sqrt(var))>0)*1
+ ## )
+ ##}
+ return(f)
+}
+
+##' @export
+logit.lvm <- binomial.lvm("logit")
+
+##' @export
+probit.lvm <- binomial.lvm("probit")
+
+###}}} binomial
+
+###{{{ Gamma
+
+##' @export
+Gamma.lvm <- function(link="inverse",shape,rate,unit=FALSE,var=FALSE,log=FALSE,...) {
+ fam <- stats::Gamma(link); fam$link <- link
+ rgam <- if (!log) rgamma else function(...) log(rgamma(...))
+ if (!missing(shape) & !missing(rate))
+ f <- function(n,mu,var,...) rgam(n,shape=shape,rate=rate)
+ if (!missing(shape) & missing(rate)) {
+ if (unit)
+ f <- function(n,mu,var,...) rgam(n,shape=shape,rate=shape)
+ else if (var)
+ f <- function(n,mu,var,...) rgam(n,shape=shape,rate=sqrt(shape/var))
+ else
+ f <- function(n,mu,var,...) rgam(n,shape=shape,rate=shape/fam$linkinv(mu))
+ }
+ if (missing(shape) & !missing(rate)) {
+ if (unit)
+ f <- function(n,mu,var,...) rgam(n,shape=shape,rate=rate)
+ else if (var)
+ f <- function(n,mu,var,...) rgam(n,shape=rate^2*var,rate=rate)
+ else
+ f <- function(n,mu,var,...) rgam(n,shape=rate*fam$linkinv(mu),rate=rate)
+ }
+ if (missing(shape) & missing(rate)) {
+ if (var)
+ f <- function(n,mu,var,...) rgam(n,shape=var,rate=1)
+ else
+ f <- function(n,mu,var,...) rgam(n,shape=fam$linkinv(mu),rate=1)
+ }
+ attr(f,"family") <- fam
+ attr(f,"var") <- FALSE
+ return(f)
+}
+
+##' @export
+loggamma.lvm <- function(...) Gamma.lvm(...,log=TRUE)
+
+###}}} Gamma
+
+###{{{ chisq
+
+##' @export
+chisq.lvm <- function(df=1,...) {
+ function(n,mu,var,...) mu + rchisq(n,df=df)
+}
+
+###}}} chisq
+
+###{{{ student (t-distribution)
+
+##' @export
+student.lvm <- function(df=2,mu,sigma,...) {
+ f <- function(n,mu,var,...) mu + sqrt(var)*rt(n,df=df)
+ if (!missing(mu)) attr(f,"mean") <- mu
+ if (!missing(sigma)) attr(f,"variace") <- sigma^2
+ return(f)
+}
+
+###}}} student (t-distribution)
+
+###{{{ uniform
+
+##' @export
+uniform.lvm <- function(a,b) {
+ if (!missing(a) & !missing(b))
+ f <- function(n,mu,var,...) mu+runif(n,a,b)
+ else
+ f <- function(n,mu,var,...)
+ (mu+(runif(n,-1,1)*sqrt(12)/2*sqrt(var)))
+ return(f)
+}
+
+###}}} uniform
+
+###{{{ weibull
+## see also eventTime.R for coxWeibull
+
+##' @export
+weibull.lvm <- function(scale=1,shape=2) {
+ ## accelerated failure time (AFT) regression
+ ## parametrization.
+ ##
+ ## We parametrize the Weibull distribution (without covariates) as follows:
+ ## hazard(t) = 1/shape * exp(-scale/shape) * t^(1/shape-1)
+ ## The hazard is:
+ ## - rising if shape > 1
+ ## - declining if shape <1
+ ## - constant if shape=1
+ ##
+ ## AFT regression
+ ## hazard(t|Z) = 1/shape * exp(-scale/shape) * t^(1/shape-1) exp(-beta/shape*Z)
+ ## scale^(-1/shape) = exp(a0+a1*X)
+ ## PH regression
+ ## scale = exp(b0+ b1*X)
+ f <- function(n,mu,var,...) {
+ (- log(runif(n)) * exp(log(scale)/shape) * exp(mu/shape))^{shape}
+ ## scale * (-log(1-runif(n)))^{1/shape}
+ ## (- (log(runif(n)) / (1/scale)^(shape) * exp(-mu)))^(1/shape)
+ }
+ attr(f,"family") <- list(family="weibull",
+ regression="AFT",
+ par=c(shape=shape,scale=scale))
+ return(f)
+}
+
+###}}} weibull
+
+###{{{ sequence
+
+##' @export
+sequence.lvm <- function(a=0,b=1,integer=FALSE) {
+ if (integer) {
+ f <- function(n,...) seq(n)
+ return(f)
+ }
+ if (is.null(a) || is.null(b)) {
+ if (!is.null(a)) {
+ f <- function(n,...) seq(a,length.out=n)
+ } else {
+ f <- function(n,...) seq(n)-(n-b)
+ }
+ } else {
+ f <- function(n,...) seq(a,b,length.out=n)
+ }
+ return(f)
+}
+
+###}}} sequence
+
+###{{{ ones
+
+##' @export
+ones.lvm <- function(p=1,interval=NULL) {
+ f <- function(n,...) {
+ if (!is.null(interval)) {
+ val <- rep(0L,n)
+ if (!is.list(interval)) interval <- list(interval)
+ for (i in seq_along(interval)) {
+ ii <- interval[[i]]
+ lo <- round(ii[1]*n)
+ hi <- round(ii[2]*n)
+ val[seq(lo,hi)] <- 1L
+ }
+ return(val)
+ }
+ if (p==0) return(rep(0L,n))
+ val <- rep(1L,n)
+ if (p>0 && p<1) val[seq(n*(1-p))] <- 0L
+ val
+ }
+ return(f)
+}
+
+###}}} ones
+
+###{{{ beta
+
+##' @export
+beta.lvm <- function(alpha=1,beta=1,scale=TRUE) {
+ ## CDF: F(x) = B(x,alpha,beta)/B(alpha,beta)
+ ## Mean: alpha/(alpha+beta)
+ ## Var: alpha*beta/((alpha+beta)^2*(alpha+beta+1))
+ if (scale)
+ f <- function(n,mu,var,...) {
+ m <- alpha/(alpha+beta)
+ v <- alpha*beta/((alpha+beta)^2*(alpha+beta+1))
+ y <- stats::rbeta(n,shape1=alpha,shape2=beta)
+ mu+(y-m)*sqrt(var/v)
+ }
+ else
+ f <- function(n,mu,var,...) stats::rbeta(n,shape1=alpha,shape2=beta)
+ return(f)
+}
+
+###}}} beta
+
+###{{{ Gaussian mixture
+
+##' @export
+GM2.lvm <- function(...,parname=c("Pr","M1","M2","V1","V2"),init=c(0.5,-4,4,1,1)) {
+ f <- function(n,pr,m1,m2,v1,v2) {
+ y1 <- rnorm(n,m1,v1^0.5)
+ if (pr>=1) return(y1)
+ z <- rbinom(n,1,pr)
+ y2 <- rnorm(n,m2,v2^0.5)
+ return(z*y1+(1-z)*y2)
+ }
+ structure(f,parname=parname,init=init)
+}
+
+##' @export
+GM3.lvm <- function(...,parname=c("Pr1","Pr2","M1","M2","M3","V1","V2","V3"),init=c(0.25,0.5,-4,0,4,1,1,1)) {
+ f <- function(n,pr1,pr2,m1,m2,m3,v1,v2,v3) {
+ p <- c(pr1,pr2,1-pr1-pr2)
+ y1 <- rnorm(n,m1,v1^0.5)
+ y2 <- rnorm(n,m2,v2^0.5)
+ y3 <- rnorm(n,m3,v3^0.5)
+ z <- stats::rmultinom(n,1,p)
+ rowSums(cbind(y1,y2,y3)*t(z))
+ }
+ structure(f,parname=parname,init=init)
+}
+
+###}}} Gaussian mixture
diff --git a/R/dsep.R b/R/dsep.R
new file mode 100644
index 0000000..3286bb6
--- /dev/null
+++ b/R/dsep.R
@@ -0,0 +1,76 @@
+##' @export
+`dsep` <-
+ function(object,...) UseMethod("dsep")
+
+##' Check d-separation criterion
+##'
+##' Check for conditional independence (d-separation)
+##' @export
+##' @aliases dsep dsep.lvm
+##' @param object lvm object
+##' @param x Variables for which to check for conditional independence
+##' @param cond Conditioning set
+##' @param return.graph If TRUE the moralized ancestral graph with the
+##' conditioning set removed is returned
+##' @param ... Additional arguments to lower level functions
+##' @details The argument 'x' can be given as a formula, e.g. x~y|z+v
+##' or ~x+y|z+v With everything on the rhs of the bar defining the
+##' variables on which to condition on.
+##' @examples
+##' m <- lvm(x5 ~ x4+x3, x4~x3+x1, x3~x2, x2~x1)
+##' if (interactive()) {
+##' plot(m,layoutType='neato')
+##' }
+##' dsep(m,x5~x1|x2+x4)
+##' dsep(m,x5~x1|x3+x4)
+##' dsep(m,~x1+x2+x3|x4)
+##'
+dsep.lvm <- function(object,x,cond=NULL,return.graph=FALSE,...) {
+ if (inherits(x,"formula")) {
+ xf <- getoutcome(x,sep="|")
+ xx <- attr(xf,"x")
+ if (length(xx)==0) stop("Not a valid formula")
+ x <- c(xf,all.vars(xx[[1]]))
+ if (length(xx)>1) {
+ cond <- all.vars(xx[[2]])
+ }
+ }
+ if (inherits(cond,"formula")) {
+ cond <- all.vars(cond)
+ }
+ nod <- vars(object)
+ x <- intersect(x,nod)
+ cond <- intersect(cond,nod)
+ V <- c(x,cond)
+ ## Ancenstral graph
+ keep <- c(V,ancestors(object,V))
+ del <- setdiff(nod,keep)
+ if (length(del)>0) object <- rmvar(object,del)
+ ## moralized graph
+ man <- object
+ for (v in V) {
+ pa <- parents(object,v)
+ if (length(pa)>1)
+ man$M[pa,pa] <- 1
+ ## for (i in seq(length(pa)-1)) {
+ ## for (j in seq(length(pa)-1)+1) {
+ ## man$M[i,j]
+ ## man <- regression(man,from=pa[i],to=pa[j])
+ ## }
+ ## }
+ }
+ man.sel <- rmvar(man,cond)
+ ## with(man.sel, solve(diag(nrow=nrow(M))-M))
+ ii <- match(x,vars(man.sel))
+ A <- with(man.sel, (t(M)+M)>0)
+ dsep <- c()
+ for (i in ii) {
+ conn <- DFS(A,i)
+ i0 <- setdiff(ii,i)
+ dsep <- c(dsep,!any(i0%in%conn))
+ }
+ res <- all(dsep)
+ attr(man.sel,"dsep") <- res
+ if (return.graph) return(man.sel)
+ return(res)
+}
diff --git a/R/effects.R b/R/effects.R
new file mode 100644
index 0000000..a43d059
--- /dev/null
+++ b/R/effects.R
@@ -0,0 +1,228 @@
+
+##' @export
+totaleffects <- function(object,...,value) UseMethod("totaleffects")
+
+##' @export
+totaleffects.lvmfit <- function(object,to,...,level=0.95) {
+ p <- (1-level)/2
+ q <- qnorm(p)
+ res <- c()
+ if (inherits(to,"formula")) {
+ if (substr(deparse(to[3]),1,1)==".") {
+ trim <- function(x) sapply(x,function(z) gsub(" ","",z,fixed=TRUE))
+ to <- trim(strsplit(deparse(to),"~")[[1]][1])
+ } else {
+ to <- list(to)
+ }
+ }
+ if (is.null(list(...)$from) & is.character(to)[1]) {
+ to <- lapply(paste(to,setdiff(vars(object),to),sep="~"),FUN=as.formula)
+ }
+ ef <- function(tt) {
+ f <- effects(object,tt,...)
+ rbind(with(f$totalef,c(est,sd,est/sd,2*(pnorm(abs(est/sd),lower.tail=FALSE)),est+q*sd,est-q*sd)))
+ }
+ if (is.list(to)) {
+ for (tt in to) {
+ res <- rbind(res,ef(tt))
+ }
+ }
+ else
+ res <- ef(to)
+ colnames(res) <- c("Estimate","Std.Err","z value","Pr(>|z|)",
+ paste0(c(1-p,p)*100,"%"))
+ rownames(res) <- to
+ res
+}
+
+##' @export
+effects.lvmfit <- function(object,to,from,silent=FALSE,...) {
+ if (missing(to)) {
+ return(summary(object))
+ }
+ P <- path(object,to=to,from=from,...)
+ if (is.null(P$path)) {
+ if (inherits(to,"formula")) {
+ f <- extractvar(to)
+ to <- f$y; from <- f$x
+ }
+ } else {
+ from <- P$path[[1]][1]
+ to <- tail(P$path[[1]],1)
+ }
+ cc <- coef(object,level=9,labels=FALSE) ## All parameters (fixed and variable)
+ cc0 <- cbind(coef(object)) ## Estimated parameters
+ i1 <- na.omit(match(rownames(cc),rownames(cc0)))
+ idx.cc0 <- which(rownames(cc)%in%rownames(cc0)); ## Position of estimated parameters among all parameters
+ S <- matrix(0,nrow(cc),nrow(cc)); rownames(S) <- colnames(S) <- rownames(cc)
+ V <- object$vcov
+ npar.mean <- index(object)$npar.mean
+## if (object$control$meanstructure & npar.mean>0)
+## V <- V[-seq_len(npar.mean),-seq_len(npar.mean)]
+ S[idx.cc0,idx.cc0] <- V[i1,i1] ## "Covariance matrix" of all parameters
+
+ cclab <- rownames(coef(object,level=9,labels=TRUE)) ## Identify equivalence constraints
+ cctab <- table(cclab)
+ equiv <- which(cctab>1)
+ for (i in seq_len(length(equiv))) {
+ orgpos <- which(cclab==(names(equiv)[i]))
+ pos <- orgpos[-1]
+ for (p in pos)
+ S[p,-orgpos[1]] <- S[-orgpos[1],p] <- S[orgpos[1],-p]
+ }
+
+ idx.orig <- unique(unlist(P$idx))
+ coefs.all <- cc[idx.orig]
+
+ S.all <- S[idx.orig,idx.orig]
+ idx.all <- numberdup(unlist(P$idx))
+ pos <- 1; idx.list <- P$idx; for (i in seq_len(length(idx.list))) {
+ K <- length(idx.list[[i]])
+ idx.list[[i]] <- idx.all[pos:(pos+K-1)]; pos <- pos+K
+ }
+ margef <- list()
+ if (length(coefs.all)==1 && is.na(coefs.all)) {
+ totalef <- list(est=0,sd=0)
+ margef <- c(margef,list(est=0,sd=NA))
+ } else {
+ totalef <- prodsumdelta(coefs.all, idx.list, S.all,...)
+ for (i in seq_len(length(idx.list))) {
+ margef <- c(margef, list(prodsumdelta(coefs.all, idx.list[i], S.all,...)))
+ }
+ paths <- list()
+ }
+
+ directidx <- which(lapply(P$path,length)==2)
+
+ inef.list <- idx.list
+ if (length(directidx)==0) {
+ directef <- list(est=0, sd=NA)
+ } else {
+ inef.list <- inef.list[-directidx]
+ directef <- margef[[directidx]]
+ }
+ if (length(inef.list)==0) {
+ totalinef <- list(est=0,sd=NA,grad=NA,hess=NA)
+ } else {
+ totalinef <- prodsumdelta(coefs.all, inef.list, S.all,...)
+ }
+
+ nn <- c("total","direct","indirect")
+ for (i in seq_len(length(margef))) {
+ if (length(P$path[[i]])>2) {
+ nn <- c(nn,paste(rev(P$path[[i]]),collapse=lava.options()$symbol[1]))
+ }
+ }
+ b <- c(totalef$est,directef$est,totalinef$est,totalinef$b)
+ names(b) <- nn
+ D <- t(cbind(totalef$grad,directef$grad,totalinef$grad,totalinef$D))
+ V <- D%*%S.all%*%t(D)
+ val <- list(coef=b, vcov=V, grad=D, paths=P$path, totalef=totalef, directef=directef, totalinef=totalinef, margef=margef, from=from, to=to)
+ class(val) <- "effects"
+ val
+}
+
+##' @export
+print.effects <- function(x,digits=4,...) {
+ s <- summary(x,...)
+ print(s$coef,digits=digits,...)
+ cat("\n")
+ print(s$medprop$coefmat[,c(1,3,4),drop=FALSE],digits=digits,...)
+ return(invisible(x))
+}
+
+##' @export
+coef.effects <- function(object,...) {
+ object$coef
+}
+
+##' @export
+vcov.effects <- function(object,...) {
+ object$vcov
+}
+
+##' @export
+summary.effects <- function(object,...) {
+ totalef <- with(object$totalef, cbind(est,sd[1]))
+ directef <- with(object$directef, cbind(est,sd[1]))
+ totindirectef <- with(object$totalinef, cbind(est,sd[1]))
+ rownames(totalef) <- "Total"
+ rownames(directef) <- "Direct"
+ rownames(totindirectef) <- "Indirect"
+ nn <- indirectef <- c()
+ K <- seq_len(length(object$margef))
+ for (i in K) {
+ if (length(object$paths[[i]])>2) {
+ nn <- c(nn,paste(rev(object$paths[[i]]),collapse=lava.options()$symbol[1]))
+ indirectef <- rbind(indirectef, with(object$margef[[i]], c(est,sd)))
+ }
+ }; rownames(indirectef) <- nn
+ mycoef <- rbind(totalef,directef,totindirectef,indirectef)
+ mycoef <- cbind(mycoef,mycoef[,1]/mycoef[,2])
+ mycoef <- cbind(mycoef,2*(pnorm(abs(mycoef[,3]),lower.tail=FALSE)))
+ colnames(mycoef) <- c("Estimate","Std.Err","z value","Pr(>|z|)")
+ medprop <- NULL
+ if (totindirectef[1]!=0)
+ medprop <- estimate(object, function(x) list("Mediation proportion"=logit(x[3]/x[1])),back.transform=expit)
+ list(coef=mycoef,medprop=medprop)
+}
+
+
+##' @export
+confint.effects <- function(object,parm,level=0.95,...) {
+ mycoef <- summary(object)$coef
+ p <- 1-(1-level)/2
+ res <- mycoef[,1] + + qnorm(p)*cbind(-1,1)%x%mycoef[,2]
+ colnames(res) <- paste0(c(1-p,p)*100,"%")
+ rownames(res) <- rownames(mycoef)
+ res
+}
+
+
+prodtrans <- function(betas) {
+ k <- length(betas)
+ res <- prod(betas)
+ ## if (all(betas>0)) {
+ ## attr(res,"gradient") <- res/betas
+ ## return(res)
+ ## }
+ nabla <- numeric(k)
+ for (i in seq_len(k))
+ nabla[i] <- prod(betas[-i])
+
+ H <- matrix(0,k,k)
+ if (k>1)
+ for (i in seq_len(k-1))
+ for (j in (i+1):k)
+ H[j,i] <- H[i,j] <- prod(c(1,betas[-c(i,j)]))
+ attr(res,"gradient") <- nabla
+ attr(res,"hessian") <- H
+ return(res)
+}
+prodsumdelta <- function(betas,prodidx,S,order=1) { ## Delta-method
+ k <- length(prodidx)
+ p <- length(betas)
+ if (p==1) {
+ return(list(est=betas, sd=sqrt(S), grad=0, beta=betas, D=0, hess=0))
+ }
+ val <- 0; grad <- numeric(p)
+ D <- matrix(0,nrow=p,ncol=k)
+ beta <- numeric(k)
+ H <- matrix(0,p,p)
+ for (i in seq_len(k)) {
+ ii <- prodidx[[i]]
+ myterm <- prodtrans(betas[ii]);
+ if (order>1) {
+ H0 <- attributes(myterm)$hessian
+ Sigma <- S[ii,ii]
+ print(sum(diag(Sigma%*%H0))/2)
+ val <- val + (myterm + sum(diag(Sigma%*%H0))/2)
+ } else {
+ val <- val + myterm
+ beta[i] <- myterm
+ }
+ D[ii,i] <- attributes(myterm)$gradient
+ grad[ii] <- grad[ii] + attributes(myterm)$gradient
+ }; grad <- matrix(grad,ncol=1)
+ return(list(est=val, sd=sqrt(t(grad)%*%S%*%grad), grad=grad, b=beta, D=D, hess=H))
+}
diff --git a/R/endogenous.R b/R/endogenous.R
new file mode 100644
index 0000000..b403120
--- /dev/null
+++ b/R/endogenous.R
@@ -0,0 +1,51 @@
+##' @export
+`endogenous` <-
+function(x,...) UseMethod("endogenous")
+
+##' @export
+`endogenous.lvmfit` <-
+function(x,...) {
+ endogenous(Model(x),...)
+}
+
+##' @export
+`endogenous.lvm` <-
+function(x,top=FALSE,latent=FALSE,...) {
+ observed <- manifest(x)
+ if (latent) observed <- vars(x)
+ if (top) {
+ M <- x$M
+ res <- c()
+ for (i in observed)
+ if (!any(M[i,]==1))
+ res <- c(res, i)
+ return(res)
+ }
+ exo <- exogenous(x)
+ return(setdiff(observed,exo))
+}
+
+##' @export
+endogenous.list <- function(x,...) {
+ endolist <- c()
+ for (i in seq_along(x)) {
+ ## exolist <- c(exolist, exogenous(x[[i]]))
+ endolist <- c(endolist, endogenous(x[[i]]))
+ }
+ endolist <- unique(endolist)
+ return(endolist)
+## exolist <- unique(exolist)
+## return(exolist[!(exolist%in%endolist)])
+}
+
+##' @export
+`endogenous.multigroup` <-
+function(x,...) {
+ endogenous(Model(x))
+}
+
+##' @export
+`endogenous.lm` <-
+function(x,...) {
+ getoutcome(formula(x))[1]
+}
diff --git a/R/equivalence.R b/R/equivalence.R
new file mode 100644
index 0000000..65f5ebd
--- /dev/null
+++ b/R/equivalence.R
@@ -0,0 +1,140 @@
+##' Identify candidates of equivalent models
+##'
+##' Identifies candidates of equivalent models
+##'
+##'
+##' @param x \code{lvmfit}-object
+##' @param rel Formula or character-vector specifying two variables to omit from
+##' the model and subsequently search for possible equivalent models
+##' @param tol Define two models as empirical equivalent if the absolute
+##' difference in score test is less than \code{tol}
+##' @param k Number of parameters to test simultaneously. For \code{equivalence}
+##' the number of additional associations to be added instead of \code{rel}.
+##' @param omitrel if \code{k} greater than 1, this boolean defines wether to
+##' omit candidates containing \code{rel} from the output
+##' @param \dots Additional arguments to be passed to the low level functions
+##' @author Klaus K. Holst
+##' @seealso \code{\link{compare}}, \code{\link{modelsearch}}
+##' @export
+equivalence <- function(x,rel,tol=1e-3,k=1,omitrel=TRUE,...) {
+ if (missing(rel)) stop("Specify association 'rel' (formula or character vector)")
+ if (inherits(rel,"formula")) {
+ myvars <- all.vars(rel)
+ } else {
+ myvars <- rel
+ }
+ if (length(myvars)!=2) stop("Two variables only")
+ x0 <- Model(x)
+ cancel(x0) <- rel
+ e0 <- estimate(x0,data=model.frame(x),weights=Weights(x),estimator=x$estimator,...)
+ if (k!=1) {
+ p0 <- coef(x)
+ p0[] <- 0
+ p0[match(names(coef(e0)),names(p0))] <- coef(e0)
+ S0 <- score(x,p=p0)[,,drop=TRUE];
+ I0 <- information(x,p=p0)
+ T0 <- rbind(S0)%*%solve(I0)%*%cbind(S0); names(T0) <- "Q"
+ }
+ s <- modelsearch(e0,k=k,...)
+ relname <- c(paste(myvars,collapse=lava.options()$symbol[2]),
+ paste(rev(myvars),collapse=lava.options()$symbol[2]))
+ relidx <- NULL
+ if (k==1) {
+ relidx <- na.omit(match(relname,s$res[,"Index"]))
+ T0 <- s$test[relidx,1]
+ }
+ T <- s$test[,1]
+ Equiv <- setdiff(which(abs(T-T0)<tol),relidx)
+ Improve <- which((T-T0)>tol)
+ if (omitrel) { ## Don't save models including 'rel'
+ keep <- c()
+ if (length(Equiv)>0) {
+ for (i in seq_len(length(Equiv))) {
+ newvars <- s$var[[Equiv[i]]]
+ if (!any(apply(newvars,1,function(z) all(z%in%myvars)))) keep <- c(keep,Equiv[i])
+ }
+ Equiv <- keep
+ }
+ keep <- c()
+ if (length(Improve)>0) {
+ for (i in seq_len(length(Improve))) {
+ newvars <- s$var[[Improve[i]]]
+ if (!any(apply(newvars,1,function(z) all(z%in%myvars)))) keep <- c(keep,Improve[i])
+ }
+ Improve <- keep
+ }
+ }
+ eqvar <- ivar <- NULL
+ models <- list()
+ if (length(Equiv)>0){
+ for (i in seq_len(length(Equiv))) {
+ xnew <- x0
+ newvars <- s$var[[Equiv[i]]]
+ for (j in seq_len(nrow(newvars))) {
+ exo.idx <- which(newvars[j,]%in%index(x0)$exogenous)
+ if (length(exo.idx)>0) {
+ xnew <- regression(xnew,from=newvars[j,exo.idx],to=newvars[j,setdiff(1:2,exo.idx)])
+ } else {
+ covariance(xnew) <- newvars
+ }
+ }
+ models <- c(models,list(xnew))
+ }
+ eqvar <- s$var[Equiv]
+ }
+ if (length(Improve)>0) {
+ for (i in seq_len(length(Improve))) {
+ xnew <- x0
+ newvars <- s$var[[Improve[i]]]
+ for (j in seq_len(nrow(newvars))) {
+ exo.idx <- which(newvars[j,]%in%index(x0)$exogenous)
+ if (length(exo.idx)>0) {
+ xnew <- regression(xnew,from=newvars[j,exo.idx],to=newvars[j,setdiff(1:2,exo.idx)])
+ } else {
+ covariance(xnew) <- newvars
+ }
+ }
+ models <- c(models,list(xnew))
+ }
+ ivar <- s$var[Improve]
+ }
+ res <- list(equiv=eqvar, improve=ivar, scoretest=s, models=models, I=Improve, E=Equiv, T0=T0, vars=myvars)
+ class(res) <- "equivalence"
+ return(res)
+}
+
+##' @export
+print.equivalence <- function(x,...) {
+ cat(" 0)\t ",paste0(x$vars,collapse=lava.options()$symbol[2])," (",formatC(x$T0),")\n")
+ cat("Empirical equivalent models:\n")
+ if (length(x$E)==0)
+ cat("\t none\n")
+ else
+ for (i in seq_len(length(x$E))) {
+ cat(" ",i,")\t ", x$scoretest$res[x$E[i],"Index"],
+ " (",x$scoretest$res[x$E[i],1],")",
+ "\n",sep="")
+ }
+ cat("Candidates for model improvement:\n")
+ if (length(x$I)==0)
+ cat("\t none\n")
+ else
+ for (i in seq_len(length(x$I))) {
+ cat(" ",i,")\t ", x$scoretest$res[x$I[i],"Index"],
+ " (",x$scoretest$res[x$I[i],1],")",
+ "\n",sep="")
+ }
+ invisible(x)
+}
+
+holm <- function(p) {
+ k <- length(p)
+ w <- 1/k
+ ii <- order(p)
+ po <- p[ii]
+ qs <- min(1,po[1]/w)
+ for (i in 2:k) {
+ qs <- c(qs, min(1, max(qs[i-1],po[i]*(1-w*(i-1))/w)))
+ }
+ return(qs)
+}
diff --git a/R/estimate.default.R b/R/estimate.default.R
new file mode 100644
index 0000000..0dce1a7
--- /dev/null
+++ b/R/estimate.default.R
@@ -0,0 +1,759 @@
+##' @export
+estimate <- function(x,...) UseMethod("estimate")
+
+##' @export
+estimate.list <- function(x,...) {
+ if (inherits(x[[1]],"lvm")) return(estimate.lvmlist(x,...))
+ lapply(x,function(x) estimate(x,...))
+}
+
+
+##' Estimation of functional of parameters
+##'
+##' Estimation of functional of parameters.
+##' Wald tests, robust standard errors, cluster robust standard errors,
+##' LRT (when \code{f} is not a function)...
+##' @param x model object (\code{glm}, \code{lvmfit}, ...)
+##' @param f transformation of model parameters and (optionally) data, or contrast matrix (or vector)
+##' @param ... additional arguments to lower level functions
+##' @param data \code{data.frame}
+##' @param id (optional) id-variable corresponding to iid decomposition of model parameters.
+##' @param iddata (optional) id-variable for 'data'
+##' @param stack if TRUE (default) the i.i.d. decomposition is automatically stacked according to 'id'
+##' @param average if TRUE averages are calculated
+##' @param subset (optional) subset of data.frame on which to condition (logical expression or variable name)
+##' @param score.deriv (optional) derivative of mean score function
+##' @param level level of confidence limits
+##' @param iid if TRUE (default) the iid decompositions are also returned (extract with \code{iid} method)
+##' @param type type of small-sample correction
+##' @param keep (optional) index of parameters to keep from final result
+##' @param use (optional) index of parameters to use in calculations
+##' @param contrast (optional) Contrast matrix for final Wald test
+##' @param null (optional) null hypothesis to test
+##' @param vcov (optional) covariance matrix of parameter estimates (e.g. Wald-test)
+##' @param coef (optional) parameter coefficient
+##' @param robust if TRUE robust standard errors are calculated. If
+##' FALSE p-values for linear models are calculated from t-distribution
+##' @param df degrees of freedom (default obtained from 'df.residual')
+##' @param print (optional) print function
+##' @param labels (optional) names of coefficients
+##' @param label.width (optional) max width of labels
+##' @param only.coef if TRUE only the coefficient matrix is return
+##' @param back.transform (optional) transform of parameters and confidence intervals
+##' @param folds (optional) aggregate influence functions (divide and conquer)
+##' @param cluster (obsolete) alias for 'id'.
+##' @param R Number of simulations (simulated p-values)
+##' @param null.sim Mean under the null for simulations
+##' @details
+##'
+##' iid decomposition
+##' \deqn{\sqrt{n}(\widehat{\theta}-\theta) = \sum_{i=1}^n\epsilon_i + o_p(1)}
+##' can be extracted with the \code{iid} method.
+##'
+##' @export
+##' @examples
+##'
+##' ## Simulation from logistic regression model
+##' m <- lvm(y~x+z);
+##' distribution(m,y~x) <- binomial.lvm("logit")
+##' d <- sim(m,1000)
+##' g <- glm(y~z+x,data=d,family=binomial())
+##' g0 <- glm(y~1,data=d,family=binomial())
+##'
+##' ## LRT
+##' estimate(g,g0)
+##'
+##' ## Plain estimates (robust standard errors)
+##' estimate(g)
+##'
+##' ## Testing contrasts
+##' estimate(g,null=0)
+##' estimate(g,rbind(c(1,1,0),c(1,0,2)))
+##' estimate(g,rbind(c(1,1,0),c(1,0,2)),null=c(1,2))
+##' estimate(g,2:3) ## same as cbind(0,1,-1)
+##' estimate(g,as.list(2:3)) ## same as rbind(c(0,1,0),c(0,0,1))
+##' ## Alternative syntax
+##' estimate(g,"z","z"-"x",2*"z"-3*"x")
+##' estimate(g,z,z-x,2*z-3*x)
+##' estimate(g,"?") ## Wilcards
+##' estimate(g,"*Int*","z")
+##' estimate(g,"1","2"-"3",null=c(0,1))
+##' estimate(g,2,3)
+##'
+##' ## Usual (non-robust) confidence intervals
+##' estimate(g,robust=FALSE)
+##'
+##' ## Transformations
+##' estimate(g,function(p) p[1]+p[2])
+##'
+##' ## Multiple parameters
+##' e <- estimate(g,function(p) c(p[1]+p[2],p[1]*p[2]))
+##' e
+##' vcov(e)
+##'
+##' ## Label new parameters
+##' estimate(g,function(p) list("a1"=p[1]+p[2],"b1"=p[1]*p[2]))
+##' ##'
+##' ## Multiple group
+##' m <- lvm(y~x)
+##' m <- baptize(m)
+##' d2 <- d1 <- sim(m,50)
+##' e <- estimate(list(m,m),list(d1,d2))
+##' estimate(e) ## Wrong
+##' estimate(e,id=rep(seq(nrow(d1)),2))
+##' estimate(lm(y~x,d1))
+##'
+##' ## Marginalize
+##' f <- function(p,data)
+##' list(p0=lava:::expit(p["(Intercept)"] + p["z"]*data[,"z"]),
+##' p1=lava:::expit(p["(Intercept)"] + p["x"] + p["z"]*data[,"z"]))
+##' e <- estimate(g, f, average=TRUE)
+##' e
+##' estimate(e,diff)
+##' estimate(e,cbind(1,1))
+##'
+##' ## Clusters and subset (conditional marginal effects)
+##' d$id <- rep(seq(nrow(d)/4),each=4)
+##' estimate(g,function(p,data)
+##' list(p0=lava:::expit(p[1] + p["z"]*data[,"z"])),
+##' subset=d$z>0, id=d$id, average=TRUE)
+##'
+##' ## More examples with clusters:
+##' m <- lvm(c(y1,y2,y3)~u+x)
+##' d <- sim(m,10)
+##' l1 <- glm(y1~x,data=d)
+##' l2 <- glm(y2~x,data=d)
+##' l3 <- glm(y3~x,data=d)
+##'
+##' ## Some random id-numbers
+##' id1 <- c(1,1,4,1,3,1,2,3,4,5)
+##' id2 <- c(1,2,3,4,5,6,7,8,1,1)
+##' id3 <- seq(10)
+##'
+##' ## Un-stacked and stacked i.i.d. decomposition
+##' iid(estimate(l1,id=id1,stack=FALSE))
+##' iid(estimate(l1,id=id1))
+##'
+##' ## Combined i.i.d. decomposition
+##' e1 <- estimate(l1,id=id1)
+##' e2 <- estimate(l2,id=id2)
+##' e3 <- estimate(l3,id=id3)
+##' (a2 <- merge(e1,e2,e3))
+##'
+##' ## If all models were estimated on the same data we could use the
+##' ## syntax:
+##' ## Reduce(merge,estimate(list(l1,l2,l3)))
+##'
+##' ## Same:
+##' iid(a1 <- merge(l1,l2,l3,id=list(id1,id2,id3)))
+##'
+##' iid(merge(l1,l2,l3,id=TRUE)) # one-to-one (same clusters)
+##' iid(merge(l1,l2,l3,id=FALSE)) # independence
+##'
+##'
+##' ## Monte Carlo approach, simple trend test example
+##'
+##' m <- categorical(lvm(),~x,K=5)
+##' regression(m,additive=TRUE) <- y~x
+##' d <- simulate(m,100,seed=1,'y~x'=0.1)
+##' l <- lm(y~-1+factor(x),data=d)
+##'
+##' f <- function(x) coef(lm(x~seq_along(x)))[2]
+##' null <- rep(mean(coef(l)),length(coef(l))) ## just need to make sure we simulate under H0: slope=0
+##' estimate(l,f,R=1e2,null.sim=null)
+##'
+##' estimate(l,f)
+##' @aliases estimate estimate.default estimate.estimate merge.estimate
+##' @method estimate default
+##' @export
+estimate.default <- function(x=NULL,f=NULL,...,data,id,
+ iddata,stack=TRUE,average=FALSE,subset,
+ score.deriv,level=0.95,iid=TRUE,
+ type=c("robust","df","mbn"),
+ keep,use,
+ contrast,null,vcov,coef,
+ robust=TRUE,df=NULL,
+ print=NULL,labels,label.width,
+ only.coef=FALSE,back.transform=NULL,
+ folds=0,
+ cluster,
+ R=0,
+ null.sim) {
+ cl <- match.call(expand.dots=TRUE)
+ if (!missing(use)) {
+ p0 <- c("f","contrast","only.coef","subset","average","keep","labels")
+ cl0 <- cl
+ cl0[c("use",p0)] <- NULL
+ cl0$keep <- use
+ cl$x <- eval(cl0,parent.frame())
+ cl[c("vcov","use")] <- NULL
+ return(eval(cl,parent.frame()))
+ }
+ expr <- suppressWarnings(inherits(try(f,silent=TRUE),"try-error"))
+ if (!missing(coef)) {
+ pp <- coef
+ } else {
+ pp <- suppressWarnings(try(stats::coef(x),"try-error"))
+ if (inherits(x,"survreg") && length(pp)<NROW(x$var)) {
+ pp <- c(pp,scale=x$scale)
+ }
+ }
+ if (!missing(cluster)) id <- cluster
+ if (expr || is.character(f) || (is.numeric(f) && !is.matrix(f))) { ## || is.call(f)) {
+ dots <- lapply(substitute(placeholder(...))[-1],function(x) x)
+ args <- c(list(coef=names(pp),x=substitute(f)),dots)
+ f <- do.call(parsedesign,args)
+ }
+ if (!is.null(f) && !is.function(f)) {
+ if (!(is.matrix(f) | is.vector(f))) return(compare(x,f,...))
+ contrast <- f; f <- NULL
+ }
+
+ if (lava.options()$cluster.index) {
+ if (!requireNamespace("mets",quietly=TRUE)) stop("'mets' package required")
+ }
+
+ if (missing(data)) data <- tryCatch(model.frame(x),error=function(...) NULL)
+ ##if (is.matrix(x) || is.vector(x)) contrast <- x
+ alpha <- 1-level
+ alpha.str <- paste(c(alpha/2,1-alpha/2)*100,"",sep="%")
+ nn <- NULL
+ if (missing(vcov) || is.null(vcov) || (is.logical(vcov) && vcov[1]==FALSE && !is.na(vcov[1]))) { ## If user supplied vcov, then don't estimate IC
+ if (missing(score.deriv)) {
+ if (!is.logical(iid)) {
+ iidtheta <- iid
+ iid <- TRUE
+ } else {
+ suppressWarnings(iidtheta <- iid(x,folds=folds))
+ }
+ } else {
+ suppressWarnings(iidtheta <- iid(x,score.deriv=score.deriv,folds=folds))
+ }
+ } else {
+ if (is.logical(vcov) && !is.na(vcov)[1]) vcov <- stats::vcov(x)
+ iidtheta <- NULL
+ }
+
+ if (!missing(subset)) {
+ e <- substitute(subset)
+ expr <- suppressWarnings(inherits(try(subset,silent=TRUE),"try-error"))
+ if (expr) subset <- eval(e,envir=data)
+ ##subset <- eval(e, data, parent.frame())
+ if (is.character(subset)) subset <- data[,subset]
+ if (is.numeric(subset)) subset <- subset>0
+ }
+ idstack <- NULL
+ ## Preserve id from 'estimate' object
+ if (missing(id) && inherits(x,"estimate") && !is.null(x$id)) id <- x$id
+ if (!missing(id) && iid) {
+ if (is.null(iidtheta)) stop("'iid' method needed")
+ nprev <- nrow(iidtheta)
+ if (inherits(id,"formula")) {
+ id <- interaction(get_all_vars(id,data))
+ }
+ ## e <- substitute(id)
+ ## expr <- suppressWarnings(inherits(try(id,silent=TRUE),"try-error"))
+ ## if (expr) id <- eval(e,envir=data)
+ ##if (!is.null(data)) id <- eval(e, data)
+ if (is.logical(id) && length(id)==1) {
+ id <- if(is.null(iidtheta)) seq(nrow(data)) else seq(nprev)
+ stack <- FALSE
+ }
+ if (is.character(id) && length(id)==1) id <- data[,id,drop=TRUE]
+ if (!is.null(iidtheta)) {
+ if (length(id)!=nprev) {
+ if (!is.null(x$na.action) && (length(id)==length(x$na.action)+nprev)) {
+ warning("Applying na.action")
+ id <- id[-x$na.action]
+ } else stop("Dimensions of i.i.d decomposition and 'id' does not agree")
+ }
+ } else {
+ if (length(id)!=nrow(data)) {
+ if (!is.null(x$na.action) && (length(id)==length(x$na.action)+nrow(data))) {
+ warning("Applying na.action")
+ id <- id[-x$na.action]
+ } else stop("Dimensions of i.i.d decomposition and 'id' does not agree")
+ }
+ }
+ if (stack) {
+ N <- nrow(iidtheta)
+ clidx <- NULL
+ atr <- attributes(iidtheta)
+ atr$dimnames <- NULL
+ atr$dim <- NULL
+ if (!lava.options()$cluster.index) {
+ iidtheta <- matrix(unlist(by(iidtheta,id,colSums)),byrow=TRUE,ncol=ncol(iidtheta))
+ attributes(iidtheta)[names(atr)] <- atr
+ idstack <- sort(unique(id))
+ } else {
+ clidx <- mets::cluster.index(id,mat=iidtheta,return.all=TRUE)
+ iidtheta <- clidx$X
+ attributes(iidtheta)[names(atr)] <- atr
+ idstack <- id[as.vector(clidx$firstclustid)+1]
+ }
+ if (is.null(attributes(iidtheta)$N)) {
+ attributes(iidtheta)$N <- N
+ }
+ } else idstack <- id
+ } else {
+ if (!is.null(data)) idstack <- rownames(data)
+ }
+
+ if (!is.null(iidtheta) && (length(idstack)==nrow(iidtheta))) rownames(iidtheta) <- idstack
+ if (!robust) {
+ if (inherits(x,"lm") && family(x)$family=="gaussian" && is.null(df)) df <- x$df.residual
+ if (missing(vcov)) vcov <- stats::vcov(x)
+ }
+ if (!is.null(iidtheta) && (missing(vcov) || is.null(vcov))) {
+ ## if (is.null(f))
+ V <- crossprod(iidtheta)
+ ### Small-sample corrections for clustered data
+ K <- NROW(iidtheta)
+ N <- attributes(iidtheta)$N
+ if (is.null(N)) N <- K
+ p <- NCOL(iidtheta)
+ adj0 <- K/(K-p) ## Mancl & DeRouen, 2001
+ adj1 <- K/(K-1) ## Mancl & DeRouen, 2001
+ adj2 <- (N-1)/(N-p)*(K/(K-1)) ## Morel,Bokossa & Neerchal, 2003
+ if (tolower(type[1])=="mbn" && !is.null(attributes(iidtheta)$bread)) {
+ V0 <- V
+ iI0 <- attributes(iidtheta)$bread
+ I0 <- Inverse(iI0)
+ I1 <- crossprod(iidtheta%*%I0)
+ delta <- min(0.5,p/(K-p))
+ phi <- max(1,tr(I0%*%V0)*adj2/p)
+ V <- adj2*V0 + delta*phi*iI0
+ }
+ if (tolower(type[1])=="df") {
+ V <- adj0*V
+ }
+ if (tolower(type[1])=="df1") {
+ V <- adj1*V
+ }
+ if (tolower(type[1])=="df2") {
+ V <- adj2*V
+ }
+ } else {
+ if (!missing(vcov)) {
+ if (length(vcov)==1 && is.na(vcov)) vcov <- matrix(NA,length(pp),length(pp))
+ V <- vcov
+ } else {
+ V <- stats::vcov(x)
+ }
+ }
+
+
+ ## Simulate p-value
+ if (R>0) {
+ if (is.null(f)) stop("Supply function 'f'")
+ if (missing(null.sim)) null.sim <- rep(0,length(pp))
+ est <- f(pp)
+ if (is.list(est)) {
+ nn <- names(est)
+ est <- unlist(est)
+ names(est) <- nn
+ }
+ if (missing(labels)) {
+ labels <- colnames(rbind(est))
+ }
+ res <- simnull(R,f,mu=null.sim,sigma=V,labels=labels)
+ return(structure(res, class=c("estimate.sim","sim"),
+ coef=pp,
+ vcov=V,
+ f=f,
+ estimate=est))
+ }
+
+
+ if (!is.null(f)) {
+ form <- names(formals(f))
+ dots <- ("..."%in%names(form))
+ form0 <- setdiff(form,"...")
+ parname <- "p"
+
+ if (!is.null(form)) parname <- form[1] # unless .Primitive
+ if (length(form0)==1 && !(form0%in%c("object","data"))) {
+ ##names(formals(f))[1] <- "p"
+ parname <- form0
+ }
+ if (!is.null(iidtheta)) {
+ arglist <- c(list(object=x,data=data,p=vec(pp)),list(...))
+ names(arglist)[3] <- parname
+ } else {
+ arglist <- c(list(object=x,p=vec(pp)),list(...))
+ names(arglist)[2] <- parname
+ }
+ if (!dots) {
+ arglist <- arglist[intersect(form0,names(arglist))]
+ }
+ newf <- NULL
+ if (length(form)==0) {
+ arglist <- list(vec(pp))
+ ##newf <- function(p,...) do.call("f",list(p,...))
+ newf <- function(...) do.call("f",list(...))
+ val <- do.call("f",arglist)
+ } else {
+ val <- do.call("f",arglist)
+ if (is.list(val)) {
+ nn <- names(val)
+ val <- do.call("cbind",val)
+ ##newf <- function(p,...) do.call("cbind",f(p,...))
+ newf <- function(...) do.call("cbind",f(...))
+ }
+ }
+ k <- NCOL(val)
+ N <- NROW(val)
+ D <- attributes(val)$grad
+ if (is.null(D)) {
+ D <- numDeriv::jacobian(function(p,...) {
+ if (length(form)==0) arglist[[1]] <- p
+ else arglist[[parname]] <- p
+ if (is.null(newf))
+ return(do.call("f",arglist))
+ return(do.call("newf",arglist)) }, pp)
+ }
+ if (is.null(iidtheta)) {
+ pp <- structure(as.vector(val),names=names(val))
+ V <- D%*%V%*%t(D)
+ } else {
+ if (!average || (N<NROW(data))) { ## || NROW(data)==0)) { ## transformation not depending on data
+ pp <- structure(as.vector(val),names=names(val))
+ iidtheta <- iidtheta%*%t(D)
+ ##V <- crossprod(iidtheta)
+ V <- D%*%V%*%t(D)
+ } else {
+ if (k>1) { ## More than one parameter (and depends on data)
+ if (!missing(subset)) { ## Conditional estimate
+ val <- apply(val,2,function(x) x*subset)
+ }
+ D0 <- matrix(nrow=k,ncol=length(pp))
+ for (i in seq_len(k)) {
+ D1 <- D[seq(N)+(i-1)*N,,drop=FALSE]
+ if (!missing(subset)) ## Conditional estimate
+ D1 <- apply(D1,2,function(x) x*subset)
+ D0[i,] <- colMeans(D1)
+ }
+ D <- D0
+ iid2 <- iidtheta%*%t(D)
+ } else { ## Single parameter
+ if (!missing(subset)) { ## Conditional estimate
+ val <- val*subset
+ D <- apply(rbind(D),2,function(x) x*subset)
+ }
+ D <- colMeans(rbind(D))
+ iid2 <- iidtheta%*%D
+ }
+ pp <- vec(colMeans(cbind(val)))
+ iid1 <- (cbind(val)-rbind(pp)%x%cbind(rep(1,N)))/N
+ if (!missing(id)) {
+ if (!lava.options()$cluster.index)
+ iid1 <- matrix(unlist(by(iid1,id,colSums)),byrow=TRUE,ncol=ncol(iid1))
+ else {
+ iid1 <- mets::cluster.index(id,mat=iid1,return.all=FALSE)
+ }
+ }
+ if (!missing(subset)) { ## Conditional estimate
+ phat <- mean(subset)
+ iid3 <- cbind(-1/phat^2 * (subset-phat)/N) ## check
+ if (!missing(id)) {
+ if (!lava.options()$cluster.index) {
+ iid3 <- matrix(unlist(by(iid3,id,colSums)),byrow=TRUE,ncol=ncol(iid3))
+ } else {
+ iid3 <- mets::cluster.index(id,mat=iid3,return.all=FALSE)
+ }
+ }
+ iidtheta <- (iid1+iid2)/phat + rbind(pp)%x%iid3
+ pp <- pp/phat
+ V <- crossprod(iidtheta)
+ } else {
+ if (nrow(iid1)!=nrow(iid2)) {
+ message("Assuming independence between model iid decomposition and new data frame")
+ V <- crossprod(iid1) + crossprod(iid2)
+ } else {
+ iidtheta <- iid1+iid2
+ V <- crossprod(iidtheta)
+ }
+ }
+ }
+ }
+ }
+
+ if (is.null(V)) {
+ res <- cbind(pp,NA,NA,NA,NA)
+ } else {
+ if (length(pp)==1) res <- rbind(c(pp,diag(V)^0.5)) else res <- cbind(pp,diag(V)^0.5)
+ beta0 <- res[,1]
+
+ if (!missing(null) && missing(contrast)) beta0 <- beta0-null
+ if (!is.null(df)) {
+ za <- qt(1-alpha/2,df=df)
+ pval <- 2*pt(abs(res[,1]/res[,2]),df=df,lower.tail=FALSE)
+ } else {
+ za <- qnorm(1-alpha/2)
+ pval <- 2*pnorm(abs(res[,1]/res[,2]),lower.tail=FALSE)
+ }
+ res <- cbind(res,res[,1]-za*res[,2],res[,1]+za*res[,2],pval)
+ }
+ colnames(res) <- c("Estimate","Std.Err",alpha.str,"P-value")
+
+ if (!is.null(nn)) {
+ rownames(res) <- nn
+ } else {
+ nn <- attributes(res)$varnames
+ if (!is.null(nn)) rownames(res) <- nn
+ if (is.null(rownames(res))) rownames(res) <- paste0("p",seq(nrow(res)))
+ }
+
+ coefs <- res[,1,drop=TRUE]; names(coefs) <- rownames(res)
+ res <- structure(list(coef=coefs,coefmat=res,vcov=V, iid=NULL, print=print, id=idstack),class="estimate")
+ if (iid) ## && is.null(back.transform))
+ res$iid <- iidtheta
+
+ if (!missing(contrast) | !missing(null)) {
+ p <- length(res$coef)
+ if (missing(contrast)) contrast <- diag(nrow=p)
+ if (missing(null)) null <- 0
+ if (is.vector(contrast) || is.list(contrast)) {
+ contrast <- contr(contrast, names(res$coef), ...)
+ ## if (length(contrast)==p) contrast <- rbind(contrast)
+ ## else {
+ ## cont <- contrast
+ ## contrast <- diag(nrow=p)[cont,,drop=FALSE]
+ ## }
+ }
+ cc <- compare(res,contrast=contrast,null=null,vcov=V,level=level,df=df)
+ res <- structure(c(res, list(compare=cc)),class="estimate")
+ if (!is.null(df)) {
+ pval <- with(cc,pt(abs(estimate[,1]-null)/estimate[,2],df=df,lower.tail=FALSE)*2)
+ } else {
+ pval <- with(cc,pnorm(abs(estimate[,1]-null)/estimate[,2],lower.tail=FALSE)*2)
+ }
+ res$coefmat <- with(cc, cbind(estimate,pval))
+ colnames(res$coefmat)[5] <- "P-value"
+ rownames(res$coefmat) <- cc$cnames
+ if (!is.null(res$iid)) {
+ res$iid <- res$iid%*%t(contrast)
+ colnames(res$iid) <- cc$cnames
+ }
+ res$compare$estimate <- NULL
+ res$coef <- res$compare$coef
+ res$vcov <- res$compare$vcov
+ }
+
+ if (!is.null(back.transform)) {
+ res$coefmat[,c(1,3,4)] <- do.call(back.transform,list(res$coefmat[,c(1,3,4)]))
+ res$coefmat[,2] <- NA
+ }
+
+ if (!missing(keep) && !is.null(keep)) {
+ if (is.character(keep)) {
+ keep <- match(keep,rownames(res$coefmat))
+ }
+ res$coef <- res$coef[keep]
+ res$coefmat <- res$coefmat[keep,,drop=FALSE]
+ if (!is.null(res$iid)) res$iid <- res$iid[,keep,drop=FALSE]
+ res$vcov <- res$vcov[keep,keep,drop=FALSE]
+ }
+ if (!missing(labels)) {
+ names(res$coef) <- labels
+ if (!is.null(res$iid)) colnames(res$iid) <- labels
+ colnames(res$vcov) <- rownames(res$vcov) <- labels
+ rownames(res$coefmat) <- labels
+ }
+ if (!missing(label.width)) {
+ rownames(res$coefmat) <- make.unique(unlist(lapply(rownames(res$coefmat),
+ function(x) toString(x,width=label.width))))
+ }
+ if (only.coef) return(res$coefmat)
+ res$call <- cl
+ res$back.transform <- back.transform
+ res$n <- nrow(data)
+ res$ncluster <- nrow(res$iid)
+ return(res)
+}
+
+simnull <- function(R,f,mu,sigma,labels=NULL) {
+ X <- rmvn(R,mu=mu,sigma=sigma)
+ est <- f(mu)
+ res <- apply(X,1,f)
+ if (is.list(est)) {
+ nn <- names(est)
+ est <- unlist(est)
+ names(est) <- nn
+ res <- matrix(unlist(res),byrow=TRUE,ncol=length(est))
+ } else {
+ res <- t(rbind(res))
+ }
+ if (is.null(labels)) {
+ labels <- colnames(rbind(est))
+ if (is.null(labels)) labels <- paste0("p",seq_along(est))
+ }
+ colnames(res) <- labels
+ return(res)
+}
+
+##' @export
+estimate.estimate.sim <- function(x,f,R=0,labels,...) {
+ atr <- attributes(x)
+ if (R>0) {
+ if (missing(f)) {
+ val <- simnull(R,f=atr[["f"]],mu=atr[["coef"]],sigma=atr[["vcov"]])
+ res <- rbind(x,val)
+ for (a in setdiff(names(atr),c("dim","dimnames")))
+ attr(res,a) <- atr[[a]]
+ } else {
+ res <- simnull(R,f=f,mu=atr[["coef"]],sigma=atr[["vcov"]])
+ for (a in setdiff(names(atr),c("dim","dimnames","f")))
+ attr(res,a) <- atr[[a]]
+ attr(f,"f") <- f
+ est <- unlist(f(atr[["coef"]]))
+ if (missing(labels)) labels <- colnames(rbind(est))
+ attr(res,"estimate") <- est
+ }
+ if (!missing(labels)) colnames(res) <- labels
+ return(res)
+ }
+ if (missing(f)) {
+ if (!missing(labels)) colnames(res) <- labels
+ return(x)
+ }
+
+ est <- f(atr[["coef"]])
+ res <- apply(x,1,f)
+ if (is.list(est)) {
+ res <- matrix(unlist(res),byrow=TRUE,ncol=length(est))
+ } else {
+ res <- t(rbind(res))
+ }
+ if (missing(labels)) {
+ labels <- colnames(rbind(est))
+ if (is.null(labels)) labels <- paste0("p",seq_along(est))
+ }
+ colnames(res) <- labels
+ for (a in setdiff(names(atr),c("dim","dimnames","f","estimate")))
+ attr(res,a) <- atr[[a]]
+ attr(f,"f") <- f
+ attr(res,"estimate") <- unlist(est)
+ return(res)
+}
+
+
+##' @export
+print.estimate.sim <- function(x,level=.05,...) {
+ quantiles <- c(level/2,1-level/2)
+ est <- attr(x,"estimate")
+ mysummary <- function(x,i) {
+ x <- as.vector(x)
+ res <- c(mean(x,na.rm=TRUE),
+ sd(x,na.rm=TRUE),
+ quantile(x,quantiles,na.rm=TRUE),
+ est[i],
+ mean(abs(x)>abs(est[i]),na.rm=TRUE))
+
+ names(res) <- c("Mean","SD",paste0(quantiles*100,"%"),
+ "Estimate","P-value")
+ res
+ }
+ env <- new.env()
+ assign("est",attr(x,"estimate"),env)
+ environment(mysummary) <- env
+ print(summary(x,fun=mysummary,...))
+}
+
+estimate.glm <- function(x,...) {
+ estimate.default(x,...)
+}
+
+##' @export
+print.estimate <- function(x,level=0,digits=4,width=25,std.error=TRUE,p.value=TRUE,...) {
+ if (!is.null(x$print)) {
+ x$print(x,digits=digits,width=width,...)
+ return(invisible(x))
+ }
+ if (level>0 && !is.null(x$call)) {
+ cat("Call: "); print(x$call)
+ printline(50)
+ }
+ if (level>0) {
+ if (!is.null(x[["n"]]) && !is.null(x[["k"]])) {
+ cat("n = ",x[["n"]],", clusters = ",x[["k"]],"\n\n",sep="")
+ } else {
+ if (!is.null(x[["n"]])) {
+ cat("n = ",x[["n"]],"\n\n",sep="")
+ }
+ if (!is.null(x[["k"]])) {
+ cat("n = ",x[["k"]],"\n\n",sep="")
+ }
+ }
+ }
+
+ cc <- x$coefmat
+ rownames(cc) <- make.unique(unlist(lapply(rownames(cc),
+ function(x) toString(x,width=width))))
+ if (!std.error) cc <- cc[,-2,drop=FALSE]
+ if (!p.value) cc[,-ncol(cc),drop=FALSE]
+
+ print(cc,digits=digits,...)
+ if (!is.null(x$compare)) {
+ cat("\n",x$compare$method[3],"\n")
+ cat(paste(" ",x$compare$method[-(1:3)],collapse="\n"),"\n")
+ if (length(x$compare$method)>4) {
+ out <- character()
+ out <- with(x$compare, c(out, paste(names(statistic), "=", format(round(statistic, 4)))))
+ out <- with(x$compare, c(out, paste(names(parameter), "=", format(round(parameter,3)))))
+ fp <- with(x$compare, format.pval(p.value, digits = digits))
+ out <- c(out, paste("p-value", if (substr(fp, 1L, 1L) == "<") fp else paste("=", fp)))
+ cat(" ",strwrap(paste(out, collapse = ", ")), sep = "\n")
+ }
+ }
+}
+
+##' @export
+vcov.estimate <- function(object,...) {
+ res <- object$vcov
+ nn <- names(coef(object))
+ dimnames(res) <- list(nn,nn)
+ res
+}
+
+##' @export
+coef.estimate <- function(object,mat=FALSE,...) {
+ if (mat) return(object$coefmat)
+ if (lava.options()$messages>0 && !is.null(object$back.transform)) message("Note: estimates on original scale (before 'back.transform')")
+ object$coef
+}
+
+##' @export
+summary.estimate <- function(object,...) {
+ ##object[c("iid","id","print")] <- NULL
+ object <- object[c("coef","coefmat","vcov","call","ncluster")]
+ class(object) <- "summary.estimate"
+ object
+}
+
+##' @export
+coef.summary.estimate <- function(object,...) {
+ object$coefmat
+}
+
+##' @export
+print.summary.estimate <- function(x,...) {
+ print.estimate(x,level=2,...)
+}
+
+##' @export
+iid.estimate <- function(x,...) {
+ if (is.null(x$iid)) return(NULL)
+ dimn <- dimnames(x$iid)
+ if (!is.null(dimn)) {
+ dimn[[2]] <- names(coef(x))
+ } else {
+ dimn <- list(NULL,names(coef(x)))
+ }
+ structure(x$iid,dimnames=dimn)
+}
+
+##' @export
+model.frame.estimate <- function(formula,...) {
+ NULL
+}
diff --git a/R/estimate.lvm.R b/R/estimate.lvm.R
new file mode 100644
index 0000000..9c74da2
--- /dev/null
+++ b/R/estimate.lvm.R
@@ -0,0 +1,883 @@
+###{{{ estimate.lvm
+
+##' Estimation of parameters in a Latent Variable Model (lvm)
+##'
+##' Estimate parameters. MLE, IV or user-defined estimator.
+##'
+##' A list of parameters controlling the estimation and optimization procedures
+##' is parsed via the \code{control} argument. By default Maximum Likelihood is
+##' used assuming multivariate normal distributed measurement errors. A list
+##' with one or more of the following elements is expected:
+##'
+##' \describe{
+##' \item{start:}{Starting value. The order of the parameters can be shown by
+##' calling \code{coef} (with \code{mean=TRUE}) on the \code{lvm}-object or with
+##' \code{plot(..., labels=TRUE)}. Note that this requires a check that it is
+##' actual the model being estimated, as \code{estimate} might add additional
+##' restriction to the model, e.g. through the \code{fix} and \code{exo.fix}
+##' arguments. The \code{lvm}-object of a fitted model can be extracted with the
+##' \code{Model}-function.}
+##'
+##' \item{starterfun:}{Starter-function with syntax
+##' \code{function(lvm, S, mu)}. Three builtin functions are available:
+##' \code{startvalues}, \code{startvalues0}, \code{startvalues1}, ...}
+##'
+##' \item{estimator:}{ String defining which estimator to use (Defaults to
+##' ``\code{gaussian}'')}
+##'
+##' \item{meanstructure}{Logical variable indicating
+##' whether to fit model with meanstructure.}
+##'
+##' \item{method:}{ String pointing to
+##' alternative optimizer (e.g. \code{optim} to use simulated annealing).}
+##'
+##' \item{control:}{ Parameters passed to the optimizer (default
+##' \code{stats::nlminb}).}
+##'
+##' \item{tol:}{ Tolerance of optimization constraints on lower limit of
+##' variance parameters. } }
+##'
+##' @param x \code{lvm}-object
+##' @param data \code{data.frame}
+##' @param estimator String defining the estimator (see details below)
+##' @param control control/optimization parameters (see details below)
+##' @param missing Logical variable indiciating how to treat missing data.
+##' Setting to FALSE leads to complete case analysis. In the other case
+##' likelihood based inference is obtained by integrating out the missing data
+##' under assumption the assumption that data is missing at random (MAR).
+##' @param weights Optional weights to used by the chosen estimator.
+##' @param weightsname Weights names (variable names of the model) in case
+##' \code{weights} was given as a vector of column names of \code{data}
+##' @param data2 Optional additional dataset used by the chosen
+##' estimator.
+##' @param id Vector (or name of column in \code{data}) that identifies
+##' correlated groups of observations in the data leading to variance estimates
+##' based on a sandwich estimator
+##' @param fix Logical variable indicating whether parameter restriction
+##' automatically should be imposed (e.g. intercepts of latent variables set to
+##' 0 and at least one regression parameter of each measurement model fixed to
+##' ensure identifiability.)
+##' @param index For internal use only
+##' @param graph For internal use only
+##' @param silent Logical argument indicating whether information should be
+##' printed during estimation
+##' @param quick If TRUE the parameter estimates are calculated but all
+##' additional information such as standard errors are skipped
+##' @param method Optimization method
+##' @param param set parametrization (see \code{help(lava.options)})
+##' @param cluster Obsolete. Alias for 'id'.
+##' @param p Evaluate model in parameter 'p' (no optimization)
+##' @param ... Additional arguments to be passed to the low level functions
+##' @return A \code{lvmfit}-object.
+##' @author Klaus K. Holst
+##' @seealso estimate.default score, information
+##' @keywords models regression
+##' @export
+##' @method estimate lvm
+##' @examples
+##' dd <- read.table(header=TRUE,
+##' text="x1 x2 x3
+##' 0.0 -0.5 -2.5
+##' -0.5 -2.0 0.0
+##' 1.0 1.5 1.0
+##' 0.0 0.5 0.0
+##' -2.5 -1.5 -1.0")
+##' e <- estimate(lvm(c(x1,x2,x3)~u),dd)
+##'
+##' ## Simulation example
+##' m <- lvm(list(y~v1+v2+v3+v4,c(v1,v2,v3,v4)~x))
+##' covariance(m) <- v1~v2+v3+v4
+##' dd <- sim(m,10000) ## Simulate 10000 observations from model
+##' e <- estimate(m, dd) ## Estimate parameters
+##' e
+##'
+##' ## Using just sufficient statistics
+##' n <- nrow(dd)
+##' e0 <- estimate(m,data=list(S=cov(dd)*(n-1)/n,mu=colMeans(dd),n=n))
+##' rm(dd)
+##'
+##' ## Multiple group analysis
+##' m <- lvm()
+##' regression(m) <- c(y1,y2,y3)~u
+##' regression(m) <- u~x
+##' d1 <- sim(m,100,p=c("u,u"=1,"u~x"=1))
+##' d2 <- sim(m,100,p=c("u,u"=2,"u~x"=-1))
+##'
+##' mm <- baptize(m)
+##' regression(mm,u~x) <- NA
+##' covariance(mm,~u) <- NA
+##' intercept(mm,~u) <- NA
+##' ee <- estimate(list(mm,mm),list(d1,d2))
+##'
+##' ## Missing data
+##' d0 <- makemissing(d1,cols=1:2)
+##' e0 <- estimate(m,d0,missing=TRUE)
+##' e0
+`estimate.lvm` <-
+ function(x, data=parent.frame(),
+ estimator=NULL,
+ control=list(),
+ missing=FALSE,
+ weights, weightsname,
+ data2,
+ id,
+ fix,
+ index=!quick,
+ graph=FALSE,
+ silent=lava.options()$silent,
+ quick=FALSE,
+ method,
+ param,
+ cluster,
+ p,
+ ...) {
+
+ cl <- match.call()
+ if (!base::missing(param)) {
+ oldparam <- lava.options()$param
+ lava.options(param=param)
+ on.exit(lava.options(param=oldparam))
+ }
+ if (!base::missing(method)) {
+ control["method"] <- list(method)
+ }
+
+ Optim <- list(
+ iter.max=lava.options()$iter.max,
+ trace=ifelse(lava.options()$debug,3,0),
+ gamma=lava.options()$gamma,
+ gamma2=1,
+ ngamma=lava.options()$ngamma,
+ backtrack=lava.options()$backtrack,
+ lambda=0.05,
+ abs.tol=1e-9,
+ epsilon=1e-10,
+ delta=1e-10,
+ rel.tol=1e-10,
+ S.tol=1e-5,
+ stabil=FALSE,
+ start=NULL,
+ constrain=lava.options()$constrain,
+ method=NULL,
+ starterfun="startvalues0",
+ information="E",
+ meanstructure=TRUE,
+ sparse=FALSE,
+ tol=lava.options()$tol)
+
+ defopt <- lava.options()[]
+ defopt <- defopt[intersect(names(defopt),names(Optim))]
+ Optim[names(defopt)] <- defopt
+ if (length(control)>0) {
+ Optim[names(control)] <- control
+ }
+
+ if (is.environment(data)) {
+ innames <- intersect(ls(envir=data),vars(x))
+ data <- as.data.frame(lapply(innames,function(x) get(x,envir=data)))
+ names(data) <- innames
+ }
+ if (length(exogenous(x)>0)) {
+ catx <- categorical2dummy(x,data)
+ x <- catx$x; data <- catx$data
+ }
+
+ if (!lava.options()$exogenous) exogenous(x) <- NULL
+
+ redvar <- intersect(intersect(parlabels(x),latent(x)),colnames(data))
+ if (length(redvar)>0)
+ warning(paste("Latent variable exists in dataset",redvar))
+ ## Random-slopes:
+ xfix <- setdiff(colnames(data)[(colnames(data)%in%parlabels(x,exo=TRUE))],latent(x))
+ if (base::missing(fix)) {
+ fix <- ifelse(length(xfix)>0,FALSE,TRUE)
+ }
+ Debug(list("start=",Optim$start))
+
+ if (!base::missing(cluster)) id <- cluster
+
+ ## commented; don't reduce data
+ ## if (!missing & (is.matrix(data) | is.data.frame(data))) {
+ ## includelist <- c(manifest(x),xfix)
+ ## if (!base::missing(weights) && is.character(weights)) includelist <- c(includelist,weights)
+ ## if (!base::missing(data2) && is.character(data2)) includelist <- c(includelist,data2)
+ ## if (!base::missing(id) && is.character(id)) includelist <- c(includelist,id)
+ ## ##data <- na.omit(data[,intersect(colnames(data),includelist),drop=FALSE])
+ ## }
+
+ ## Weights...
+ if (!base::missing(weights)) {
+ if (is.character(weights)) {
+ weights <- data[,weights,drop=FALSE]
+ if (!base::missing(weightsname)) {
+ colnames(weights) <- weightsname
+ } else {
+ yvar <- index(x)$endogenous
+ nw <- seq_len(min(length(yvar),ncol(weights)))
+ colnames(weights)[nw] <- yvar[nw]
+ }
+ }
+ weights <- cbind(weights)
+ } else {
+ weights <- NULL
+ }
+ if (!base::missing(data2)) {
+ if (is.character(data2)) {
+ data2 <- data[,data2]
+ }
+ } else {
+ data2 <- NULL
+ }
+ ## Correlated clusters...
+ if (!base::missing(id)) {
+ if (is.character(id)) {
+ id <- data[,id]
+ }
+ } else {
+ id <- NULL
+ }
+
+ Debug("procdata")
+ val <- try({
+ dd <- procdata.lvm(x,data=data,missing=missing)
+ S <- dd$S; mu <- dd$mu; n <- dd$n
+ var.missing <- setdiff(vars(x),colnames(S))
+ }, silent=TRUE)
+ if (inherits(val,"try-error")) {
+ var.missing <- setdiff(vars(x),colnames(data))
+ S <- NULL; mu <- NULL; n <- nrow(data)
+ }
+ ## Debug(list("n=",n))
+ ## Debug(list("S=",S))
+ ## Debug(list("mu=",mu))
+
+ ## if (fix) {
+ if (length(var.missing)>0) {## Convert to latent:
+ new.lat <- setdiff(var.missing,latent(x))
+ if (length(new.lat)>0)
+ x <- latent(x, new.lat)
+ }
+ ##}
+
+ ## Run hooks (additional lava plugins)
+ myhooks <- gethook()
+ for (f in myhooks) {
+ res <- do.call(f, list(x=x,data=data,weights=weights,data2=data2,estimator=estimator,optim=Optim))
+ if (!is.null(res$x)) x <- res$x
+ if (!is.null(res$data)) data <- res$data
+ if (!is.null(res$weights)) weights <- res$weights
+ if (!is.null(res$data2)) data2 <- res$data2
+ if (!is.null(res$optim)) Optim <- res$optim
+ if (!is.null(res$estimator)) estimator <- res$estimator
+ rm(res)
+ }
+ if (is.null(estimator)) {
+ if (!missing(weights) && !is.null(weights)) {
+ estimator <- "normal"
+ } else estimator <- "gaussian"
+ }
+
+ checkestimator <- function(x,...) {
+ ffname <- paste0(x,c("_objective","_gradient"),".lvm")
+ exists(ffname[1])||exists(ffname[2])
+ }
+ if (!checkestimator(estimator)) { ## Try down/up-case version
+ estimator <- tolower(estimator)
+ if (!checkestimator(estimator)) {
+ estimator <- toupper(estimator)
+ }
+ }
+ ObjectiveFun <- paste0(estimator, "_objective", ".lvm")
+ GradFun <- paste0(estimator, "_gradient", ".lvm")
+ if (!exists(ObjectiveFun) & !exists(GradFun))
+ stop("Unknown estimator.")
+
+
+ Method <- paste0(estimator, "_method", ".lvm")
+ if (!exists(Method)) {
+ Method <- "nlminb1"
+ } else {
+ Method <- get(Method)
+ }
+ NoOptim <- "method"%in%names(control) && is.null(control$method)
+ if (is.null(Optim$method) && !(NoOptim)) {
+ Optim$method <- if (missing && Method!="nlminb0") "nlminb1" else Method
+ }
+
+
+ if (index) {
+ ## Proces data and setup some matrices
+ x <- fixsome(x, measurement.fix=fix, S=S, mu=mu, n=n,debug=!silent)
+ if (!silent)
+ message("Reindexing model...\n")
+ if (length(xfix)>0) {
+ index(x) <- reindex(x,sparse=Optim$sparse,zeroones=TRUE,deriv=TRUE)
+ } else {
+ x <- updatelvm(x,sparse=Optim$sparse,zeroones=TRUE,deriv=TRUE,mean=TRUE)
+ }
+ }
+ if (is.null(estimator) || estimator==FALSE) {
+ return(x)
+ }
+
+ if (length(index(x)$endogenous)==0) stop("No observed outcome variables. Check variable names in model and data.")
+ if (!Optim$meanstructure) {
+ mu <- NULL
+ }
+
+ nparall <- index(x)$npar + ifelse(Optim$meanstructure, index(x)$npar.mean+index(x)$npar.ex,0)
+ ## Get starting values
+ if (!missing(p)) {
+ start <- p
+ Optim$start <- p
+ } else {
+ myparnames <- coef(x,mean=TRUE)
+ paragree <- FALSE
+ paragree.2 <- c()
+ if (!is.null(Optim$start)) {
+ paragree <- myparnames%in%names(Optim$start)
+ paragree.2 <- names(Optim$start)%in%myparnames
+ }
+ if (sum(paragree)>=length(myparnames))
+ Optim$start <- Optim$start[which(paragree.2)]
+
+ if (! (length(Optim$start)==length(myparnames) & sum(paragree)==0))
+ if (is.null(Optim$start) || sum(paragree)<length(myparnames)) {
+ if (is.null(Optim$starterfun) && lava.options()$param!="relative")
+ Optim$starterfun <- startvalues0
+ start <- suppressWarnings(do.call(Optim$starterfun, list(x=x,S=S,mu=mu,debug=lava.options()$debug,silent=silent,data=data,...)))
+ if (!is.null(x$expar) && length(start)<nparall) {
+ ii <- which(index(x)$e1==1)
+ start <- c(start, structure(unlist(x$expar[ii]),names=names(x$expar)[ii]))
+ }
+ ## Debug(list("start=",start))
+ if (length(paragree.2)>0) {
+ start[which(paragree)] <- Optim$start[which(paragree.2)]
+ }
+ Optim$start <- start
+ }
+ }
+
+ ## Missing data
+ if (missing) {
+ return(estimate.MAR(x=x,data=data,fix=fix,control=Optim,debug=lava.options()$debug,silent=silent,estimator=estimator,weights=weights,data2=data2,cluster=id,...))
+ }
+ coefname <- coef(x,mean=Optim$meanstructure,fix=FALSE);
+ names(Optim$start) <- coefname
+
+ ## Non-linear parameter constraints involving observed variables? (e.g. nonlinear regression)
+ constr <- lapply(constrain(x), function(z)(attributes(z)$args))
+ xconstrain <- intersect(unlist(constr), manifest(x))
+ xconstrainM <- TRUE
+ XconstrStdOpt <- TRUE
+ if (length(xconstrain)>0) {
+ constrainM <- names(constr)%in%unlist(x$mean)
+ for (i in seq_len(length(constr))) {
+ if (!constrainM[i]) {
+ if (any(constr[[i]]%in%xconstrain)) {
+ xconstrainM <- FALSE
+ break;
+ }
+ }
+ }
+ if (xconstrainM & ( (is.null(control$method) || Optim$method=="nlminb0") & (lava.options()$test & estimator=="gaussian") ) ) {
+ XconstrStdOpt <- FALSE
+ Optim$method <- "nlminb0"
+ if (is.null(control$constrain)) control$constrain <- TRUE
+ }
+ }
+
+ ## Setup optimization constraints
+ lowmin <- -Inf
+ lower <- rep(lowmin,length(Optim$start))
+ if (length(Optim$constrain)==1 & Optim$constrain)
+ lower[variances(x)+index(x)$npar.mean] <- Optim$tol
+ if (any(Optim$constrain)) {
+ if (length(Optim$constrain)!=length(lower))
+ constrained <- is.finite(lower)
+ else
+ constrained <- Optim$constrain
+ lower[] <- -Inf
+ Optim$constrain <- TRUE
+ constrained <- which(constrained)
+ nn <- names(Optim$start)
+ CS <- Optim$start[constrained]
+ CS[CS<0] <- 0.01
+ Optim$start[constrained] <- log(CS)
+ names(Optim$start) <- nn
+ }
+ ## Fix problems with starting values?
+ Optim$start[is.nan(unlist(Optim$start))] <- 0
+ ## Debug(list("lower=",lower))
+
+ ObjectiveFun <- paste0(estimator, "_objective", ".lvm")
+ GradFun <- paste0(estimator, "_gradient", ".lvm")
+ if (!exists(ObjectiveFun) & !exists(GradFun)) stop("Unknown estimator.")
+
+ InformationFun <- paste0(estimator, "_hessian", ".lvm")
+
+ mymodel <- x
+ myclass <- "lvmfit"
+
+ ## Random slopes?
+ if (length(xfix)>0 | (length(xconstrain)>0 & XconstrStdOpt | !lava.options()$test)) { ## Yes
+ x0 <- x
+
+ if (length(xfix)>0) {
+ myclass <- c("lvmfit.randomslope",myclass)
+ nrow <- length(vars(x))
+ xpos <- lapply(xfix,function(y) which(regfix(x)$labels==y))
+ colpos <- lapply(xpos, function(y) ceiling(y/nrow))
+ rowpos <- lapply(xpos, function(y) (y-1)%%nrow+1)
+ myfix <- list(var=xfix, col=colpos, row=rowpos)
+ x0 <- x
+ for (i in seq_along(myfix$var))
+ for (j in seq_len(length(myfix$col[[i]])))
+ regfix(x0, from=vars(x0)[myfix$row[[i]][j]],
+ to=vars(x0)[myfix$col[[i]][j]]) <-
+ colMeans(data[,myfix$var[[i]],drop=FALSE])
+ x0 <- updatelvm(x0,zeroones=TRUE,deriv=TRUE)
+ x <- x0
+ yvars <- endogenous(x0)
+ ## Alter start-values/constraints:
+ new.par.idx <- which(coef(mymodel,mean=TRUE,fix=FALSE)%in%coef(x0,mean=TRUE,fix=FALSE))
+ if (length(Optim$start)>length(new.par.idx))
+ Optim$start <- Optim$start[new.par.idx]
+ lower <- lower[new.par.idx]
+ if (Optim$constrain) {
+ constrained <- match(constrained,new.par.idx)
+ }
+ }
+ mydata <- as.matrix(data[,manifest(x0)])
+
+ myObj <- function(pp) {
+ if (Optim$constrain) {
+ pp[constrained] <- exp(pp[constrained])
+ }
+ myfun <- function(ii) {
+ if (length(xfix)>0)
+ for (i in seq_along(myfix$var)) {
+ x0$fix[cbind(rowpos[[i]],colpos[[i]])] <- index(x0)$A[cbind(rowpos[[i]],colpos[[i]])] <- data[ii,xfix[i]]
+ }
+ if (is.list(data2)) {
+ res <- do.call(ObjectiveFun, list(x=x0, p=pp, data=mydata[ii,], n=1, weights=weights[ii,], data2=data2[ii,]))
+ } else {
+ res <- do.call(ObjectiveFun, list(x=x0, p=pp, data=mydata[ii,], n=1, weights=weights[ii,], data2=data2))
+ }
+ return(res)
+ }
+ sum(sapply(seq_len(nrow(data)),myfun))
+ }
+
+ myGrad <- function(pp) {
+ if (Optim$constrain) {
+ pp[constrained] <- exp(pp[constrained])
+ }
+ myfun <- function(ii) {
+ if (length(xfix)>0)
+ for (i in seq_along(myfix$var)) {
+ x0$fix[cbind(rowpos[[i]],colpos[[i]])] <- index(x0)$A[cbind(rowpos[[i]],colpos[[i]])] <- data[ii,xfix[i]]
+ }
+ if (is.list(data2)) {
+ rr <- do.call(GradFun, list(x=x0, p=pp, data=mydata[ii,,drop=FALSE], n=1, weights=weights[ii,], data2=data2))
+ } else
+ {
+ rr <- do.call(GradFun, list(x=x0, p=pp, data=mydata[ii,,drop=FALSE], n=1, weights=weights[ii,], data2=data2[ii,]))
+ }
+ return(rr)
+ }
+ ss <- rowSums(rbind(sapply(seq_len(nrow(data)),myfun)))
+ if (Optim$constrain) {
+ ss[constrained] <- ss[constrained]*pp[constrained]
+ }
+ return(ss)
+ }
+
+
+ myInfo <- function(pp) {
+ myfun <- function(ii) {
+ if (length(xfix)>0)
+ for (i in seq_along(myfix$var)) {
+ x0$fix[cbind(rowpos[[i]],colpos[[i]])] <- index(x0)$A[cbind(rowpos[[i]],colpos[[i]])] <- data[ii,xfix[i]]
+ }
+ if (is.list(data2)) {
+ res <- do.call(InformationFun, list(p=pp, obj=myObj, x=x0, data=data[ii,],
+ n=1, weights=weights[ii,], data2=data2))
+ } else {
+ res <- do.call(InformationFun, list(p=pp, obj=myObj, x=x0, data=data[ii,],
+ n=1, weights=weights[ii,], data2=data2[ii,]))
+ }
+ return(res)
+ }
+ L <- lapply(seq_len(nrow(data)),function(x) myfun(x))
+ val <- apply(array(unlist(L),dim=c(length(pp),length(pp),nrow(data))),c(1,2),sum)
+ if (!is.null(attributes(L[[1]])$grad)) {
+ attributes(val)$grad <- colSums (
+ matrix( unlist(lapply(L,function(i) attributes(i)$grad)) , ncol=length(pp), byrow=TRUE)
+ )
+ }
+ return(val)
+ }
+
+##################################################
+ } else { ## No, standard model
+
+ ## Non-linear parameter constraints involving observed variables? (e.g. nonlinear regression)
+ xconstrain <- c()
+ for (i in seq_len(length(constrain(x)))) {
+ z <- constrain(x)[[i]]
+ xx <- intersect(attributes(z)$args,manifest(x))
+ if (length(xx)>0) {
+ warg <- setdiff(attributes(z)$args,xx)
+ wargidx <- which(attributes(z)$args%in%warg)
+ exoidx <- which(attributes(z)$args%in%xx)
+ parname <- names(constrain(x))[i]
+ y <- names(which(unlist(lapply(intercept(x),function(x) x==parname))))
+ el <- list(i,y,parname,xx,exoidx,warg,wargidx,z)
+ names(el) <- c("idx","endo","parname","exo","exoidx","warg","wargidx","func")
+ xconstrain <- c(xconstrain,list(el))
+ }
+ }
+ yconstrain <- unlist(lapply(xconstrain,function(x) x$endo))
+ iconstrain <- unlist(lapply(xconstrain,function(x) x$idx))
+
+ MkOffset <- function(pp,grad=FALSE) {
+ if (length(xconstrain)>0) {
+ Mu <- matrix(0,nrow(data),length(vars(x))); colnames(Mu) <- vars(x)
+ M <- modelVar(x,p=pp,data=data)
+ M$parval <- c(M$parval, x$mean[unlist(lapply(x$mean,is.numeric))])
+ for (i in seq_len(length(xconstrain))) {
+ pp <- unlist(M$parval[xconstrain[[i]]$warg]);
+ myidx <- with(xconstrain[[i]],order(c(wargidx,exoidx)))
+ D <- cbind(rbind(pp)%x%cbind(rep(1,nrow(Mu))),
+ data[,xconstrain[[i]]$exo,drop=FALSE])[,myidx,drop=FALSE]
+ mu <- try(xconstrain[[i]]$func(D),silent=TRUE)
+ if (is.data.frame(mu)) mu <- mu[,1]
+ if (inherits(mu,"try-error") || NROW(mu)!=NROW(Mu)) {
+ ## mu1 <- with(xconstrain[[i]],
+ ## apply(data[,exo,drop=FALSE],1,
+ ## function(x) func(unlist(c(pp,x))[myidx])))
+ mu <- apply(D,1,xconstrain[[i]]$func)
+ }
+ Mu[,xconstrain[[i]]$endo] <- mu
+ }
+ offsets <- Mu%*%t(M$IAi)[,endogenous(x)]
+ return(offsets)
+ }
+ return(NULL)
+ }
+
+ myObj <- function(pp) {
+ if (Optim$constrain) {
+ pp[constrained] <- exp(pp[constrained])
+ }
+ offset <- MkOffset(pp)
+ mu0 <- mu; S0 <- S; x0 <- x
+ if (!is.null(offset)) {
+ x0$constrain[iconstrain] <- NULL
+ data0 <- data[,manifest(x0)]
+ data0[,endogenous(x)] <- data0[,endogenous(x)]-offset
+ pd <- procdata.lvm(x0,data=data0)
+ S0 <- pd$S; mu0 <- pd$mu
+ x0$mean[yconstrain] <- 0
+ }
+ do.call(ObjectiveFun, list(x=x0, p=pp, data=data, S=S0, mu=mu0, n=n, weights=weights
+ ,data2=data2, offset=offset
+ ))
+ }
+
+ myGrad <- function(pp) {
+ if (Optim$constrain)
+ pp[constrained] <- exp(pp[constrained])
+ ## offset <- MkOffset(pp)
+ ## mu0 <- mu; S0 <- S; x0 <- x
+ ## if (!is.null(offset)) {
+ ## x0$constrain[iconstrain] <- NULL
+ ## data0 <- data[,manifest(x0)]
+ ## data0[,endogenous(x)] <- data0[,endogenous(x)]-offset
+ ## pd <- procdata.lvm(x0,data=data0)
+ ## S0 <- pd$S; mu0 <- pd$mu
+ ## }
+ S <- do.call(GradFun, list(x=x, p=pp, data=data, S=S, mu=mu, n=n, weights=weights
+ , data2=data2##, offset=offset
+ ))
+ if (Optim$constrain) {
+ S[constrained] <- S[constrained]*pp[constrained]
+ }
+ if (is.null(mu) & index(x)$npar.mean>0) {
+ return(S[-c(seq_len(index(x)$npar.mean))])
+ }
+ if (length(S)<length(pp)) S <- c(S,rep(0,length(pp)-length(S)))
+
+ return(S)
+ }
+ myInfo <- function(pp) {
+ I <- do.call(InformationFun, list(p=pp,
+ obj=myObj,
+ x=x, data=data,
+ S=S, mu=mu,
+ n=n,
+ weights=weights, data2=data2,
+ type=Optim$information
+ ))
+ if (is.null(mu) && index(x)$npar.mean>0) {
+ return(I[-seq_len(index(x)$npar.mean),-seq_len(index(x)$npar.mean)])
+ }
+ return(I)
+ }
+
+ }
+
+ myHess <- function(pp) {
+ p0 <- pp
+ if (Optim$constrain)
+ pp[constrained] <- exp(pp[constrained])
+ I0 <- myInfo(pp)
+ attributes(I0)$grad <- NULL
+ D <- attributes(I0)$grad
+ if (is.null(D)) {
+ D <- myGrad(p0)
+ attributes(I0)$grad <- D
+ }
+ if (Optim$constrain) {
+ I0[constrained,-constrained] <- apply(I0[constrained,-constrained,drop=FALSE],2,function(x) x*pp[constrained]);
+ I0[-constrained,constrained] <- t(I0[constrained,-constrained])
+ if (sum(constrained)==1) {
+ I0[constrained,constrained] <- I0[constrained,constrained]*outer(pp[constrained],pp[constrained]) - D[constrained]
+ } else {
+ I0[constrained,constrained] <- I0[constrained,constrained]*outer(pp[constrained],pp[constrained]) - diag(D[constrained],ncol=length(constrained))
+ }
+ }
+ return(I0)
+ }
+ if (is.null(tryCatch(get(InformationFun),error = function (x) NULL)))
+ myInfo <- myHess <- NULL
+ if (is.null(tryCatch(get(GradFun),error = function (x) NULL)))
+ myGrad <- NULL
+
+ if (!silent) message("Optimizing objective function...")
+ if (Optim$trace>0 & !silent) message("\n")
+ ## Optimize with lower constraints on the variance-parameters
+ if ((is.data.frame(data) | is.matrix(data)) && nrow(data)==0) stop("No observations")
+ if (!missing(p)) {
+ opt <- list(estimate=p)
+ ## if (!is.null(myGrad))
+ ## opt <- c(opt,list(gradient=myGrad(p)))
+ ## if (!is.null(myObj))
+ ## opt <- c(opt,list(objective=myObj(p)))
+
+ } else {
+ if (!is.null(Optim$method)) {
+ optarg <- list(start=Optim$start, objective=myObj, gradient=myGrad, hessian=myHess, lower=lower, control=Optim, debug=debug)
+ if (length(Optim$method)>1) {
+ Optim$optimx.method <- Optim$method
+ }
+ if (!is.null(Optim$optimx.method)) {
+ Optim$method <- "optimx"
+ }
+ if (Optim$method%in%c("optimx","optim")) {
+ optimcontrolnames <-
+ c("trace",
+ "follow.on",
+ "save.failures",
+ "maximize",
+ "all.methods",
+ "kkt",
+ "kkttol",
+ "kkt2tol",
+ "starttests",
+ "dowarn",
+ "badval",
+ "usenumDeriv",
+ "fnscale",
+ "parscale",
+ "ndeps",
+ "maxit",
+ "abstol",
+ "reltol",
+ #"alpha","beta","gamma",
+ "REPORT",
+ "type",
+ "lmm",
+ "factr",
+ "pgtol")
+ if (!is.null(optarg$control)) {
+ optarg$control[names(optarg$control)%ni%optimcontrolnames] <- NULL
+ }
+ args <- names(formals(get(Optim$method)))
+ names(optarg)[1] <- "par"
+ if (is.null(optarg$upper)) optarg$upper <- Inf
+ if (!is.null(optarg[["objective"]])) names(optarg)[2] <- "fn"
+ if (!is.null(optarg[["gradient"]])) names(optarg)[3] <- "gr"
+ ##if (!is.null(optarg[["hessian"]])) names(optarg)[4] <- "hess"
+ optarg$hessian <- NULL
+ optarg[names(optarg)%ni%args] <- NULL
+ }
+ if (!is.null(Optim$optimx.method)) optarg$method <- Optim$optimx.method
+ opt <- do.call(Optim$method,
+ optarg)
+ if (inherits(opt,"optimx")) {
+ opt0 <- opt
+ opt <- list(par=coef(opt)[1,])
+ }
+ if (is.null(opt$estimate))
+ opt$estimate <- opt$par
+ if (Optim$constrain) {
+ opt$estimate[constrained] <- exp(opt$estimate[constrained])
+ }
+
+ if (XconstrStdOpt & !is.null(myGrad))
+ opt$gradient <- as.vector(myGrad(opt$par))
+ else {
+ opt$gradient <- numDeriv::grad(myObj,opt$par)
+ }
+ } else {
+ if (!NoOptim) {
+ opt <- do.call(ObjectiveFun, list(x=x,data=data,control=control,...))
+ opt$gradient <- rep(0,length(opt$estimate))
+ } else {
+ opt <- list(estimate=Optim$start,
+ gradient=rep(0,length(Optim$start)))
+ }
+ }
+ }
+
+ if (!is.null(opt$convergence)) {
+ if (opt$convergence!=0) warning("Lack of convergence. Increase number of iteration or change starting values.")
+ } else if (!is.null(opt$gradient) && mean(opt$gradient)^2>1e-3) warning("Lack of convergence. Increase number of iteration or change starting values.")
+ if (quick) {
+ return(opt$estimate)
+ }
+ ## Calculate std.err:
+ pp <- rep(NA,length(coefname)); names(pp) <- coefname
+ pp.idx <- NULL
+ if (!is.null(names(opt$estimate))) {
+ pp[names(opt$estimate)] <- opt$estimate
+ pp.idx <- na.omit(match(coefname,names(opt$estimate)))
+ } else {
+ pp[] <- opt$estimate
+ pp.idx <- seq(length(pp))
+ }
+ ## TODO:
+ ## if (length(pp.idx)!=length(pp)) {
+ ## pp <- rep(NA,length(coefname)); names(pp) <- coefname
+ ## pp[] <- opt$estimate
+ ## pp.idx <- seq(length(pp))
+ ## }
+
+ suppressWarnings(mom <- tryCatch(modelVar(x, pp, data=data),error=function(x)NULL))
+ if (NoOptim) {
+ asVar <- matrix(NA,ncol=length(pp),nrow=length(pp))
+ } else {
+
+ if (!silent) message("\nCalculating asymptotic variance...\n")
+ asVarFun <- paste0(estimator, "_variance", ".lvm")
+
+ if (!exists(asVarFun)) {
+ if (is.null(myInfo)) {
+ if (!is.null(myGrad))
+ myInfo <- function(pp)
+ numDeriv::jacobian(myGrad,pp,method=lava.options()$Dmethod)
+ else
+ myInfo <- function(pp)
+ numDeriv::hessian(myObj,pp)
+ }
+ I <- myInfo(opt$estimate)
+ asVar <- tryCatch(Inverse(I),
+ error=function(e) matrix(NA, length(opt$estimate), length(opt$estimate)))
+ } else {
+ asVar <- tryCatch(do.call(asVarFun,
+ list(x=x,p=opt$estimate,data=data,opt=opt)),
+ error=function(e) matrix(NA, length(opt$estimate), length(opt$estimate)))
+ }
+
+ if (any(is.na(asVar))) {
+ warning("Problems with asymptotic variance matrix. Possibly non-singular information matrix!")
+ }
+ if (!is.null(attributes(asVar)$pseudo) && attributes(asVar)$pseudo) {
+ warning("Near-singular covariance matrix, using pseudo-inverse!")
+ }
+ diag(asVar)[diag(asVar)==0] <- NA
+ }
+
+ mycoef <- matrix(NA,nrow=nparall,ncol=4)
+ mycoef[pp.idx,1] <- opt$estimate ## Will be finished during post.hooks
+
+### OBS: v = t(A)%*%v + e
+ res <- list(model=x, call=cl, coef=mycoef,
+ vcov=asVar, mu=mu, S=S, ##A=A, P=P,
+ model0=mymodel, ## Random slope hack
+ estimator=estimator, opt=opt,expar=x$expar,
+ data=list(model.frame=data, S=S, mu=mu,
+ C=mom$C, v=mom$v, n=n,
+ m=length(latent(x)), k=length(index(x)$manifest), data2=data2),
+ weights=weights, data2=data2,
+ cluster=id,
+ pp.idx=pp.idx,
+ graph=NULL, control=Optim)
+
+ class(res) <- myclass
+
+ myhooks <- gethook("post.hooks")
+ for (f in myhooks) {
+ res0 <- do.call(f,list(x=res))
+ if (!is.null(res0))
+ res <- res0
+ }
+
+ if(graph) {
+ res <- edgelabels(res,type="est")
+ }
+
+ return(res)
+ }
+
+###}}} estimate.lvm
+
+###{{{ estimate.formula
+
+##' @export
+estimate.formula <- function(x,data=parent.frame(),pred.norm=c(),unstruct=FALSE,silent=TRUE,id=NULL,distribution=NULL,estimator="gaussian",...) {
+ cl <- match.call()
+ formulaId <- union(Specials(x,c("cluster")),Specials(x,c("id")))
+ formulaSt <- paste0("~.-cluster(",formulaId,")-id(",formulaId,")")
+ if (!is.null(formulaId)) {
+ id <- formulaId
+ x <- update(x,as.formula(formulaSt))
+ }
+ if (!is.null(id))
+ x <- update(x,as.formula(paste(".~.+",id)))
+ varnames <- all.vars(x)
+ mf <- model.frame(x,data)
+ mt <- attr(mf, "terms")
+ yvar <- names(mf)[1]
+ y <- mf[,yvar]
+ opt <- options(na.action="na.pass")
+ mm <- model.matrix(x,data)
+ options(opt)
+ covars <- colnames(mm)
+ covars <- unlist(lapply(covars, function(x) gsub("[^a-zA-Z0-9._]","",x)))
+ colnames(mm) <- covars
+
+ if (attr(terms(x),"intercept")==1) {
+ covars <- covars[-1]
+ it <- c()
+ } else {
+ it <- "0"
+ }
+
+ if (!is.null(id)) covars <- setdiff(covars,id)
+ model <- lvm(toformula(yvar,c(it,covars)),silent=TRUE)
+ if (!is.null(distribution)) {
+ lava::distribution(model,yvar) <- distribution
+ estimator <- "glm"
+ }
+ mydata <- na.omit(as.data.frame(cbind(data.frame(y),mm))); names(mydata)[1] <- yvar
+ exogenous(model) <- setdiff(covars,pred.norm)
+ if (unstruct) {
+ model <- covariance(model,pred.norm,pairwise=TRUE)
+ }
+ estimate(model,mydata,silent=silent,id=id,estimator=estimator,...)
+}
+
+###}}} estimate.formula
diff --git a/R/estimate.multigroup.R b/R/estimate.multigroup.R
new file mode 100644
index 0000000..4b3ad0c
--- /dev/null
+++ b/R/estimate.multigroup.R
@@ -0,0 +1,649 @@
+###{{{ estimate.multigroup
+
+##' @export
+`estimate.multigroup` <- function(x, control=list(),
+ estimator=NULL,
+ weights, weightsname,
+ data2,
+ id=NULL,
+ silent=lava.options()$silent,
+ quick=FALSE,
+ param,
+ cluster,
+ ...) {
+ cl <- match.call()
+ Optim <- list(
+ iter.max=lava.options()$iter.max,
+ trace=ifelse(lava.options()$debug,3,0),
+ gamma=lava.options()$gamma,
+ ngamma=lava.options()$ngamma,
+ backtrace=TRUE,
+ gamma2=1,
+ lambda=0.05,
+ abs.tol=1e-9,
+ epsilon=1e-10,
+ delta=1e-10,
+ S.tol=1e-6,
+ stabil=FALSE,
+ start=NULL,
+ constrain=lava.options()$constrain,
+ method=NULL,
+ starterfun=startvalues0,
+ information="E",
+ meanstructure=TRUE,
+ sparse=FALSE,
+ lbound=1e-9,
+ reindex=FALSE,
+ tol=lava.options()$tol)
+
+
+ if (!missing(param)) {
+ oldparam <- lava.options()$param
+ lava.options(param=param)
+ on.exit(lava.options(param=oldparam))
+ }
+ if (!missing(cluster)) id <- cluster
+
+ defopt <- lava.options()[]
+ defopt <- defopt[intersect(names(defopt),names(Optim))]
+ Optim[names(defopt)] <- defopt
+
+ if (length(control)>0) {
+ Optim[names(control)] <- control
+ }
+
+
+ Debug("Start values...")
+ if (!is.null(Optim$start) & length(Optim$start)==(x$npar+x$npar.mean)) {
+ mystart <- Optim$start
+ } else {
+ if (!silent) cat("Obtaining starting value...")
+ if (is.null(control$starterfun) && lava.options()$param!="relative")
+ Optim$starterfun <- startvalues0
+ mystart <- with(Optim, starter.multigroup(x,meanstructure=meanstructure,starterfun=starterfun,silent=FALSE,fix=FALSE))
+ if (!is.null(Optim$start)) {
+ pname <- names(Optim$start)
+ ppos <- parpos.multigroup(x,p=pname,mean=TRUE)
+ if (any(!is.na(ppos)))
+ mystart[ppos] <- Optim$start[na.omit(match(attributes(ppos)$name,pname))]
+ }
+ if (!silent) cat("\n")
+ }
+ Debug(mystart)
+ Debug("Constraints...")
+ ## Setup optimization constraints
+ lower <- rep(-Inf, x$npar);
+ for (i in seq_len(x$ngroup)) {
+ vpos <- sapply(x$parlist[[i]][variances(x$lvm[[i]],mean=FALSE)], function(y) char2num(substr(y,2,nchar(y))))
+ if (length(vpos)>0)
+ lower[vpos] <- Optim$lbound
+ }
+ if (Optim$meanstructure)
+ lower <- c(rep(-Inf,x$npar.mean), lower)
+ if (any(Optim$constrain)) {
+ if (length(Optim$constrain)!=length(lower))
+ constrained <- is.finite(lower)
+ else
+ constrained <- Optim$constrain
+ constrained <- which(constrained)
+ lower[] <- -Inf
+ Optim$constrain <- TRUE
+ mystart[constrained] <- log(mystart[constrained])
+ }
+
+ if (!missing(weights)) {
+ if (is.character(weights)) {
+ stweights <- weights
+ weights <- list()
+ for (i in seq_along(x$data)) {
+ newweights <- as.matrix(x$data[[i]][,stweights])
+ colnames(newweights) <- index(x$lvm[[i]])$endogenous[seq_len(ncol(newweights))]
+ weights <- c(weights, list(newweights))
+ }
+ }
+ } else {
+ weights <- NULL
+ }
+ if (!missing(data2)) {
+ if (is.character(data2)) {
+ stdata2 <- data2
+ data2 <- list()
+ for (i in seq_along(x$data)) {
+ newdata <- as.matrix(x$data[[i]][,stdata2,drop=FALSE])
+ dropcol <- apply(newdata,2,function(x) any(is.na(x)))
+ newdata <- newdata[,!dropcol,drop=FALSE]
+ colnames(newdata) <- index(x$lvm[[i]])$endogenous[seq_len(ncol(newdata))]
+ data2 <- c(data2, list(newdata))
+ }
+ }
+ } else {
+ data2 <- NULL
+ }
+
+### Run hooks (additional lava plugins)
+ myhooks <- gethook()
+ newweights <- list()
+ newdata2 <- list()
+ newoptim <- newestimator <- NULL
+ for (f in myhooks) {
+ for ( i in seq_len(x$ngroup)) {
+ res <- do.call(f, list(x=x$lvm[[i]],data=x$data[[i]],weights=weights[[i]],data2=data2[[i]],estimator=estimator,optim=Optim))
+ if (!is.null(res$x)) x$lvm[[i]] <- res$x
+ if (!is.null(res$data)) x$data[[i]] <- res$data
+ if (!is.null(res$weights)) newweights <- c(newweights,list(res$weights))
+ if (!is.null(res$data2)) newdata2 <- c(newdata2,list(res$data2))
+ if (!is.null(res$optim)) newoptim <- res$optim
+ if (!is.null(res$estimator)) newestimator <- res$estimator
+ }
+ if (!is.null(newestimator)) estimator <- newestimator
+ if (!is.null(newoptim)) Optim <- newoptim
+ if (!is.null(res$weights))
+ if (!any(unlist(lapply(newweights,is.null)))) {
+ weights <- newweights
+ }
+ if (!is.null(res$data2))
+ if (!any(unlist(lapply(newdata2,is.null)))) {
+ data2 <- newdata2
+ }
+ }
+ if (is.null(estimator)) {
+ if (!missing(weights) && !is.null(weights)) {
+ estimator <- "normal"
+ } else estimator <- "gaussian"
+ }
+
+ checkestimator <- function(x,...) {
+ ffname <- paste0(x,c("_objective","_gradient"),".lvm")
+ exists(ffname[1])||exists(ffname[2])
+ }
+ if (!checkestimator(estimator)) { ## Try down/up-case version
+ estimator <- tolower(estimator)
+ if (!checkestimator(estimator)) {
+ estimator <- toupper(estimator)
+ }
+ }
+
+ Method <- paste0(estimator, "_method", ".lvm")
+ if (!exists(Method))
+ Method <- "nlminb1"
+ else
+ Method <- get(Method)
+ if (is.null(Optim$method)) {
+ Optim$method <- Method
+ }
+
+ ## Check for random slopes
+ xXx <- exogenous(x)
+ Xfix <- FALSE
+ Xconstrain <- FALSE
+ xfix <- list()
+ for (i in seq_len(x$ngroup)) {
+ x0 <- x$lvm[[i]]
+ data0 <- x$data[[i]]
+ xfix0 <- colnames(data0)[(colnames(data0)%in%parlabels(x0,exo=TRUE))]
+ xconstrain0 <- intersect(unlist(lapply(constrain(x0),function(z) attributes(z)$args)),manifest(x0))
+ xfix <- c(xfix, list(xfix0))
+ if (length(xfix0)>0) Xfix<-TRUE ## Yes, random slopes
+ if (length(xconstrain0)>0) Xconstrain <- TRUE ## Yes, nonlinear regression
+ }
+
+ ## Non-linear parameter constraints involving observed variables? (e.g. nonlinear regression)
+ constr <- c()
+ XconstrStdOpt <- TRUE
+ xconstrainM <- TRUE
+ xconstrain <- c()
+ if (Xconstrain)
+ for (i in seq_len(x$ngroup)) {
+ x0 <- x$lvm[[i]]
+ data0 <- x$data[[i]]
+ constr0 <- lapply(constrain(x0), function(z)(attributes(z)$args))
+ xconstrain0 <- intersect(unlist(constr0), manifest(x0))
+ xconstrain <- c(xconstrain, list(xconstrain0))
+ if (length(xconstrain0)>0) {
+ constrainM0 <- names(constr0)%in%unlist(x0$mean)
+ for (i in seq_len(length(constr0))) {
+ if (!constrainM0[i]) {
+ if (xconstrain0%in%constr0[[i]]) {
+ xconstrainM <- FALSE
+ }
+ }
+ }
+ if (xconstrainM & ((is.null(control$method) || Optim$method=="nlminb0") & (lava.options()$test & estimator=="gaussian")) ) {
+ XconstrStdOpt <- FALSE
+ Optim$method <- "nlminb0"
+ if (is.null(control$constrain)) control$constrain <- TRUE
+ }
+ }
+ }
+
+ ## Define objective function and first and second derivatives
+ ObjectiveFun <- paste0(estimator, "_objective", ".lvm")
+ GradFun <- paste0(estimator, "_gradient", ".lvm")
+ if (!exists(ObjectiveFun) & !exists(GradFun)) stop("Unknown estimator.")
+
+ InformationFun <- paste0(estimator, "_hessian", ".lvm")
+
+ parord <- modelPar(x,seq_len(with(x,npar+npar.mean)))$p
+ mymodel <- x
+
+ parkeep <- c()
+ myclass <- c("multigroupfit","lvmfit")
+ myfix <- list()
+
+ if (Xfix | (Xconstrain & XconstrStdOpt | !lava.options()$test)) { ## Model with random slopes:
+#############################################################
+
+ if (Xfix) {
+ myclass <- c(myclass,"lvmfit.randomslope")
+ for (k in seq_len(x$ngroup)) {
+ x1 <- x0 <- x$lvm[[k]]
+ data0 <- x$data[[k]]
+
+ nrow <- length(vars(x0))
+ xpos <- lapply(xfix[[k]],function(y) which(regfix(x0)$labels==y))
+ colpos <- lapply(xpos, function(y) ceiling(y/nrow))
+ rowpos <- lapply(xpos, function(y) (y-1)%%nrow+1)
+ myfix0 <- list(var=xfix[[k]], col=colpos, row=rowpos)
+ myfix <- c(myfix, list(myfix0))
+
+ for (i in seq_along(myfix0$var))
+ for (j in seq_along(myfix0$col[[i]]))
+ regfix(x0,
+ from=vars(x0)[myfix0$row[[i]][j]],to=vars(x0)[myfix0$col[[i]][j]]) <-
+ colMeans(data0[,myfix0$var[[i]],drop=FALSE],na.rm=TRUE)
+ index(x0) <- reindex(x0,zeroones=TRUE,deriv=TRUE)
+ x$lvm[[k]] <- x0
+ yvars <- endogenous(x0)
+ parkeep <- c(parkeep, parord[[k]][coef(x1,mean=TRUE,fix=FALSE)%in%coef(x0,mean=TRUE,fix=FALSE)])
+ }
+ parkeep <- sort(unique(parkeep))
+ ## Alter start-values:
+
+ if (length(mystart)!=length(parkeep))
+ mystart <- mystart[parkeep]
+ lower <- lower[parkeep]
+ x <- multigroup(x$lvm,x$data,fix=FALSE,exo.fix=FALSE)
+ }
+
+ parord <- modelPar(x,seq_along(mystart))$p
+ mydata <- list()
+ for (i in seq_len(x$ngroup)) {
+ mydata <- c(mydata, list(as.matrix(x$data[[i]][,manifest(x$lvm[[i]])])))
+ }
+
+ myObj <- function(theta) {
+ if (Optim$constrain)
+ theta[constrained] <- exp(theta[constrained])
+ pp <- modelPar(x,theta)$p
+ res <- 0
+ for (k in seq_len(x$ngroup)) {
+ x0 <- x$lvm[[k]]
+ data0 <- x$data[[k]]
+ if (Xfix) {
+ xfix0 <- xfix[[k]]
+ myfix0 <- myfix[[k]]
+ }
+ p0 <- pp[[k]]
+ myfun <- function(ii) {
+ if (Xfix)
+ for (i in seq_along(myfix0$var)) {
+ x0$fix[cbind(myfix0$row[[i]],myfix0$col[[i]])] <-
+ index(x0)$A[cbind(myfix0$row[[i]],myfix0$col[[i]])] <-
+ data0[ii,xfix0[i]]
+ }
+ if (is.list(data2[[k]][ii,])) {
+ res <- do.call(ObjectiveFun, list(x=x0, p=p0,
+ data=data0[ii,manifest(x0),drop=FALSE],
+ n=1, S=NULL, weights=weights[[k]][ii,],
+ data2=data2[[k]]))
+
+ } else {
+ res <- do.call(ObjectiveFun, list(x=x0, p=p0,
+ data=data0[ii,manifest(x0),drop=FALSE],
+ n=1, S=NULL, weights=weights[[k]][ii,],
+ data2=data2[[k]][ii,]))
+ }
+ return(res)
+ }
+ res <- res + sum(sapply(seq_len(nrow(mydata[[k]])),myfun))
+ }
+ res
+ }
+
+ myGrad <- function(theta) {
+ if (Optim$constrain) {
+ theta[constrained] <- exp(theta[constrained])
+ }
+ pp <- modelPar(x,theta)$p
+ D0 <- res <- rbind(numeric(length(mystart)))
+ for (k in seq_len(x$ngroup)) {
+ if (Xfix) {
+ myfix0 <- myfix[[k]]
+ }
+ x0 <- x$lvm[[k]]
+ myfun <- function(ii) {
+ if (Xfix)
+ for (i in seq_along(myfix0$var)) {
+ x0$fix[cbind(myfix0$row[[i]],myfix0$col[[i]])] <-
+ index(x0)$A[cbind(myfix0$row[[i]],myfix0$col[[i]])] <-
+ x$data[[k]][ii,xfix[[k]][i]]
+ }
+ if (is.list(data2[[k]][ii,])) {
+
+ } else {
+ val <- do.call(GradFun, list(x=x0, p=pp[[k]],
+ data=mydata[[k]][ii,,drop=FALSE], n=1,
+ S=NULL,
+ weights=weights[[k]][ii,],
+ data2=data2[[k]][ii,]))
+ }
+ return(val)
+ }
+ D <- D0; D[parord[[k]]] <- rowSums(sapply(seq_len(nrow(mydata[[k]])),myfun))
+ res <- res+D
+ }
+ if (Optim$constrain) {
+ res[constrained] <- res[constrained]*theta[constrained]
+ }
+ return(as.vector(res))
+ }
+
+ myInformation <- function(theta) {
+ theta0 <- theta
+ if (Optim$constrain) {
+ theta[constrained] <- exp(theta[constrained])
+ }
+ pp <- modelPar(x,theta)$p
+ I0 <- res <- matrix(0,length(theta),length(theta))
+ grad <- grad0 <- numeric(length(theta))
+ for (k in seq_len(x$ngroup)) {
+ x0 <- x$lvm[[k]]
+ if (Xfix) {
+ myfix0 <- myfix[[k]]
+ }
+ myfun <- function(ii) {
+ if (Xfix)
+ for (i in seq_along(myfix0$var)) {
+ x0$fix[cbind(myfix0$row[[i]],myfix0$col[[i]])] <- index(x0)$A[cbind(myfix0$row[[i]],myfix0$col[[i]])] <-
+ x$data[[k]][ii,xfix[[k]][i]]
+ }
+ I <- I0
+ J <- do.call(InformationFun,
+ list(x=x0, p=pp[[k]],
+ data=mydata[[k]][ii,], n=1,
+ S=NULL,
+ weights=weights[[k]][ii,],
+ data2=data2[[k]][ii,],
+ type=Optim$information
+ )
+ )
+ D <- grad0
+ if (!is.null(attributes(J)$grad)) {
+ D[ parord[[k]] ] <- attributes(J)$grad
+ attributes(I)$grad <- D
+ }
+ I[ parord[[k]], parord[[k]] ] <- J
+ return(I)
+ }
+ L <- lapply(seq_len(nrow(x$data[[k]])),function(x) myfun(x))
+ if (!is.null(attributes(L[[1]])$grad))
+ grad <- grad + rowSums(matrix((unlist(lapply(L,function(x) attributes(x)$grad))),ncol=length(L)))
+ res <- res + apply(array(unlist(L),dim=c(length(theta),length(theta),nrow(x$data[[k]]))),c(1,2),sum)
+ }
+ if (!is.null(attributes(L[[1]])$grad))
+ attributes(res)$grad <- grad
+ return(res)
+ }
+ } else { ## Model without random slopes:
+###########################################################
+
+
+ ## Non-linear parameter constraints involving observed variables? (e.g. nonlinear regression)
+ yconstrain <- c()
+ iconstrain <- c()
+ xconstrain <- c()
+ for (j in seq_len(x$ngroup)) {
+ x0 <- x$lvm[[j]]
+ data0 <- x$data[[j]]
+ xconstrain0 <- c()
+ for (i in seq_len(length(constrain(x0)))) {
+ z <- constrain(x0)[[i]]
+ xx <- intersect(attributes(z)$args,manifest(x0))
+ if (length(xx)>0) {
+ warg <- setdiff(attributes(z)$args,xx)
+ wargidx <- which(attributes(z)$args%in%warg)
+ exoidx <- which(attributes(z)$args%in%xx)
+ parname <- names(constrain(x0))[i]
+ y <- names(which(unlist(lapply(intercept(x0),function(x) x==parname))))
+ el <- list(i,y,parname,xx,exoidx,warg,wargidx,z)
+ names(el) <- c("idx","endo","parname","exo","exoidx","warg","wargidx","func")
+ xconstrain0 <- c(xconstrain0,list(el))
+ }
+ }
+ yconstrain0 <- unlist(lapply(xconstrain0,function(x) x$endo))
+ iconstrain0 <- unlist(lapply(xconstrain0,function(x) x$idx))
+ xconstrain <- c(xconstrain, list(xconstrain0))
+ yconstrain <- c(yconstrain, list(yconstrain0))
+ iconstrain <- c(iconstrain, list(iconstrain0))
+ }
+
+ MkOffset <- function(pp,x,data,xconstrain,grad=FALSE) {
+ if (length(xconstrain)>0) {
+ Mu <- matrix(0,nrow(data),length(vars(x))); colnames(Mu) <- vars(x)
+ M <- modelVar(x,p=pp,data=data)
+ M$parval <- c(M$parval, x$mean[unlist(lapply(x$mean,is.numeric))])
+ for (i in seq_len(length(xconstrain))) {
+ pp <- unlist(M$parval[xconstrain[[i]]$warg]);
+ myidx <- with(xconstrain[[i]],order(c(wargidx,exoidx)))
+ mu <- with(xconstrain[[i]],
+ apply(data[,exo,drop=FALSE],1,
+ function(x) func(
+ unlist(c(pp,x))[myidx])))
+ Mu[,xconstrain[[i]]$endo] <- mu
+ }
+ offsets <- Mu%*%t(M$IAi)[,endogenous(x)]
+ return(offsets)
+ }
+ return(NULL)
+ }
+
+
+ myObj <- function(theta) {
+ theta0 <- theta
+ if (Optim$constrain) {
+ theta[constrained] <- exp(theta[constrained])
+ }
+ pp <- modelPar(x,theta)$p
+ res <- c()
+ for (i in seq_len(x$ngroup)) {
+ offset <- MkOffset(pp[[i]],x$lvm[[i]],x$data[[i]],xconstrain[[i]])
+ x0 <- x$lvm[[i]]
+ data0 <- x$data[[i]][,index(x$lvm[[i]])$manifest,drop=FALSE]
+ S <- x$samplestat[[i]]$S
+ mu <- x$samplestat[[i]]$mu
+ n <- x$samplestat[[i]]$n
+ if (!is.null(offset)) {
+ x0$constrain[iconstrain[[i]]] <- NULL
+ pd <- procdata.lvm(x0,data0[,endogenous(x0),drop=FALSE]-offset)
+ S[endogenous(x0),endogenous(x0)] <- pd$S
+ mu[endogenous(x0)] <- pd$mu
+ n <- pd$n
+ x0$mean[yconstrain[[i]]] <- 0
+ }
+ res <- c(res,
+ do.call(ObjectiveFun, list(x=x0, p=pp[[i]], data=data0, S=S, mu=mu, n=n, weights=weights[[i]], data2=data2[[i]], offset=offset)))
+
+ }
+ sum(res)
+ }
+
+ if (!exists(GradFun)) {
+ myGrad <- NULL
+ } else {
+ myGrad <- function(theta) {
+ theta0 <- theta
+ if (Optim$constrain) {
+ theta[constrained] <- exp(theta[constrained])
+ }
+ pp <- modelPar(x,theta)$p
+ D0 <- res <- rbind(numeric(length(theta)))
+ for (i in seq_len(x$ngroup)) {
+ repval <- with(x$samplestat[[i]],
+ do.call(GradFun, list(x=x$lvm[[i]],p=pp[[i]],
+ data=x$data[[i]][,index(x$lvm[[i]])$manifest,drop=FALSE],
+ S=S,mu=mu,n=n,
+ weights=weights[[i]], data2=data2[[i]])))
+ D <- D0; D[ parord[[i]] ] <- repval
+ res <- res + D
+ }
+ if (Optim$constrain) {
+ res[constrained] <- res[constrained]*theta[constrained]
+ }
+ return(as.vector(res))
+ }
+ }
+
+ myInformation <- function(theta) {
+ theta0 <- theta
+ if (Optim$constrain) {
+ theta[constrained] <- exp(theta[constrained])
+ }
+ pp <- modelPar(x,theta)$p
+ I0 <- res <- matrix(0,length(theta),length(theta))
+ for (i in seq_len(x$ngroup)) {
+ I <- I0;
+ I[ parord[[i]], parord[[i]] ] <- with(x$samplestat[[i]], do.call(InformationFun, list(p=pp[[i]], x=x$lvm[[i]], data=x$data[[i]],
+ S=S, mu=mu, n=n, weights=weights[[i]],
+ data2=data2[[i]],
+ type=Optim$information)))
+ res <- res + I
+ }
+ D <- myGrad(theta0)
+ if (Optim$constrain) {
+ res[constrained,-constrained] <- apply(res[constrained,-constrained,drop=FALSE],2,function(x) x*theta[constrained]);
+ res[-constrained,constrained] <- t(res[constrained,-constrained])
+ if (sum(constrained)==1) {
+ res[constrained,constrained] <- res[constrained,constrained]*outer(theta[constrained],theta[constrained]) - (D[constrained])
+ } else {
+ res[constrained,constrained] <- res[constrained,constrained]*outer(theta[constrained],theta[constrained]) - diag(D[constrained],nrow=length(constrained))
+ }
+ }
+ attributes(res)$grad <- D
+ return(res)
+ }
+ }
+
+##############################################################
+
+
+ if (!exists(InformationFun)) myInformation <- NULL
+ else if (is.null(get(InformationFun))) myInformation <- NULL
+ if (is.null(get(GradFun))) myGrad <- NULL
+
+ if (!silent) cat("Optimizing objective function...\n")
+ if (lava.options()$debug) {
+ print(lower)
+ print(Optim$constrain)
+ print(Optim$method)
+ }
+ opt <- do.call(Optim$method,
+ list(start=mystart, objective=myObj, gradient=myGrad, hessian=myInformation, lower=lower, control=Optim))
+## if (!silent) cat("\n")
+
+ opt$estimate <- opt$par
+ if (Optim$constrain) {
+ opt$estimate[constrained] <- exp(opt$estimate[constrained])
+ }
+ if (quick) return(list(opt=opt,vcov=NA))
+
+ if (is.null(myGrad) | !XconstrStdOpt ) {
+ ## if (!requireNamespace("numDeriv")) {
+ ## opt$gradient <- naiveGrad(myObj, opt$estimate)
+ ## } else {
+ opt$gradient <- numDeriv::grad(myObj, opt$par, method=lava.options()$Dmethod)
+ } else {
+ opt$gradient <- myGrad(opt$estimate)
+ }
+
+ if (!is.null(opt$convergence)) {
+ if (opt$convergence!=0) warning("Lack of convergence. Increase number of iteration or change starting values.")
+ } else if (!is.null(opt$gradient) && mean(opt$gradient)^2>1e-3) warning("Lack of convergence. Increase number of iteration or change starting values.")
+
+ if (!XconstrStdOpt) {
+ myInformation <- function(theta) information(x,p=theta)
+ } else {
+ if (is.null(myInformation)) {
+## if (!requireNamespace("numDeriv")) stop("I do not know how to calculate the asymptotic variance of this estimator.
+## For numerical approximation please install the library 'numDeriv'.")
+ if (!is.null(myGrad) & XconstrStdOpt)
+ myInformation <- function(theta) numDeriv::jacobian(myGrad, theta, method=lava.options()$Dmethod)
+ else {
+ myInformation <- function(theta) numDeriv::hessian(myObj, theta)
+ }
+ }
+}
+ I <- myInformation(opt$estimate)
+ asVar <- tryCatch(Inverse(I),
+ error=function(e) matrix(NA, length(mystart), length(mystart)))
+
+ res <- list(model=x, model0=mymodel, call=cl, opt=opt, meanstructure=Optim$meanstructure,
+ vcov=asVar, estimator=estimator, weights=weights, data2=data2, cluster=id)
+ class(res) <- myclass
+
+ myhooks <- gethook("post.hooks")
+ for (f in myhooks) {
+ res0 <- do.call(f,list(x=res))
+ if (!is.null(res0))
+ res <- res0
+ }
+
+ return(res)
+}
+
+###}}}
+
+###{{{ estimate.list
+
+estimate.lvmlist <-
+function(x, data, silent=lava.options()$silent, fix, missing=FALSE, ...) {
+ if (base::missing(data)) {
+ return(estimate(x[[1]],x[[2]],missing=missing,...))
+ }
+ nm <- length(x)
+ if (nm==1) {
+ return(estimate(x[[1]],data,missing=missing,...))
+ }
+ if (!all(unlist(lapply(x, function(y) inherits(y,"lvm"))))) stop ("Expected a list of 'lvm' objects.")
+ if (is.data.frame(data)) {
+ warning("Only one dataset - going for standard analysis on each submodel.")
+ res <- c()
+ for (i in seq_len(nm)) {
+ res <- c(res, list(estimate(x[[i]],data=data,silent=TRUE,missing=missing, ...)))
+ }
+ return(res)
+ }
+
+ if (nm!=length(data)) stop("Supply dataset for each model")
+
+ Xfix <- FALSE
+ xfix <- list()
+ for (i in seq_along(x)) {
+ data0 <- data[[i]]
+ xfix0 <- colnames(data0)[(colnames(data0)%in%parlabels(x[[i]],exo=TRUE))]
+ xfix <- c(xfix, list(xfix0))
+ if (length(xfix0)>0) { ## Yes, random slopes
+ Xfix<-TRUE
+ }
+ }
+ if (base::missing(fix)) {
+ fix <- ifelse(Xfix,FALSE,TRUE)
+ }
+
+
+ mg <- multigroup(x,data,fix=fix,missing=missing,...)
+ res <- estimate(mg,...)
+
+ return(res)
+}
+
+###}}}
diff --git a/R/eventTime.R b/R/eventTime.R
new file mode 100644
index 0000000..4e28aa1
--- /dev/null
+++ b/R/eventTime.R
@@ -0,0 +1,428 @@
+##' Add an observed event time outcome to a latent variable model.
+##'
+##' For example, if the model 'm' includes latent event time variables
+##' are called 'T1' and 'T2' and 'C' is the end of follow-up (right censored),
+##' then one can specify
+##'
+##' \code{eventTime(object=m,formula=ObsTime~min(T1=a,T2=b,C=0,"ObsEvent"))}
+##'
+##' when data are simulated from the model
+##' one gets 2 new columns:
+##'
+##' - "ObsTime": the smallest of T1, T2 and C
+##' - "ObsEvent": 'a' if T1 is smallest, 'b' if T2 is smallest and '0' if C is smallest
+##'
+##' Note that "ObsEvent" and "ObsTime" are names specified by the user.
+##'
+##' @author Thomas A. Gerds, Klaus K. Holst
+##' @keywords survival models regression
+##' @examples
+##'
+##' # Right censored survival data without covariates
+##' m0 <- lvm()
+##' distribution(m0,"eventtime") <- coxWeibull.lvm(scale=1/100,shape=2)
+##' distribution(m0,"censtime") <- coxExponential.lvm(rate=10)
+##' m0 <- eventTime(m0,time~min(eventtime=1,censtime=0),"status")
+##' sim(m0,10)
+##'
+##' # Alternative specification of the right censored survival outcome
+##' ## eventTime(m,"Status") <- ~min(eventtime=1,censtime=0)
+##'
+##' # Cox regression:
+##' # lava implements two different parametrizations of the same
+##' # Weibull regression model. The first specifies
+##' # the effects of covariates as proportional hazard ratios
+##' # and works as follows:
+##' m <- lvm()
+##' distribution(m,"eventtime") <- coxWeibull.lvm(scale=1/100,shape=2)
+##' distribution(m,"censtime") <- coxWeibull.lvm(scale=1/100,shape=2)
+##' m <- eventTime(m,time~min(eventtime=1,censtime=0),"status")
+##' distribution(m,"sex") <- binomial.lvm(p=0.4)
+##' distribution(m,"sbp") <- normal.lvm(mean=120,sd=20)
+##' regression(m,from="sex",to="eventtime") <- 0.4
+##' regression(m,from="sbp",to="eventtime") <- -0.01
+##' sim(m,6)
+##' # The parameters can be recovered using a Cox regression
+##' # routine or a Weibull regression model. E.g.,
+##' \dontrun{
+##' set.seed(18)
+##' d <- sim(m,1000)
+##' library(survival)
+##' coxph(Surv(time,status)~sex+sbp,data=d)
+##'
+##' sr <- survreg(Surv(time,status)~sex+sbp,data=d)
+##' library(SurvRegCensCov)
+##' ConvertWeibull(sr)
+##'
+##' }
+##'
+##' # The second parametrization is an accelerated failure time
+##' # regression model and uses the function weibull.lvm instead
+##' # of coxWeibull.lvm to specify the event time distributions.
+##' # Here is an example:
+##'
+##' ma <- lvm()
+##' distribution(ma,"eventtime") <- weibull.lvm(scale=3,shape=0.7)
+##' distribution(ma,"censtime") <- weibull.lvm(scale=2,shape=0.7)
+##' ma <- eventTime(ma,time~min(eventtime=1,censtime=0),"status")
+##' distribution(ma,"sex") <- binomial.lvm(p=0.4)
+##' distribution(ma,"sbp") <- normal.lvm(mean=120,sd=20)
+##' regression(ma,from="sex",to="eventtime") <- 0.7
+##' regression(ma,from="sbp",to="eventtime") <- -0.008
+##' set.seed(17)
+##' sim(ma,6)
+##' # The regression coefficients of the AFT model
+##' # can be tranformed into log(hazard ratios):
+##' # coef.coxWeibull = - coef.weibull / shape.weibull
+##' \dontrun{
+##' set.seed(17)
+##' da <- sim(ma,1000)
+##' library(survival)
+##' fa <- coxph(Surv(time,status)~sex+sbp,data=da)
+##' coef(fa)
+##' c(0.7,-0.008)/0.7
+##' }
+##'
+##'
+##' # The Weibull parameters are related as follows:
+##' # shape.coxWeibull = 1/shape.weibull
+##' # scale.coxWeibull = exp(-scale.weibull/shape.weibull)
+##' # scale.AFT = log(scale.coxWeibull) / shape.coxWeibull
+##' # Thus, the following are equivalent parametrizations
+##' # which produce exactly the same random numbers:
+##'
+##' model.aft <- lvm()
+##' distribution(model.aft,"eventtime") <- weibull.lvm(scale=-log(1/100)/2,shape=0.5)
+##' distribution(model.aft,"censtime") <- weibull.lvm(scale=-log(1/100)/2,shape=0.5)
+##' set.seed(17)
+##' sim(model.aft,6)
+##'
+##' model.cox <- lvm()
+##' distribution(model.cox,"eventtime") <- coxWeibull.lvm(scale=1/100,shape=2)
+##' distribution(model.cox,"censtime") <- coxWeibull.lvm(scale=1/100,shape=2)
+##' set.seed(17)
+##' sim(model.cox,6)
+##'
+##' # The minimum of multiple latent times one of them still
+##' # being a censoring time, yield
+##' # right censored competing risks data
+##'
+##' mc <- lvm()
+##' distribution(mc,~X2) <- binomial.lvm()
+##' regression(mc) <- T1~f(X1,-.5)+f(X2,0.3)
+##' regression(mc) <- T2~f(X2,0.6)
+##' distribution(mc,~T1) <- coxWeibull.lvm(scale=1/100)
+##' distribution(mc,~T2) <- coxWeibull.lvm(scale=1/100)
+##' distribution(mc,~C) <- coxWeibull.lvm(scale=1/100)
+##' mc <- eventTime(mc,time~min(T1=1,T2=2,C=0),"event")
+##' sim(mc,6)
+##'
+##'
+##' @export
+##' @aliases eventTime<-
+##' @param object Model object
+##' @param formula Formula (see details)
+##' @param eventName Event names
+##' @param \dots Additional arguments to lower levels functions
+eventTime <- function(object,formula,eventName="status",...) {
+ if (missing(formula)) return(object$attributes$eventHistory)
+ if (inherits(eventName,"formula")) eventName <- all.vars(eventName)
+ ff <- as.character(formula)
+ timeName <- all.vars(update.formula(formula,"~1"))
+ if (length(timeName)==0){
+ timeName <- "observedTime"
+ rhs <- ff[[2]]
+ }else{
+ rhs <- ff[[3]]
+ }
+ ## rhs <- tolower(rhs)
+ latentTimes <- strsplit(rhs,"[(,)]")[[1]]
+ if (latentTimes[1]!="min")
+ stop(paste("Formula ",formula," does not have the required form, ",
+ "e.g. ~min(T1=1,T2=2,C=0), see (examples in) help(eventTime)."))
+ latentTimes <- latentTimes[-1]
+ NT <- length(latentTimes)
+ events <- vector(NT,mode="character")
+ for (lt in seq_len(NT)){
+ tmp <- strsplit(latentTimes[lt],"=")[[1]]
+ stopifnot(length(tmp) %in% c(1,2))
+ if (length(tmp)==1){
+ events[lt] <- as.character(lt)
+ latentTimes[lt] <- tmp
+ }
+ else{
+ events[lt] <- tmp[2]
+ latentTimes[lt] <- tmp[1]
+ }
+ }
+ events <- gsub(" ","",events)
+ eventnum <- char2num(events)
+ if (all(!is.na(eventnum))) {
+ events <- eventnum
+ } else {
+ events <- gsub("\"","",events)
+ }
+
+ addvar(object) <- timeName
+ ##distribution(object,timeName) <- NA
+ ##m <- regression(m,formula(paste0("~",timeName)))
+ ##if (missing(eventName)) eventName <- "Event"
+ eventTime <- list(names=c(timeName,eventName),
+ latentTimes=gsub(" ","",latentTimes),
+ events=events
+ )
+
+ transform(object,
+ y=eventTime$names,
+ x=eventTime$latentTimes) <-
+ function(z) {
+ idx <- apply(z,1,which.min)
+ cbind(z[cbind(seq(NROW(z)),idx)],
+ eventTime$events[idx])
+ }
+
+ if (is.null(object$attributes$eventHistory)) {
+ object$attributes$eventHistory <- list(eventTime)
+ names(object$attributes$eventHistory) <- timeName
+ } else {
+ object$attributes$eventHistory[[timeName]] <- eventTime
+ }
+ return(object)
+}
+
+##' @export
+"eventTime<-" <- function(object,...,value) {
+ eventTime(object,value,...)
+}
+
+## addhook("color.eventHistory","color.hooks")
+## color.eventHistory <- function(x,subset=vars(x),...) {
+## return(list(vars=intersect(subset,binary(x)),col="indianred1"))
+## }
+
+addhook("plothook.eventHistory","plot.post.hooks")
+plothook.eventHistory <- function(x,...) {
+ eh <- x$attributes$eventHistory
+ ehnames <- unlist(lapply(eh,function(x) x$names))
+ for (f in eh) {
+ x <- regression(x,to=f$names[1],from=f$latentTimes)
+ latent(x) <- f$latentTimes
+ kill(x) <- f$names[2]
+ }
+ timedep <- x$attributes$timedep
+ for (i in seq_len(length(timedep))) {
+ x <- regression(x,to=names(timedep)[i],from=timedep[[i]])
+ }
+ return(x)
+}
+
+addhook("colorhook.eventHistory","color.hooks")
+colorhook.eventHistory <- function(x,subset=vars(x),...) {
+ return(list(vars=intersect(subset,unlist(x$attributes$timedep)),col="lightblue4"))
+}
+
+addhook("print.eventHistory","print.hooks")
+print.eventHistory <- function(x,...) {
+ eh <- x$attributes$eventHistory
+ timedep <- x$attributes$timedep
+ if (is.null(eh) & is.null(timedep)) return(NULL)
+ ehnames <- unlist(lapply(eh,function(x) x$names))
+ cat("Event History Model\n")
+ ff <- formula(x,char=TRUE,all=TRUE)
+ R <- c()
+ for (f in ff) {
+ oneline <- as.character(f);
+ y <- gsub(" ","",strsplit(f,"~")[[1]][1])
+ if (!(y %in% ehnames)) {
+ col1 <- as.character(oneline)
+ D <- attributes(distribution(x)[[y]])$family
+ col2 <- "Normal"
+ if (!is.null(D$family)) col2 <- paste0(D$family)
+ if (!is.null(D$link)) col2 <- paste0(col2,"(",D$link,")")
+ if (!is.null(D$par)) col2 <- paste0(col2,"(",paste(D$par,collapse=","),")")
+ R <- rbind(R,c(col1," ",col2))
+ }
+ }
+ for (y in names(eh)) {
+ col1 <- paste0(y, " = min(",paste(eh[[y]]$latentTimes,collapse=","),")")
+ eh[[y]]$names[2]
+ col2 <- paste0(eh[[y]]$names[2], " := {",paste(eh[[y]]$events,collapse=","),"}")
+ R <- rbind(R,c(col1,"",col2))
+ }
+ rownames(R) <- rep("",nrow(R)); colnames(R) <- rep("",ncol(R))
+ print(R,quote=FALSE,...)
+ cat("\n")
+ for (i in seq_len(length(timedep))) {
+ cat("Time-dependent covariates:\n\n")
+ cat(paste("",names(timedep)[i],"~", paste(timedep[[i]],collapse="+")),"\n")
+ }
+ TRUE
+}
+
+## addhook("simulate.eventHistory","sim.hooks")
+
+## simulate.eventHistory <- function(x,data,...){
+## if (is.null(eventTime(x))) {
+## return(data)
+## }
+## else{
+## for (eh in eventTime(x)) {
+## if (any((found <- match(eh$latentTimes,names(data),nomatch=0))==0)){
+## warning("Cannot find latent time variable: ",
+## eh$latentTimes[found==0],".")
+## }
+## else{
+## for (v in seq_along(eh$latentTimes)) {
+## if (v==1){ ## initialize with the first latent time and event
+## eh.time <- data[,eh$latentTimes[v]]
+## eh.event <- rep(eh$events[v],NROW(data))
+## } else{ ## now replace if next time is smaller
+## ## in case of tie keep the first event
+## eh.event[data[,eh$latentTimes[v]]<eh.time] <- eh$events[v]
+## eh.time <- pmin(eh.time,data[,eh$latentTimes[v]])
+## }
+## }
+## }
+## data[,eh$names[1]] <- eh.time
+## data[,eh$names[2]] <- eh.event
+## }
+## return(data)
+## }
+## }
+
+
+
+##' @export
+coxWeibull.lvm <- function(scale=1/100,shape=2) {
+ ## proportional hazard (Cox) parametrization.
+ ##
+ ## Here we parametrize the Weibull distribution
+ ## (without covariates) as
+ ##
+ ## hazard(t) = scale * shape * t^(shape-1)
+ ##
+ ## The linear predictor (LP) enters like this
+ ##
+ ## hazard(t) = = scale * exp(LP) * shape * t^(shape-1)
+ ##
+ ## Thus, we simulate
+ ##
+ ## T = (scale^{-1} * exp(-LP) * -log(U))^{shape-1})
+ ##
+ ## The hazard is:
+ ## - rising if shape > 1
+ ## - declining if shape <1
+ ## - constant if shape=1
+ ##
+ ## scale = exp(b0 + b1*X)
+ f <- function(n,mu,Scale=scale,Shape=shape,...) {
+ (- log(runif(n)) / (Scale * exp(mu)))^(1/Shape)
+ }
+ ff <- formals(f)
+ expr <- "(- log(runif(n)) / (Scale * exp(mu)))^{1/Shape}"
+ if (inherits(scale,"formula")) scale <- all.vars(scale)[1]
+ if (is.character(scale)) {
+ names(ff)[3] <- scale
+ expr <- gsub("Scale",scale,expr)
+ }
+ if (inherits(shape,"formula")) shape <- all.vars(shape)[1]
+ if (is.character(shape)) {
+ names(ff)[4] <- shape
+ expr <- gsub("Shape",shape,expr)
+ }
+ formals(f) <- ff
+ e <- parse(text=expr)
+ body(f) <- as.call(c(as.name("{"), e))
+ attr(f,"family") <- list(family="weibull",
+ regression="PH",
+ par=c(shape=shape,scale=scale))
+ return(f)
+}
+
+
+##' @export
+coxExponential.lvm <- function(scale=1,rate,timecut){
+ if (missing(rate)) rate=1/scale
+ if (missing(scale)) scale=1/rate
+ if (missing(timecut)) {
+ return(coxWeibull.lvm(shape=1,scale))
+ }
+ if (NROW(rate)>length(timecut))
+ stop("Number of time-intervals (cuts) does not agree with number of rate parameters (beta0)")
+ par <- paste(timecut,rate,sep=":")
+ if (is.matrix(rate)) par <- "..."
+ timecut <- c(timecut,Inf)
+ f <- function(n,mu,...) {
+ Ai <- function() {
+ vals <- matrix(0,ncol=length(timecut)-1,nrow=n)
+ ival <- numeric(n)
+ if (is.matrix(rate)) {
+ mu <- cbind(mu[,1],cbind(1,as.matrix(mu[,-1]))%*%t(rate))
+ rate <- rep(1,length(timecut)-1)
+ }
+ for (i in seq(length(timecut)-1)) {
+ u <- -log(runif(n)) ##rexp(n,1)
+ if (NCOL(mu)>1) {
+ vals[,i] <- timecut[i] + u*exp(-mu[,1]-mu[,i+1])/(rate[i])
+ } else {
+ vals[,i] <- timecut[i] + u*exp(-mu)/(rate[i])
+ }
+ idx <- which(vals[,i]<=timecut[i+1] & ival==0)
+ ival[idx] <- vals[idx,i]
+ }
+ ival
+ }
+ Ai()
+ }
+ attributes(f)$family <- list(family="CoxExponential",par=par)
+ return(f)
+}
+
+##' @export
+aalenExponential.lvm <- function(scale=1,rate,timecut=0){
+ if (missing(rate)) rate=1/scale
+ if (missing(scale)) scale=1/rate
+ if (missing(timecut)==1) {
+ return(coxWeibull.lvm(shape=1,scale))
+ }
+
+ if (length(rate)>length(timecut))
+ stop("Number of time-intervals (cuts) does not agree with number of rate parameters (beta0)")
+ par <- paste(timecut,rate,sep=":")
+ if (is.matrix(rate)) par <- "..."
+ timecut <- c(timecut,Inf)
+ f <- function(n,mu,...) {
+ Ai <- function() {
+ vals <- matrix(0,ncol=length(timecut)-1,nrow=n)
+ ival <- numeric(n)
+ if (is.matrix(rate)) {
+ mu <- cbind(mu[,1],cbind(1,as.matrix(mu[,-1]))%*%t(rate))
+ rate <- rep(1,length(timecut)-1)
+ }
+ for (i in seq(length(timecut)-1)) {
+ u <- -log(runif(n)) ##rexp(n,1)
+ if (NCOL(mu)>1) {
+ vals[,i] <- timecut[i] + u/(rate[i]+mu[,1]+mu[,i+1])
+ } else {
+ vals[,i] <- timecut[i] + u/(rate[i]+mu)
+ }
+ idx <- which(vals[,i]<=timecut[i+1] & ival==0)
+ ival[idx] <- vals[idx,i]
+ }
+ ival
+ }
+ Ai()
+ }
+ attributes(f)$family <- list(family="aalenExponential",par=par)
+ return(f)
+}
+
+
+##' @export
+coxGompertz.lvm <- function(shape=1,scale) {
+ f <- function(n,mu,var,...) {
+ (1/shape) * log(1 - (shape/scale) * (log(runif(n)) * exp(-mu)))
+ }
+ attr(f,"family") <- list(family="gompertz",par=c(shape,scale))
+ return(f)
+}
diff --git a/R/exogenous.R b/R/exogenous.R
new file mode 100644
index 0000000..3718f14
--- /dev/null
+++ b/R/exogenous.R
@@ -0,0 +1,91 @@
+##' @export
+`exogenous` <-
+function(x,...) UseMethod("exogenous")
+
+##' @export
+"exogenous<-" <- function(x,...,value) UseMethod("exogenous<-")
+
+##' @export
+`exogenous<-.lvm` <- function(x,silent=FALSE,
+ xfree=TRUE,
+ ...,value) {
+ if (inherits(value,"formula")) {
+ exogenous(x,...) <- all.vars(value)
+ return(x)
+ }
+ not.in <- !(value%in%vars(x))
+ if (any(not.in)) {
+ addvar(x,reindex=FALSE) <- value[not.in]
+ }
+ xorg <- exogenous(x)
+ x$exogenous <- value
+ if (!is.null(value) & xfree) {
+ notexo.idx <- xorg[which(!(xorg%in%value))]
+ if (length(notexo.idx)>0) { ## & mom) {
+ if (length(notexo.idx)>1) {
+ covariance(x,notexo.idx,pairwise=TRUE,exo=TRUE) <- NA
+ }
+ covariance(x,notexo.idx,vars(x),exo=TRUE) <- NA
+ intercept(x,notexo.idx) <- x$mean[notexo.idx]
+ }
+ }
+## x$exogenous <- value
+ index(x) <- reindex(x)
+ return(x)
+}
+
+##' @export
+`exogenous.lvm` <-
+function(x,latent=FALSE,index=TRUE,...) {
+ if (!index) {
+ if (latent) {
+ allvars <- vars(x)
+ } else {
+ allvars <- manifest(x)
+ }
+ M <- x$M
+ res <- c()
+ for (i in allvars)
+ if (!any(M[,i]==1) & !any(is.na(x$cov[i,]))) # & any(M[i,]==1))
+ res <- c(res, i)
+ return(res)
+ }
+ if (is.null(x$exogenous)) return(x$exogenous)
+ if (all(!is.na(x$exogenous)) & !latent) {
+ return(x$exogenous[x$exogenous%in%index(x)$manifest])
+ }
+ if (!latent)
+ return(index(x)$exogenous)
+ return(exogenous(x,latent=latent,index=FALSE,...))
+}
+
+##' @export
+`exogenous.lvmfit` <-
+function(x,...) {
+ exogenous(Model(x),...)
+}
+
+##' @export
+exogenous.list <- function(x,...) {
+ exolist <- c()
+ endolist <- c()
+ for (i in seq_along(x)) {
+ exolist <- c(exolist, exogenous(x[[i]]))
+ endolist <- c(endolist, endogenous(x[[i]]))
+ }
+ endolist <- unique(endolist)
+ exolist <- unique(exolist)
+ return(exolist[!(exolist%in%endolist)])
+}
+
+##' @export
+`exogenous.multigroup` <-
+function(x,...) {
+ exogenous(Model(x))
+}
+
+##' @export
+`exogenous.lm` <-
+function(x,...) {
+ attr(getoutcome(formula(x)),"x")
+}
diff --git a/R/finalize.R b/R/finalize.R
new file mode 100644
index 0000000..e079234
--- /dev/null
+++ b/R/finalize.R
@@ -0,0 +1,211 @@
+##' @export
+`finalize` <-
+function(x,...) UseMethod("finalize")
+
+##' @export
+`finalize.lvm` <-
+function(x, diag=FALSE, cor=FALSE, addcolor=TRUE, intercept=FALSE, plain=FALSE, cex, fontsize1=10, cols=lava.options()$node.color, unexpr=FALSE, addstyle=TRUE, ...) {
+
+ g <- as(new("graphAM",adjMat=x$M,"directed"),"graphNEL")
+ graph::nodeRenderInfo(g)$fill <- NA
+ graph::nodeRenderInfo(g)$label <- NA
+ graph::nodeRenderInfo(g)$label[vars(x)] <- vars(x)
+ graph::nodeRenderInfo(g)$shape <- x$graphdef$shape
+
+ Lab <- NULL
+ for (i in seq_len(length(x$noderender))) {
+ nn <- unlist(x$noderender[[i]])
+ if (length(nn)>0) {
+ R <- list(as.list(x$noderender[[i]])); names(R) <- names(x$noderender)[i]
+ if (names(x$noderender)[i]!="label")
+ graph::nodeRenderInfo(g) <- x$noderender[i]
+ else Lab <- R[[1]]
+ }
+ }
+
+ if (!is.null(Lab)) { ## Ugly hack to allow mathematical annotation
+ nn <- names(graph::nodeRenderInfo(g)$label)
+ LL <- as.list(graph::nodeRenderInfo(g)$label)
+ LL[names(Lab)] <- Lab
+ if (any(unlist(lapply(LL,function(x) is.expression(x) || is.name(x) || is.call(x))))) {
+ graph::nodeRenderInfo(g) <- list(label=as.expression(LL))
+ } else graph::nodeRenderInfo(g) <- list(label=LL)
+ names(graph::nodeRenderInfo(g)$label) <- nn
+ ii <- which(names(graph::nodeRenderInfo(g)$label)=="")
+ if (length(ii)>0)
+ graph::nodeRenderInfo(g)$label <- graph::nodeRenderInfo(g)$label[-ii]
+ }
+
+ graph::edgeDataDefaults(g)$futureinfo <- x$edgerender$futureinfo
+ graph::edgeRenderInfo(g)$lty <- x$graphdef$lty
+ graph::edgeRenderInfo(g)$lwd <- x$graphdef$lty
+ graph::edgeRenderInfo(g)$col <- x$graphdef$col
+ graph::edgeRenderInfo(g)$textCol <- x$graphdef$textCol
+ graph::edgeRenderInfo(g)$arrowhead <- x$graphdef$arrowhead
+ graph::edgeRenderInfo(g)$dir <- x$graphdef$dir
+ graph::edgeRenderInfo(g)$arrowtail <- "none"
+ graph::edgeRenderInfo(g)$cex <- x$graphdef$cex
+ graph::edgeRenderInfo(g)$label <- x$graphdef$label
+ for (i in seq_len(length(x$edgerender))) {
+ ee <- x$edgerender[[i]]
+ if (length(ee)>0 && names(x$edgerender)[i]!="futureinfo") {
+ graph::edgeRenderInfo(g)[names(x$edgerender)[i]][names(ee)] <- ee
+ }
+ }
+
+ opt <- options(warn=-1)
+ var <- rownames(covariance(x)$rel)
+
+
+ if (unexpr) {
+ mylab <- as.character(graph::edgeRenderInfo(g)$label); names(mylab) <- names(graph::edgeRenderInfo(g)$label)
+ g at renderInfo@edges$label <- as.list(mylab)
+ }
+
+
+ if (intercept) {
+ ## mu <- intfix(x)
+ ## nNA <- sum(is.na(mu))
+ ## if (nNA>0)
+## mu[is.na(mu)] <- paste("m",seq_len(nNA))
+## mu <- unlist(mu)
+## x <- addNode(mu,x)
+## for (i in seq_along(mu)) {
+ ## print(mu[i])
+## x <- addEdge(var[i], var[i], x)
+## }
+## x <- addattr(x,attr="shape",var=mu,val="none")
+ }
+
+ allEdges <- graph::edgeNames(g)
+ regEdges <- c()
+ feedback <- c()
+ A <- index(x)$A
+ if (index(x)$npar.reg>0)
+ for (i in seq_len(nrow(A)-1))
+ for (j in (i+1):(ncol(A))) {
+ if(A[i,j]==1 & A[j,i]==1) feedback <- c(feedback,
+ paste0(var[i],"~",var[j]),
+ paste0(var[j],"~",var[i]))
+ if (A[j,i]==0 & x$M[j,i]!=0) {
+ g <- graph::removeEdge(var[j],var[i],g)
+ }
+ if (A[i,j]==1) regEdges <- c(regEdges,paste0(var[i],"~",var[j]))
+ if (A[j,i]==1) regEdges <- c(regEdges,paste0(var[j],"~",var[i]))
+ }
+
+
+ varEdges <- corEdges <- c()
+ delta <- ifelse(diag,0,1)
+ if (cor | diag) {
+ for (r in seq_len(nrow(covariance(x)$rel)-delta) ) {
+ for (s in (r+delta):ncol(covariance(x)$rel) ) {
+ if (cor | r==s)
+ if (covariance(x)$rel[r,s]==1 & (!any(c(var[r],var[s])%in%exogenous(x)))) {
+ newedges <- c()
+ if (A[r,s]!=1) {
+ g <- graph::addEdge(var[r],var[s], g)
+ newedges <- paste0(var[r],"~",var[s])
+ } else {
+ if (A[s,r]!=1) {
+ g <- graph::addEdge(var[s],var[r], g)
+ newedges <- c(newedges,paste0(var[s],"~",var[r]))
+ }
+ }
+ if (r==s)
+ varEdges <- c(varEdges,
+ newedges
+ )
+ if (r!=s)
+ corEdges <- c(corEdges,newedges)
+ }
+ }
+ }
+ }
+
+ if (length(x$edgerender$futureinfo)>0) {
+ estr <- names(x$edgerender$futureinfo$label)
+ estr <- estr[which(unlist(lapply(estr,nchar))>0)]
+ revestr <- sapply(estr, function(y) paste(rev(unlist(strsplit(y,"~"))),collapse="~"))
+ revidx <- which(revestr%in%graph::edgeNames(g))
+ count <- 0
+ for (i in estr) {
+ count <- count+1
+ for (f in names(x$edgerender$futureinfo)) {
+ if (count%in%revidx) {
+ g at renderInfo@edges[[f]][[revestr[count]]] <- x$edgerender$futureinfo[[f]][[i]]
+ } else {
+ g at renderInfo@edges[[f]][[i]] <- x$edgerender$futureinfo[[f]][[i]]
+ }
+ }
+ }
+ }
+ allEdges <- unique(c(regEdges,corEdges,varEdges))
+ corEdges <- setdiff(corEdges,regEdges)
+
+ for (e in allEdges) {
+ dir <- "forward"; lty <- 1; arrowtail <- "none"
+ if (e %in% feedback) {
+ dir <- "none"; lty <- 1; arrowtail <- "closed"
+ }
+ if (e %in% varEdges) {
+ dir <- "none"; lty <- 2; arrowtail <- "none"
+ }
+ if (e %in% corEdges) {
+ dir <- "none"; lty <- 2; arrowtail <- "closed"
+ }
+ arrowhead <- "closed"
+ estr <- e
+ for (f in c("col","cex","textCol","lwd","lty")) {
+ if (!(estr%in%names(graph::edgeRenderInfo(g)[[f]]))
+ || is.na(graph::edgeRenderInfo(g)[[f]][[estr]]))
+ g <- addattr(g,f,var=estr,
+ val=x$graphdef[[f]],
+ fun="graph::edgeRenderInfo")
+ }
+
+ if (addstyle) {
+ g <- addattr(g,"lty",var=estr,val=lty,fun="graph::edgeRenderInfo")
+ g <- addattr(g,"direction",var=estr,val=dir,fun="graph::edgeRenderInfo")
+ g <- addattr(g,"dir",var=estr,val=dir,fun="graph::edgeRenderInfo")
+ g <- addattr(g,"arrowhead",var=estr,val=arrowhead,fun="graph::edgeRenderInfo")
+ g <- addattr(g,"arrowtail",var=estr,val=arrowtail,fun="graph::edgeRenderInfo")
+ g <- addattr(g,attr="fontsize",var=estr,val=fontsize1,fun="graph::edgeRenderInfo")
+ }
+ if (is.null(graph::edgeRenderInfo(g)$label))
+ graph::edgeRenderInfo(g)$label <- expression()
+
+ if (!missing(cex))
+ if (!is.null(cex))
+ graph::nodeRenderInfo(g)$cex <- cex
+ }
+ if (plain) {
+ g <- addattr(g,attr="shape",var=vars(x),val="none")
+ } else {
+ if (addcolor) {
+ if (is.null(x$noderender$fill)) notcolored <- vars(x)
+ else notcolored <- vars(x)[is.na(x$noderender$fill)]
+ nodecolor(g, intersect(notcolored,exogenous(x))) <- cols[1]
+ nodecolor(g, intersect(notcolored,endogenous(x))) <- cols[2]
+ nodecolor(g, intersect(notcolored,latent(x))) <- cols[3]
+ if (!is.null(trv <- x$attributes$transform)) {
+ nodecolor (g, names(trv)) <- cols[4]
+ }
+ ## nodecolor(x, intersect(notcolored,survival(x))) <- cols[4]
+ myhooks <- gethook("color.hooks")
+ count <- 3
+ for (f in myhooks) {
+ count <- count+1
+ res <- do.call(f, list(x=x,subset=notcolored))
+ if (length(cols)>=count) {
+ nodecolor(g,res$vars) <- cols[count]
+ } else {
+ nodecolor(g, res$vars) <- res$col
+ }
+ }
+ }
+ }
+ options(opt)
+ attributes(g)$feedback <- (length(feedback)>0)
+ return(g)
+}
diff --git a/R/fix.R b/R/fix.R
new file mode 100644
index 0000000..b9f2c91
--- /dev/null
+++ b/R/fix.R
@@ -0,0 +1,516 @@
+###{{{ print.fix
+
+##' @export
+print.fix <- function(x,exo=FALSE,...) {
+ switch(attributes(x)$type,
+ reg = cat("Regression parameters:\n"),
+ cov = cat("Covariance parameters:\n"),
+ mean = cat("Intercept parameters:\n"))
+ M <- linconstrain(x,print=TRUE)
+ invisible(x)
+}
+
+linconstrain <- function(x,print=TRUE,indent=" ",exo=FALSE,...) {
+ idx <- seq_len(attributes(x)$nvar)
+ idx0 <- setdiff(idx,attributes(x)$exo.idx)
+ if (!exo & attributes(x)$type!="reg")
+ idx <- idx0
+ if (attributes(x)$type=="mean") {
+ if (length(idx)>0){
+ M <- rbind(unlist(x[idx]))
+ rownames(M) <- ""
+ M[is.na(M)] <- "*"
+ } else {
+ M <- NULL
+ }
+ } else {
+ if (length(x$rel)==0) {
+ M <- NULL
+ } else {
+ M <- x$rel[idx,idx,drop=FALSE]
+ M[M==0] <- NA
+ M[M==1] <- "*"
+ M[which(!is.na(x$labels[idx,idx]))] <- x$labels[idx,idx][which(!is.na(x$labels[idx,idx]))]
+ M[which(!is.na(x$values[idx,idx]))] <- x$values[idx,idx][which(!is.na(x$values[idx,idx]))]
+ if (attributes(x)$type=="reg")
+ M <- t(M[,idx0,drop=FALSE])
+ }
+ }
+ if (print) {
+ M0 <- M
+ if (NROW(M)>0)
+ rownames(M0) <- paste(indent,rownames(M))
+ print(M0,quote=FALSE,na.print="",...)
+ }
+ invisible(M)
+}
+
+###}}} print.fix
+
+###{{{ intfix
+
+##' @export
+"intfix" <- function(object,...) UseMethod("intfix")
+##' @export
+"intfix<-" <- function(object,...,value) UseMethod("intfix<-")
+
+##' Fix mean parameters in 'lvm'-object
+##'
+##' Define linear constraints on intercept parameters in a \code{lvm}-object.
+##'
+##'
+##' The \code{intercept} function is used to specify linear constraints on the
+##' intercept parameters of a latent variable model. As an example we look at
+##' the multivariate regression model
+##'
+##' \deqn{ E(Y_1|X) = \alpha_1 + \beta_1 X} \deqn{ E(Y_2|X) = \alpha_2 + \beta_2
+##' X}
+##'
+##' defined by the call
+##'
+##' \code{m <- lvm(c(y1,y2) ~ x)}
+##'
+##' To fix \eqn{\alpha_1=\alpha_2} we call
+##'
+##' \code{intercept(m) <- c(y1,y2) ~ f(mu)}
+##'
+##' Fixed parameters can be reset by fixing them to \code{NA}. For instance to
+##' free the parameter restriction of \eqn{Y_1} and at the same time fixing
+##' \eqn{\alpha_2=2}, we call
+##'
+##' \code{intercept(m, ~y1+y2) <- list(NA,2)}
+##'
+##' Calling \code{intercept} with no additional arguments will return the
+##' current intercept restrictions of the \code{lvm}-object.
+##'
+##' @aliases intercept intercept<- intercept.lvm intercept<-.lvm intfix intfix
+##' intfix<- intfix.lvm intfix<-.lvm
+##' @param object \code{lvm}-object
+##' @param vars character vector of variable names
+##' @param value Vector (or list) of parameter values or labels (numeric or
+##' character) or a formula defining the linear constraints (see also the
+##' \code{regression} or \code{covariance} methods).
+##' @param \dots Additional arguments
+##' @usage
+##' \method{intercept}{lvm}(object, vars, ...) <- value
+##' @return
+##'
+##' A \code{lvm}-object
+##' @note
+##'
+##' Variables will be added to the model if not already present.
+##' @author Klaus K. Holst
+##' @seealso \code{\link{covariance<-}}, \code{\link{regression<-}},
+##' \code{\link{constrain<-}}, \code{\link{parameter<-}},
+##' \code{\link{latent<-}}, \code{\link{cancel<-}}, \code{\link{kill<-}}
+##' @keywords models regression
+##' @export
+##' @examples
+##'
+##'
+##' ## A multivariate model
+##' m <- lvm(c(y1,y2) ~ f(x1,beta)+x2)
+##' regression(m) <- y3 ~ f(x1,beta)
+##' intercept(m) <- y1 ~ f(mu)
+##' intercept(m, ~y2+y3) <- list(2,"mu")
+##' intercept(m) ## Examine intercepts of model (NA translates to free/unique paramete##r)
+##'
+##'
+"intercept" <- function(object,...) UseMethod("intercept")
+
+##' @export
+##' @export
+intercept.lvm <- intfix.lvm <- function(object,value,...) {
+ if (!missing(value)) {
+ intercept(object,...) <- value
+ return(object)
+ }
+ res <- object$mean; attr(res,"type") <- "mean"
+ attr(res,"exo.idx") <- index(object)$exo.idx
+ attr(res,"nvar") <- length(res)
+ class(res) <- "fix"
+ return(res)
+}
+
+##' @export
+"intercept<-" <- function(object,...,value) UseMethod("intercept<-")
+
+##' @export
+##' @export
+"intercept<-.lvm" <- "intfix<-.lvm" <- function(object, vars,...,value) {
+ if (!missing(vars) && inherits(value,"formula")) value <- all.vars(value)
+ if (inherits(value,"formula")) {
+ lhs <- getoutcome(value)
+ yy <- decomp.specials(lhs)
+ if ((inherits(value[[3]],"logical") && is.na(value[[3]]))) {
+ intfix(object,yy) <- NA
+ return(object)
+ }
+ tt <- terms(value)
+ xf <- attributes(terms(tt))$term.labels
+ res <- lapply(xf,decomp.specials)[[1]]
+
+ myvalue <- char2num(as.list(res))
+ myvalue <- lapply(myvalue, function(x) ifelse(x=="NA",NA,x))
+ intfix(object,yy) <- myvalue
+ object$parpos <- NULL
+ return(object)
+ }
+ if (inherits(vars,"formula")) {
+ vars <- all.vars(vars)
+ }
+ object$mean[vars] <- value
+ newindex <- reindex(object)
+ object$parpos <- NULL
+ index(object)[names(newindex)] <- newindex
+ return(object)
+}
+
+###}}} intfix
+
+###{{{ covfix
+
+##' @export
+"covfix" <- function(object,...) UseMethod("covfix")
+
+##' @export
+covfix.lvm <- function(object,...) {
+ res <- list(rel=object$cov, labels=object$covpar, values=object$covfix); attr(res,"type") <- "cov"
+ attr(res,"exo.idx") <- index(object)$exo.idx
+ attr(res,"nvar") <- NROW(res$rel)
+ class(res) <- "fix"
+ return(res)
+}
+
+
+##' @export
+"covfix<-" <- function(object,...,value) UseMethod("covfix<-")
+
+##' @export
+"covfix<-.lvm" <- function(object, var1, var2=var1, pairwise=FALSE, exo=FALSE, ..., value) {
+
+ if (inherits(var1,"formula")) {
+ var1 <- all.vars(var1)
+ }
+ if (inherits(var2,"formula")) {
+ var2 <- all.vars(var2)
+ }
+ object <- addvar(object,c(var1,var2),reindex=FALSE,...)
+
+ allvars <- c(var1,var2)
+ xorg <- exogenous(object)
+ exoset <- setdiff(xorg,allvars)
+
+ if (!exo & length(exoset)<length(xorg)) {
+ exogenous(object) <- exoset
+ }
+
+ if (inherits(value,"formula")) value <- all.vars(value)
+ if (pairwise) {
+ p <- 0
+ K <- length(var1)*(length(var1)-1)/2
+ if (length(value)==1)
+ value <- rep(value,K)
+ if (length(value)!=K) stop("Wrong number of parameters")
+ for (i in seq_len(length(var1)-1)) {
+ for (j in seq(i+1,length(var1))) {
+ p <- p+1
+ valp <- char2num(value[[p]])
+ if (is.na(value[[p]]) | value[[p]]=="NA") {
+ object$covfix[var1[i],var1[j]] <- object$covpar[var1[i],var1[j]] <- NA
+ object$covfix[var1[j],var1[i]] <- object$covpar[var1[j],var1[i]] <- NA
+ }
+ else {
+ object$cov[var1[i],var1[j]] <- object$cov[var1[j],var1[i]] <- 1
+ if (is.numeric(value[[p]]) | !is.na(valp)) {
+ object$covfix[var1[i],var1[j]] <- object$covfix[var1[j],var1[i]] <- valp
+ object$covpar[var1[i],var1[j]] <- object$covpar[var1[j],var1[i]] <- NA
+ } else {
+ object$covpar[var1[i],var1[j]] <- object$covpar[var1[j],var1[i]] <- value[[p]]
+ object$covfix[var1[i],var1[j]] <- object$covfix[var1[j],var1[i]] <- NA
+ }
+ }
+ }
+ }
+ newindex <- reindex(object)
+ object$parpos <- NULL
+ index(object)[names(newindex)] <- newindex
+ return(object)
+ }
+
+
+ if (is.null(var2)) {
+ if (length(value)==1)
+ value <- rep(value,length(var1))
+ if (length(value)!=length(var1)) stop("Wrong number of parameters")
+ for (i in seq_along(var1)) {
+ vali <- char2num(value[[i]])
+ if (is.na(value[[i]]) | value[[i]]=="NA") {
+ object$covfix[var1[i],var1[i]] <- object$covpar[var1[i],var1[i]] <- NA
+ }
+ else {
+ if (is.numeric(value[[i]]) | !is.na(vali)) {
+ object$covfix[var1[i],var1[i]] <- vali
+ object$covpar[var1[i],var1[i]] <- NA
+ } else {
+ object$covfix[var1[i],var1[i]] <- NA
+ object$covpar[var1[i],var1[i]] <- value[[i]]
+ }
+ }
+ }
+ newindex <- reindex(object)
+ object$parpos <- NULL
+ index(object)[names(newindex)] <- newindex
+ return(object)
+ }
+
+ if (length(var1)==length(var2) & length(var1)==length(value)) {
+ p <- 0
+ for (i in seq_along(var1)) {
+ p <- p+1
+ valp <- char2num(value[[p]])
+ if (is.na(value[[p]]) | value[[p]]=="NA") {
+ object$covfix[var1[i],var2[i]] <- object$covpar[var1[i],var2[i]] <- NA
+ object$covfix[var2[i],var1[i]] <- object$covpar[var2[i],var1[i]] <- NA
+ }
+ else {
+ object$cov[var1[i],var2[i]] <- object$cov[var2[i],var1[i]] <- 1
+ if (is.numeric(value[[p]]) | !is.na(valp)) {
+ object$covfix[var1[i],var2[i]] <- object$covfix[var2[i],var1[i]] <- valp
+ object$covpar[var1[i],var2[i]] <- object$covpar[var2[i],var1[i]] <- NA
+ } else {
+ object$covpar[var1[i],var2[i]] <- object$covpar[var2[i],var1[i]] <- value[[p]]
+ object$covfix[var1[i],var2[i]] <- object$covfix[var2[i],var1[i]] <- NA
+ }
+ }
+ }
+ newindex <- reindex(object)
+ object$parpos <- NULL
+ index(object)[names(newindex)] <- newindex
+ return(object)
+ }
+
+
+ K <- length(var1)*length(var2)
+ if (length(value)==1)
+ value <- rep(value,K)
+ if (length(value)!=K) stop("Wrong number of parameters")
+
+ p <- 0
+ for (i in seq_along(var1)) {
+ for (j in seq_along(var2)) {
+ if (!pairwise | var1[i]!=var2[j]) {
+ p <- p+1
+ valp <- char2num(value[[p]])
+ if (is.na(value[[p]]) | value[[p]]=="NA") {
+ object$covfix[var1[i],var2[j]] <- object$covpar[var1[i],var2[j]] <- NA
+ object$covfix[var2[j],var1[i]] <- object$covpar[var2[j],var1[i]] <- NA
+ }
+ else {
+ object$cov[var1[i],var2[j]] <- object$cov[var2[j],var1[i]] <- 1
+ if (is.numeric(value[[p]]) | !is.na(valp)) {
+ object$covfix[var1[i],var2[j]] <- object$covfix[var2[j],var1[i]] <- valp
+ object$covpar[var1[i],var2[j]] <- object$covpar[var2[j],var1[i]] <- NA
+ } else {
+ object$covpar[var1[i],var2[j]] <- object$covpar[var2[j],var1[i]] <- value[[p]]
+ object$covfix[var1[i],var2[j]] <- object$covfix[var2[j],var1[i]] <- NA
+ }
+ }
+ }
+ }
+ }
+ newindex <- reindex(object)
+ object$parpos <- NULL
+ index(object)[names(newindex)] <- newindex
+ return(object)
+}
+
+###}}} covfix
+
+###{{{ regfix
+
+##' @export
+"regfix" <- function(object,...) UseMethod("regfix")
+
+##' @export
+regfix.lvm <- function(object,...) {
+ res <- list(rel=index(object)$M, labels=object$par, values=object$fix); attr(res,"type") <- "reg"
+ attr(res,"exo.idx") <- index(object)$exo.idx
+ attr(res,"nvar") <- NROW(res$rel)
+ class(res) <- "fix"
+ return(res)
+}
+
+##' @export
+"regfix<-" <- function(object,...,value) UseMethod("regfix<-")
+
+##' @export
+"regfix<-.lvm" <- function(object, to, from, exo=lava.options()$exogenous, variance, y,x, ..., value) {
+ if (!missing(y)) {
+ if (inherits(y,"formula")) y <- all.vars(y)
+ to <- y
+ }
+ if (!missing(x)) {
+ if (inherits(x,"formula")) x <- all.vars(x)
+ from <- x
+ }
+ if (is.null(to)) stop("variable list needed")
+
+ if (inherits(to,"formula")) {
+ val <- procformula(object,to,exo=exo)
+ object <- val$object
+ ys <- val$ys
+ xs <- val$xs
+ if (!missing(variance))
+ covariance(object,ys) <- variance
+ to <- ys; from <- xs
+ } else {
+ object <- addvar(object,c(to,from),reindex=FALSE,...)
+ newexo <- from
+ notexo <- to
+ curvar <- index(object)$var
+ if (exo) {
+ oldexo <- exogenous(object)
+ newexo <- setdiff(newexo,c(notexo,curvar))
+ exogenous(object) <- union(newexo,setdiff(oldexo,notexo))
+ }
+ }
+
+ if (inherits(value,"formula")) value <- all.vars(value)
+
+ if (length(from)==length(to) & length(from)==length(value)) {
+ for (i in seq_along(from)) {
+ if (object$M[from[i],to[i]]==0) { ## Not adjacent! ##!isAdjacent(Graph(object), from[i], to[i])) {
+ object <- regression(object, to=to[i], from=from[i])
+ }
+ vali <- char2num(value[[i]])
+ if (is.na(value[[i]]) | value[[i]]=="NA") {
+ object$fix[from[i],to[i]] <- object$par[from[i],to[i]] <- NA
+ }
+ else {
+ if (is.numeric(value[[i]]) | !is.na(vali)) {
+ object$fix[from[i],to[i]] <- vali
+ object$par[from[i],to[i]] <- NA
+ } else {
+ object$par[from[i],to[i]] <- value[[i]]
+ object$fix[from[i],to[i]] <- NA
+ }
+ }
+ }
+ newindex <- reindex(object)
+ object$parpos <- NULL
+ index(object)[names(newindex)] <- newindex
+ return(object)
+ }
+
+ for (i in from) {
+ for (j in to) {
+ if (object$M[i,j]==0) { ##!isAdjacent(Graph(object), i, j)) {
+ object <- regression(object,to=j,from=i)
+ }
+ }
+ }
+
+ K <- length(from)*length(to)
+ if (length(value)==1)
+ value <- rep(value,K)
+ if (length(value)!=K) stop("Wrong number of parameters")
+
+ for (j in seq_along(to)) {
+ for (i in seq_along(from)) {
+ p <- (j-1)*length(from) + i
+ valp <- char2num(value[[p]])
+ if (is.na(value[[p]]) | value[[p]]=="NA")
+ object$fix[from[i],to[j]] <- object$par[from[i],to[j]] <- NA
+ else {
+ if (is.numeric(value[[p]]) | !is.na(valp)) {
+ object$fix[from[i],to[j]] <- valp
+ object$par[from[i],to[j]] <- NA
+ } else {
+ object$par[from[i],to[j]] <- value[[p]]
+ object$fix[from[i],to[j]] <- NA
+ }
+ }
+ }
+ }
+ newindex <- reindex(object)
+ object$parpos <- NULL
+ index(object)[names(newindex)] <- newindex
+ index(object) <- reindex(object)
+ return(object)
+}
+
+###}}} regfix
+
+###{{{ parfix
+
+##' @export
+"parfix<-" <- function(x,...,value) UseMethod("parfix<-")
+
+##' @export
+"parfix<-.lvm" <- function(x,idx,...,value) {
+ parfix(x,idx,value,...)
+}
+
+##' @export
+"parfix" <- function(x,...) UseMethod("parfix")
+
+
+## m <- lvm(c(y[m:v]~b*x))
+## constrain(m,b~a) <- base::identity
+
+##' @export
+parfix.lvm <- function(x,idx,value,fix=FALSE,...) {
+ object <- Model(x)
+ if (fix)
+ object <- fixsome(object)
+ if (length(idx)!=length(value))
+ value <- rep(value,length.out=length(idx))
+ value <- as.list(value)
+ I <- index(object)
+ V <- with(I, matrices2(Model(object), seq_len(npar.mean+npar+npar.ex)))
+ V$A[I$M0!=1] <- 0; V$P[I$P0!=1] <- 0
+ v.fix <- which(V$v%in%idx) ## Intercepts
+ vval <- V$v[v.fix]
+ v.ord <- match(vval,idx)
+ Pval <- V$P[V$P%in%idx] ## Variance/covariance
+ P.fix <- which(matrix(V$P%in%idx,nrow=nrow(V$P)),arr.ind=TRUE)
+ P.ord <- match(Pval,idx)
+ Aval <- V$A[which(V$A%in%idx)] ## Regression parameters
+ A.fix <- which(matrix(V$A%in%idx,nrow=nrow(V$A)),arr.ind=TRUE)
+ A.ord <- match(Aval,idx)
+ e.fix <- which(V$e%in%idx)
+ eval <- V$e[e.fix]
+ e.ord <- match(eval,idx)
+ for (i in seq_len(length(e.fix))) {
+ object$exfix[[e.fix[i]]] <- value[[e.ord[i]]]
+ }
+ for (i in seq_len(length(v.fix))) {
+ object$mean[[v.fix[i]]] <- value[[v.ord[i]]]
+ }
+ for (i in seq_len(nrow(A.fix))) {
+ if (is.numeric(value[[ A.ord[i] ]])){
+ object$fix[A.fix[i,1],A.fix[i,2]] <- value[[A.ord[i]]]
+ object$par[A.fix[i,1],A.fix[i,2]] <- NA
+ } else {
+ object$par[A.fix[i,1],A.fix[i,2]] <- value[[A.ord[i]]]
+ object$fix[A.fix[i,1],A.fix[i,2]] <- NA
+ }
+ }
+ for (i in seq_len(nrow(P.fix))) {
+ if (is.numeric(value[[ P.ord[i] ]])) {
+ object$covfix[P.fix[i,1],P.fix[i,2]] <- value[[P.ord[i]]]
+ object$covpar[P.fix[i,1],P.fix[i,2]] <- NA
+ } else {
+ object$covpar[P.fix[i,1],P.fix[i,2]] <- value[[P.ord[i]]]
+ object$covfix[P.fix[i,1],P.fix[i,2]] <- NA
+ }
+ }
+ newindex <- reindex(object)
+ object$parpos <- NULL
+ index(object)[names(newindex)] <- newindex
+ attributes(object)$fixed <- list(v=v.fix,A=A.fix,P=P.fix,e=e.fix)
+ return(object)
+}
+
+###}}} parfix
diff --git a/R/fixsome.R b/R/fixsome.R
new file mode 100644
index 0000000..c64a386
--- /dev/null
+++ b/R/fixsome.R
@@ -0,0 +1,107 @@
+
+##' @export
+fixsome <- function(x, exo.fix=TRUE, measurement.fix=TRUE, S, mu, n, data, x0=FALSE, na.method="complete.obs", param=lava.options()$param,...) {
+
+ if (is.null(param)) {
+ param <- "none"
+ } else {
+ paramval <- c("hybrid","relative","none","absolute")
+ param <- agrep(param,paramval,max.distance=0,value=TRUE)
+ }
+
+ if (is.character(measurement.fix)) {
+ param <- measurement.fix
+ measurement.fix <- TRUE
+ }
+ var.missing <- c()
+ if (!missing(data) | !missing(S)) {
+
+ if (!missing(data)) {
+ dd <- procdata.lvm(x,data=data,na.method=na.method)
+ } else {
+ dd <- procdata.lvm(x, list(S=S,mu=mu,n=n))
+ }
+ S <- dd$S; mu <- dd$mu; n <- dd$n
+ var.missing <- setdiff(index(x)$manifest,colnames(S))
+ } else { S <- NULL; mu <- NULL }
+
+ if (measurement.fix & param!="none") {
+ if (length(var.missing)>0) {## Convert to latent:
+ new.lat <- setdiff(var.missing,latent(x))
+ if (length(new.lat)>0)
+ x <- latent(x, new.lat)
+ }
+ etas <- latent(x)
+ ys <- endogenous(x)
+ M <- x$M
+
+ for (e in etas) { ## Makes sure that at least one arrow from latent variable is fixed (identification)
+ ys. <- names(which(M[e,ys]==1))
+ if (length(ys.)>0) {
+ if (tolower(param)=="absolute") {
+ if (is.na(intercept(x)[[e]])) intercept(x,e) <- 0
+ if (is.na(x$covfix[e,e]) & is.na(x$covpar[e,e])) covariance(x,e) <- 1
+ } else {
+ if (param=="hybrid") {
+ if (is.na(intercept(x)[[e]])) intercept(x,e) <- 0
+ if (all(is.na(x$fix[e, ]==1)) &
+ is.na(x$covpar[e,e]) & is.na(x$covfix[e,e]))
+ regfix(x,from=e,to=ys.[1]) <- 1
+ } else { ## relative
+ if (all(is.na(x$fix[e, ]==1)) &
+ is.na(x$covpar[e,e]) & is.na(x$covfix[e,e]))
+ regfix(x,from=e,to=ys.[1]) <- 1
+ if (!any(unlist(lapply(intercept(x)[ys.],is.numeric))) & is.na(intercept(x)[[e]])) {
+ if (tryCatch(any(idx <- !is.na(x$fix[e,ys.])),error=function(x) FALSE)) {
+ intercept(x, ys.[which(idx)[1]]) <- 0
+ } else {
+ intercept(x,ys.[1]) <- 0
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+
+ if (is.null(S)) x0 <- TRUE
+ if (exo.fix) {
+ if (x0) {
+ S0 <- diag(nrow=length(index(x)$manifest))
+ mu0 <- rep(0,nrow(S0))
+ }
+ else {
+ S0 <- S
+ S0[is.na(S0)] <- 0
+ mu0 <- mu
+ e0 <- eigen(S0)
+ thres <- lava.options()$itol^(1/2)
+ if (any(e0$values<thres)) {
+ ## Projection to nearest positive definite matrix
+ ii <- e0$values
+ ii[ii<thres] <- thres
+ S0 <- e0$vectors%*%diag(ii,nrow=length(ii))%*%t(e0$vectors)
+ }
+
+ }
+ exo.idx <- index(x)$exo.obsidx;
+ exo_all.idx <- index(x)$exo.idx
+ if (length(exo.idx)>0) {
+ for (i in seq_along(exo.idx))
+ for (j in seq_along(exo.idx)) {
+ i. <- exo_all.idx[i]; j. <- exo_all.idx[j]
+ myval <- S0[exo.idx[i],exo.idx[j]];
+ if (i.==j. & myval==0) {
+ ##warning("Overparametrized model. Problem with '"%++%index(x)$vars[j.]%++%"'")
+ myval <- 1
+ }
+ else if (is.na(myval) || is.nan(myval)) myval <- 0
+ x$covfix[i.,j.] <- x$covfix[j.,i.] <- myval
+ }
+ x$mean[exo_all.idx] <- mu0[exo.idx]
+ }
+ }
+
+ index(x) <- reindex(x)
+ return(x)
+}
diff --git a/R/formula.R b/R/formula.R
new file mode 100644
index 0000000..0fe3c0b
--- /dev/null
+++ b/R/formula.R
@@ -0,0 +1,21 @@
+##' @export
+formula.lvm <- function(x,char=FALSE,all=FALSE,...) {
+ A <- index(x)$A
+ res <- c()
+ for (i in seq_len(ncol(A))) {
+ if (all || !(colnames(A)[i]%in%c(index(x)$exogenous,parameter(x)) )) {
+ f <- paste(colnames(A)[i],"~ 1")
+ if (any(A[,i]!=0)) {
+ f <- (paste(colnames(A)[i],"~",paste(colnames(A)[A[,i]!=0],collapse="+")))
+ }
+ if (!char)
+ f <- formula(f)
+ res <- c(res, list(f))
+ }
+ }
+ return(res)
+}
+
+
+##' @export
+formula.lvmfit <- formula.lvm
diff --git a/R/fplot.R b/R/fplot.R
new file mode 100644
index 0000000..d07d7a5
--- /dev/null
+++ b/R/fplot.R
@@ -0,0 +1,58 @@
+##' Faster plot via RGL
+##' @title fplot
+##' @export
+##' @examples
+##' if (interactive()) {
+##' data(iris)
+##' fplot(Sepal.Length ~ Petal.Length+Species, data=iris, size=2, type="s")
+##' }
+##' @param x X variable
+##' @param y Y variable
+##' @param z Z variable (optional)
+##' @param xlab x-axis label
+##' @param ylab y-axis label
+##' @param ... additional arggument to lower level plot functions
+##' @param z.col Color
+##' @param data data.frame
+##' @param add If TRUE use current active device
+fplot <- function(x,y,z=NULL,xlab,ylab,...,z.col=topo.colors(64),
+ data=parent.frame(),add=FALSE) {
+ if (!requireNamespace("rgl",quietly=TRUE)) stop("Requires 'rgl'")
+ if (inherits(x,"formula")) {
+ y <- getoutcome(x)
+ x <- attributes(y)$x
+ if (length(x)>1) {
+ z <- as.numeric(with(data, get(x[2])))
+ }
+ if (length(x)==0) {
+ x <- seq(nrow(data))
+ if (missing(xlab)) xlab <- "Index"
+ } else {
+ if (missing(xlab)) xlab <- x[1]
+ x <- with(data, get(x[1]))
+ }
+ if (missing(ylab)) ylab <- y
+ y <- with(data, get(y))
+ } else {
+ if (missing(y)) {
+ y <- x
+ if (missing(ylab)) ylab <- deparse(substitute(x))
+ x <- seq(nrow(data))
+ if (missing(xlab)) xlab <- "Index"
+ } else {
+ if (missing(xlab)) xlab <- deparse(substitute(x))
+ if (missing(ylab)) ylab <- deparse(substitute(y))
+ }
+ }
+ rgl::.check3d()
+ if (!is.null(z)) {
+ ncol <- length(z.col);
+ glut <- approxfun(seq(min(z),max(z),length.out=ncol),seq(ncol))
+ rgl::plot3d(x,y,0,col=z.col[round(glut(z))],xlab=xlab,ylab=ylab,...)
+ } else {
+ rgl::plot3d(x,y,0,xlab=xlab,ylab=ylab,...)
+ }
+ rgl::view3d(0,0,fov=0)
+}
+
+
diff --git a/R/functional.R b/R/functional.R
new file mode 100644
index 0000000..fd4cc4c
--- /dev/null
+++ b/R/functional.R
@@ -0,0 +1,49 @@
+##' @export
+"functional<-" <- function(x,...,value) UseMethod("functional<-")
+
+##' @export
+"functional<-.lvm" <- function(x,to,from,...,value) {
+ if (inherits(to,"formula")) {
+ yy <- decomp.specials(getoutcome(to))
+ ##xx <- attributes(terms(to))$term.labels
+ myvars <- all.vars(to)
+ xx <- setdiff(myvars,yy)
+ if (length(yy)*length(xx)>length(value) & length(value)!=1) stop("Wrong number of values")
+ count <- 0
+ for (y in yy) {
+ count <- count+1
+ for (i in seq_along(xx)) {
+ suppressWarnings(x <- regression(x,to=y,from=xx[i],silent=TRUE))
+ count <- count+1
+ if (length(value)==1) {
+ functional(x, to=y, from=xx[i],...) <- value
+ } else
+ functional(x, to=y, from=xx[i],...) <- value[[count]]
+ }
+ }
+ return(x)
+ }
+
+ if (missing(from) | missing(to))
+ return(x)
+
+ edges <- paste(from,to,sep="~")
+ x$attributes$functional[[edges]] <- value
+ return(x)
+}
+
+##' @export
+"functional" <- function(x,...) UseMethod("functional")
+
+##' @export
+functional.lvm <- function(x,to,from,f,...) {
+ if (!missing(f)) {
+ functional(x,to,from,...) <- f
+ return(x)
+ }
+ if (missing(from))
+ return(x$attributes$functional)
+
+ edges <- paste(from,to,sep="~")
+ x$attributes$functional[edges]
+}
diff --git a/R/gkgamma.R b/R/gkgamma.R
new file mode 100644
index 0000000..dcf33bf
--- /dev/null
+++ b/R/gkgamma.R
@@ -0,0 +1,133 @@
+goodmankruskal_gamma <- function(P,...) {
+ nr <- nrow(P); nc <- ncol(P)
+ Pconc <- 0
+ for (i in seq_len(nr-1)) {
+ h <- seq(i+1,nr)
+ for (j in seq_len(nc-1)) {
+ k <- seq(j+1,nc)
+ Pconc <- Pconc+2*P[i,j]*sum(P[h,k])
+ }
+ }
+ Pdisc <- 0
+ for (i in seq_len(nr-1)) {
+ h <- seq(i+1,nr)
+ for (j in (seq_len(nc-1)+1)) {
+ k <- seq(1,j-1)
+ Pdisc <- Pdisc+2*P[i,j]*sum(P[h,k])
+ }
+ }
+ list(C=Pconc,D=Pdisc,gamma=(Pconc-Pdisc)/(Pconc+Pdisc))
+}
+
+
+##' @export
+gkgamma <- function(x,data=parent.frame(),strata=NULL,all=FALSE,iid=TRUE,...) {
+ if (inherits(x,"formula")) {
+ xf <- getoutcome(x,sep="|")
+ xx <- attr(xf,"x")
+ if (length(xx)==0) stop("Not a valid formula")
+ yx <- update(as.formula(paste0(xf,"~.")),xx[[1]])
+ if (length(xx)>1) {
+ strata <- interaction(model.frame(xx[[2]],data=data))
+ x <- yx
+ } else {
+ x <- model.frame(yx,data=data)
+ }
+ }
+ if (!is.null(strata)) {
+ dd <- split(data,strata)
+ gam <- lapply(dd,function(d,...) gkgamma(x,data=d,...),
+ ...,
+ iid=TRUE,
+ keep=1:2)
+ mgam <- Reduce(function(x,y,...) merge(x,y,...),gam)
+ ps <- estimate(multinomial(strata),data=data,...)
+ mgam <- merge(mgam,ps)
+ psi <- 2*length(gam)+seq(length(coef(ps)))
+ res <- estimate(mgam,function(p,...) {
+ k <- length(p)/3
+ cd <- lapply(seq(k),function(x) p[(1:2)+2*(x-1)])
+ dif <- unlist(lapply(cd,function(x) x[1]-x[2]))
+ tot <- unlist(lapply(cd,function(x) x[1]+x[2]))
+ gam <- dif/tot ## Conditional gammas given Z=z
+ px2 <- p[psi]^2
+ pgamma <- sum(dif*px2)/sum(tot*px2)
+ c(gam,pgamma=pgamma)
+ },labels=c(paste0("\u03b3:",names(dd)),"pgamma"),
+ iid=iid)
+ if (!iid) {
+ for (i in seq_along(gam))
+ gam[[i]][c("iid","id")] <- NULL
+ }
+ homtest <- estimate(res,lava::contr(seq_along(gam),length(gam)+1),iid=FALSE)
+ attributes(res) <- c(attributes(res),
+ list(class=c("gkgamma","estimate"),
+ cl=match.call(),
+ strata=gam,
+ homtest=homtest))
+ return(res)
+ }
+ if (is.table(x) || is.data.frame(x) || is.matrix(x)) {
+ x <- multinomial(x)
+ }
+ if (!inherits(x,"multinomial")) stop("Expected table, data.frame or multinomial object")
+ structure(estimate(x,function(p) {
+ P <- x$position; P[] <- p[x$position]
+ goodmankruskal_gamma(P)
+ },iid=iid,data=data,...),
+ cl=match.call(),
+ class=c("gkgamma","estimate"))
+}
+
+##' @export
+print.gkgamma <- function(x,call=TRUE,...) {
+ if (call) {
+ cat("Call: ")
+ print(attr(x,"cl"))
+ printline(50)
+ }
+ n <- x$n
+
+ if (!is.null(attr(x,"strata"))) {
+ cat("Strata:\n\n")
+ for (i in seq_along(attr(x,"strata"))) {
+ with(attributes(x), cat(paste0(names(strata)[i],
+ " (n=",strata[[i]]$n,
+ if (strata[[i]]$ncluster<strata[[i]]$n) paste0(",clusters=",strata[[i]]$ncluster),
+ "):\n",sep="")))
+ e <- attr(x,"strata")[[i]]
+ print.estimate(e,level=0)
+ cat("\n")
+ }
+ printline(50)
+ cat("\n")
+ n <- sum(unlist(lapply(attr(x,"strata"),"[[","n")))
+ }
+ k <- x$ncluster
+ if (!is.null(n) && !is.null(k) && k<n) {
+ cat("n = ",n,", clusters = ",k,"\n\n",sep="")
+ } else {
+ if (!is.null(n)) {
+ cat("n = ",n,"\n\n",sep="")
+ } else if (!is.null(k)) {
+ cat("n = ",k,"\n\n",sep="")
+ }
+ }
+ if (!is.null(attr(x,"strata"))) {
+ cat("Gamma coefficient:\n\n")
+ }
+ class(x) <- "estimate"
+ print(x)
+ ## if (!is.null(attr(x,"homtest"))) {
+ ## printline(50)
+ ## cat("Homogeneity test:\n\n")
+ ## with(attr(x,"homtest")$compare,
+ ## cat("\u03c7\u00b2 = ",statistic,
+ ## ", df = ",parameter,
+ ## ", p-value = ",p.value,"\n",sep=""))
+ ## }
+ invisible(x)
+}
+
+
+
diff --git a/R/glmest.R b/R/glmest.R
new file mode 100644
index 0000000..73e3160
--- /dev/null
+++ b/R/glmest.R
@@ -0,0 +1,348 @@
+
+glm.estimate.hook <- function(x,estimator,...) {
+ yy <- c()
+ if (length(estimator)>0 && estimator=="glm") {
+ for (y in endogenous(x)) {
+ fam <- attributes(distribution(x)[[y]])$family
+ if (is.null(fam)) fam <- stats::gaussian()
+ if (!(tolower(fam$family)%in%
+ c("gaussian","gamma","inverse.gaussian","weibull"))) {
+ yy <- c(yy,y)
+ }
+ }
+ if (length(yy)>0) covariance(x,yy) <- 1
+ }
+ return(c(list(x=x,estimator=estimator,...)))
+}
+
+GLMest <- function(m,data,control=list(),...) {
+ v <- vars(m)
+ yvar <- endogenous(m)
+ res <- c()
+ count <- 0
+ V <- NULL
+ mymsg <- c()
+ iids <- c()
+ breads <- c()
+
+ et <- eventTime(m)
+ yvar.et <- rep(NA,length(yvar))
+ names(yvar.et) <- yvar
+ if (!is.null(et)) {
+ for (i in seq_along(et)) {
+ ## if (!survival::is.Surv(data[,et[[i]]$names[1]]))
+ ## data[,et[[i]]$names[1]] <- with(et[[i]],
+ ## survival::Surv(data[,names[1]],data[,names[2]]))
+ yvar <- setdiff(yvar,c(et[[i]]$latentTimes[-1],et[[i]]$names))
+ yvar.et[et[[i]]$latentTimes[1]] <- et[[i]]$names[1]
+ }
+ }
+ ## newpar <- c()
+ for (y in yvar) {
+ count <- count+1
+ xx <- parents(m,y)
+ fam <- attributes(distribution(m)[[y]])$family
+ if (is.null(fam)) fam <- stats::gaussian()
+ if (!is.null(fam$link)) {
+ mymsg <- c(mymsg, with(fam, paste0(family,"(",link,")")))
+ } else {
+ mymsg <- c(mymsg, with(fam, paste0(family)))
+ }
+ if (length(xx)==0) xx <- 1
+ nn0 <- paste(y,xx,sep=lava.options()$symbol[1])
+ y0 <- y
+ ## isEventTime <- !is.na(yvar.et[y])
+ ## if (isEventTime) {
+ ## y <- yvar.et[y]
+ ## }
+ #nn0 <- paste(y,xx,sep=lava.options()$symbol[1])
+
+ f <- as.formula(paste0(y,"~",paste(xx,collapse="+")))
+ isSurv <- inherits(data[1,y],"Surv")
+ if (isSurv) {
+ g <- survival::survreg(f,data=data,dist=fam$family)
+ } else {
+ g <- glm(f,family=fam,data=data)
+ }
+
+ p <- pars(g)
+ ii <- iid(g)
+ V0 <- attr(ii,"bread")
+ iids <- cbind(iids,ii)
+ y <- y0
+ names(p)[1] <- y
+ if (length(p)>1) {
+ nn <- paste(y,xx,sep=lava.options()$symbol[1])
+ names(p)[seq_along(nn)+1] <- nn0
+ if (length(p)>length(nn)+1) names(p)[length(p)] <- paste(y,y,sep=lava.options()$symbol[2])
+ }
+ ## if (isEventTime) {
+ ## newpar <- c(newpar,names(p))
+ ## }
+ if (tolower(fam$family)%in%c("gaussian","gamma","inverse.gaussian") && !isSurv) {
+ iids <- cbind(iids,0)
+ null <- matrix(0); dimnames(null) <- list("scale","scale")
+ V0 <- blockdiag(V0,null,pad=0)
+ }
+ breads <- c(breads,list(V0))
+ res <- c(res, list(p));
+ }
+ coefs <- unlist(res)
+ idx <- na.omit(match(coef(m),names(coefs)))
+ coefs <- coefs[idx]
+ ##V <- Reduce(blockdiag,breads)[idx,idx]
+ V <- crossprod(iids[,idx])
+ ##V <- crossprod(iids[,idx])
+ mymsg <- noquote(cbind(mymsg))
+ colnames(mymsg) <- "Family(Link)"; rownames(mymsg) <- paste(yvar,":")
+ list(estimate=coefs,vcov=V,breads=breads,iid=iids[,idx],summary.message=function(...) {
+ mymsg }, dispname="Dispersion:") ##, new.parameters=newpar)
+}
+
+GLMscore <- function(x,p,data,indiv=TRUE,logLik=FALSE,...) {
+ v <- vars(x)
+ yvar <- endogenous(x)
+ S <- pnames <- c()
+ count <- 0
+ pos <- 0
+ breads <- c()
+ L <- 0
+ for (y in yvar) {
+ count <- count+1
+ xx <- parents(x,y)
+ pname <- c(y,paste0(y,sep=lava.options()$symbol[1],xx),paste(y,y,sep=lava.options()$symbol[2]))
+ pidx <- na.omit(match(pname,coef(x)))
+ ##pidx <- na.omit(match(coef(x),pname))
+ fam <- attributes(distribution(x)[[y]])$family
+ if (is.null(fam)) fam <- stats::gaussian()
+ if (length(xx)==0) xx <- 1
+ f <- as.formula(paste0(y,"~",paste(xx,collapse="+")))
+ isSurv <- inherits(data[1,y],"Surv")
+ if (inherits(data[,y],"Surv")) {
+ g <- survival::survreg(f,data=data,dist=fam$family)
+ } else {
+ g <- glm(f,family=fam,data=data)
+ }
+ pdispersion <- NULL
+ npar <- length(xx)+2
+ p0 <- p[pidx]
+ if (!isSurv) L0 <- logL.glm(g,p=p0,indiv=TRUE,...)
+ if (tolower(fam$family)%in%c("gaussian","gamma","inverse.gaussian") && !isSurv) {
+ p0 <- p0[-length(p0)]
+ S0 <- score(g,p=p0,indiv=TRUE,pearson=TRUE,...)
+ V0 <- attr(S0,"bread")
+ r <- attr(S0,"pearson")
+ dispersion <- mean(r^2)
+ S0 <- cbind(S0,scale=0)
+ null <- matrix(0); dimnames(null) <- list("scale","scale")
+ V0 <- blockdiag(V0,null,pad=0)
+ } else {
+ S0 <- score(g,p=p0,indiv=TRUE,...)
+ if (isSurv) L0 <- attr(S0,"logLik")
+ V0 <- attr(S0,"bread")
+ }
+ L <- L+sum(L0)
+ breads <- c(breads,list(V0))
+ S <- c(S,list(S0))
+ pnames <- c(pnames, list(pname));
+ }
+ coefs <- unlist(pnames)
+ idx <- na.omit(match(coefs,coef(x)))
+ idx <- order(idx)
+ V <- Reduce(blockdiag,breads)[idx,idx]
+ S1 <- Reduce(cbind,S)[,idx,drop=FALSE]
+ colnames(S1) <- coef(x)
+ attributes(S1)$bread <- V
+ attributes(S1)$logLik <- structure(L,nobs=nrow(data),nall=nrow(data),df=length(p),class="logLik")
+ if (!indiv) S1 <- colSums(S1)
+ return(S1)
+}
+
+
+##' @export
+score.lm <- function(x,p=coef(x),data,indiv=FALSE,
+ y,X,offset=NULL,weights=NULL,...) {
+ response <- all.vars(formula(x))[1]
+ sigma2 <- summary(x)$sigma^2
+ if (missing(data)) {
+ X <- model.matrix(x)
+ y <- model.frame(x)[,1]
+ } else {
+ X <- model.matrix(formula(x),data=data)
+ y <- model.frame(formula(x),data=data)[,1]
+ }
+ n <- nrow(X)
+ if(any(is.na(p))) warning("Over-parameterized model")
+ Xbeta <- X%*%p
+ if (is.null(offset)) offset <- x$offset
+ if (!is.null(offset)) Xbeta <- Xbeta+offset
+ r <- y-Xbeta
+ if (is.null(weights)) weights <- x$weights
+ if (!is.null(weights)) r <- r*weights
+ A <- as.vector(r)/sigma2
+ S <- apply(X,2,function(x) x*A)
+ if (!indiv) return(colSums(S))
+ attributes(S)$bread <- vcov(x)
+ return(S)
+}
+
+##' @export
+score.glm <- function(x,p=coef(x),data,indiv=FALSE,pearson=FALSE,
+ y,X,link,dispersion,offset=NULL,weights=NULL,...) {
+
+ response <- all.vars(formula(x))[1]
+ if (inherits(x,"glm")) {
+ link <- family(x)
+ if (missing(data)) {
+ X <- model.matrix(x)
+ y <- model.frame(x)[,1]
+ } else {
+ X <- model.matrix(formula(x),data=data)
+ y <- model.frame(formula(x),data=data)[,1]
+ }
+ offset <- x$offset
+ } else {
+ if (missing(link)) stop("Family needed")
+ if (missing(data)) stop("data needed")
+ X <- model.matrix(formula(x),data=data)
+ y <- model.frame(formula(x),data=data)[,1]
+ }
+ if (is.character(y) || is.factor(y)) {
+ y <- as.numeric(as.factor(y))-1
+ }
+ n <- nrow(X)
+ g <- link$linkfun
+ ginv <- link$linkinv
+ dginv <- link$mu.eta ## D[linkinv]
+ ##dg <- function(x) 1/dginv(g(x)) ## Dh^-1 = 1/(h'(h^-1(x)))
+ canonf <- do.call(link$family,list())
+ caninvlink <- canonf$linkinv
+ canlink <- canonf$linkfun
+ Dcaninvlink <- canonf$mu.eta
+ Dcanlink <- function(x) 1/Dcaninvlink(canlink(x))
+ ##gmu <- function(x) g(caninvlink(x))
+ ##invgmu <- function(z) canlink(ginv(z))
+ h <- function(z) Dcanlink(ginv(z))*dginv(z)
+ if(any(is.na(p))) stop("Over-parameterized model")
+ Xbeta <- X%*%p
+ if (!is.null(offset)) Xbeta <- Xbeta+offset
+ if (missing(data) && !is.null(x$offset) && is.null(offset) ) Xbeta <- Xbeta+x$offset
+ pi <- ginv(Xbeta)
+ ##res <- as.vector(y/pi*dginv(Xbeta)-(1-y)/(1-pi)*dginv(Xbeta))*X
+ ##return(res)
+ r <- y-pi
+ if (!is.null(x$prior.weights) || !is.null(weights)) {
+ if (is.null(weights)) weights <- x$prior.weights
+ } else {
+ weights <- !is.na(r)
+ }
+ r <- r*weights
+ a.phi <- 1
+ rpearson <- as.vector(r)/link$variance(pi)^.5
+ if (length(p)>length(coef(x))) {
+ a.phi <- p[length(coef(x))+1]
+ } else if (tolower(family(x)$family)%in%c("gaussian","gamma","inverse.gaussian")) {
+ ##a.phi <- summary(x)$dispersion*g0$df.residual/sum(weights)
+ a.phi <- sum(rpearson^2)*x$df.residual/x$df.residual^2
+ }
+ A <- as.vector(h(Xbeta)*r)/a.phi
+ S <- apply(X,2,function(x) x*A)
+ if (!indiv) return(colSums(S))
+ if (pearson) attr(S,"pearson") <- rpearson
+ attributes(S)$bread <- vcov(x)
+ if (x$family$family=="quasi" && x$family$link=="identity" && x$family$varfun=="constant")
+ attributes(S)$bread <- -Inverse(information.glm(x))
+ return(S)
+}
+
+##' @export
+pars.glm <- function(x,...) {
+ if (tolower(family(x)$family)%in%c("gaussian","gamma","inverse.gaussian")) {
+ res <- c(coef(x),summary(x)$dispersion)
+ names(res)[length(res)] <- "Dispersion"
+ return(res)
+ }
+ return(coef(x))
+}
+
+logL.glm <- function(x,p=pars.glm(x),data,indiv=FALSE,...) {
+ if (!missing(data)) {
+ x <- update(x,data=data,...)
+ }
+ f <- family(x)
+ ginv <- f$linkinv
+ X <- model.matrix(x)
+ n <- nrow(X)
+ disp <- 1; p0 <- p
+ if (tolower(family(x)$family)%in%c("gaussian","gamma","inverse.gaussian")) {
+ if (length(p)==ncol(X)) {
+ disp <- suppressWarnings((summary(x)$dispersion))
+ } else {
+ disp <- tail(p,1)
+ p0 <- p[-length(p)]
+ }
+ }
+ if(any(is.na(p))) {
+ warning("Over-parametrized model")
+ }
+ Xbeta <- X%*%p0
+ if (!is.null(x$offset)) Xbeta <- Xbeta+x$offset
+ y <- model.frame(x)[,1]
+ mu <- ginv(Xbeta)
+ w <- x$prior.weights
+ dev <- f$dev.resids(y,mu,w)
+ if (indiv) {
+
+ }
+ loglik <- length(p)-(f$aic(y,n,mu,w,sum(dev))/2+x$rank)
+ structure(loglik,nobs=n,df=length(p),class="logLik")
+}
+
+##' @export
+iid.glm <- function(x,...) {
+ ## if (x$family$family=="quasi" && x$family$link=="identity" && x$family$varfun=="constant") {
+ ## return(iid.default(x,information.glm,...))
+ ## }
+ iid.default(x,...)
+}
+
+hessian.glm <- function(x,p=coef(x),...) {
+ numDeriv::jacobian(function(theta) score.glm(x,p=theta,indiv=FALSE,...),p)
+}
+
+##' @export
+information.glm <- function(x,...) hessian.glm(x,...)
+
+robustvar <- function(x,id=NULL,...) {
+ U <- score(x,indiv=TRUE)
+ II <- unique(id)
+ K <- length(II)
+ J <- 0
+ if (is.null(id)) {
+ J <- crossprod(U)
+ } else {
+ for (ii in II) {
+ J <- J+tcrossprod(colSums(U[which(id==ii),,drop=FALSE]))
+ }
+ J <- K/(K-1)*J
+ }
+ iI <- vcov(x)
+ V <- iI%*%J%*%iI
+ return(V)
+}
+
+glm_logLik.lvm <- function(object,...) {
+ attr(GLMscore(object,...),"logLik")
+}
+
+glm_method.lvm <- NULL
+glm_objective.lvm <- function(x,p,data,...) {
+ GLMest(x,data,...)
+}
+glm_gradient.lvm <- function(x,p,data,...) {
+ -GLMscore(x,p,data,...)
+}
+
+glm_variance.lvm <- function(x,p,data,opt,...) {
+ opt$vcov
+}
diff --git a/R/gof.R b/R/gof.R
new file mode 100644
index 0000000..ae3f7da
--- /dev/null
+++ b/R/gof.R
@@ -0,0 +1,386 @@
+##' @export
+rsq <- function(x,stderr=FALSE) {
+
+ if (stderr) {
+ v <- endogenous(x)
+ vpar <- paste(v,v,sep=lava.options()$symbol[2])
+ iid.v <- iid(model.frame(x)[,v])
+ iid.mod <- iid(x)
+ coef0 <- c(attributes(iid.v)$coef[vpar],
+ coef(x)[vpar])
+ iid0 <- cbind(iid.v[,vpar],iid.mod[,vpar])
+ p <- length(v)
+ idx <- seq_len(p);
+ ee <- estimate(NULL,data=NULL,
+ function(x) {
+ res <- (x[idx]-x[idx+p])/x[idx]
+ names(res) <- v
+ as.list(res)
+ },
+ print=function(x,...) {
+ cat("\nR-squared:\n\n")
+ print(x$coefmat)
+ },
+ coef=coef0, iid=iid0)
+
+ res <- ee
+ ##res <- list(ee)
+ ## for (lat in latent(x)) {
+
+ ## v <- intersect(children(x,lat),endogenous(x))
+ ## vpar <- paste(v,v,sep=lava.options()$symbol[2])
+ ## lpar <- paste(lat,lat,sep=lava.options()$symbol[2])
+ ## rpar <- paste(v,lat,sep=lava.options()$symbol[1])
+ ## fix <- c(x$model$fix[lat,v,drop=TRUE],x$model$covfix[lat,lat])
+ ## pp <- coef(x)
+ ## idx <- x$model$parpos$A[lat,v]
+ ## idx2 <- x$model$parpos$P[lat,lat]
+ ## p0 <- c(idx,idx2)
+ ## p1 <- setdiff(unique(p0),0)
+ ## p2 <- match(p0,p1)
+
+ ## k <- length(v)
+ ## coef0 <- c(pp[p1],attributes(iid.v)$coef[vpar])
+ ## iid0 <- cbind(iid.mod[,p1],iid.v[,vpar])
+ ## ee <- estimate(NULL,data=NULL,
+ ## function(p) {
+ ## p. <- p[p2]
+ ## p.[is.na(p.)] <- fix[is.na(p.)]
+ ## res <- p.[seq_len(k)]^2*p.[k+1]/tail(p,k)
+ ## names(res) <- v
+ ## as.list(res)
+ ## },
+ ## print=function(x,...) {
+ ## cat("\nVariance explained by '", lat,"':\n\n",sep="")
+ ## print(x$coefmat)
+ ## },coef=coef0,iid=iid0)
+ ## res <- c(res,list(ee))
+ ## }
+
+ return(res)
+ }
+
+
+
+ v <- c(endogenous(x),setdiff(latent(x),parameter(Model(x))))
+ res <- coef(x,9,std="yx")
+ idx <- with(attributes(res),
+ which(type=="variance" & (var==from)))
+ nam <- attributes(res)$var[idx]
+ res <- 1-res[idx,5]
+ names(res) <- nam
+ res <- list("R-squared"=res)
+ ## M <- moments(x,coef(x))
+ ## v <- setdiff(vars(x),exogenous(x))
+ ## vvar <- M$Cfull[cbind(v,v)]
+ ## rsq <- (vvar-M$P[cbind(v,v)])/vvar
+
+ if (length(latent(x))>0) {
+ M <- moments(x,coef(x))
+ nn <- names(res)
+ for (lat in latent(x)) {
+ v <- intersect(children(x,lat),endogenous(x))
+ varl <- M$Cfull[lat,lat]
+ varv <- M$Cfull[cbind(v,v)]
+ rpar <- paste(v,lat,sep=lava.options()$symbol[1])
+ fix <- c(x$model$fix[lat,v,drop=TRUE])
+ pp <- coef(x)
+ if (inherits(x,"lvm.missing")) {
+ mp <- match(coef(x$model),names(coef(x)))
+ pp <- pp[mp]
+ }
+ idx1 <- x$model$parpos$A[lat,v]
+ ##idx2 <- x$model$parpos$P[lat,lat]
+ ##idx3 <- x$model$parpos$P[cbind(v,v)]
+ p0 <- c(idx1)
+ p1 <- setdiff(unique(p0),0)
+ p2 <- match(p0,p1)
+ p <- pp[p1]
+ p. <- p[p2]
+ p.[is.na(p.)] <- fix[is.na(p.)]
+ k <- length(v)
+ val <- (p.^2*varl)/varv; names(val) <- v
+ res <- c(res,list(val))
+ nn <- c(nn,paste0("Variance explained by '",lat,"'"))
+ }
+ names(res) <- nn
+ }
+ res
+}
+
+satmodel <- function(object,logLik=TRUE,data=model.frame(object),
+ control=list(trace=1),
+ weights=Weights(object),estimator=object$estimator,
+ missing=inherits(object,"lvm.missing"),
+ regr=FALSE,
+ ...) {
+ if (object$estimator=="gaussian" & logLik & !missing) {
+ if (class(object)[1]%in%c("multigroupfit","multigroup")) {
+
+ ll <- structure(0,nall=0,nobs=0,df=0,class="logLik")
+ for (i in seq_len(Model(object)$ngroup)) {
+ l0 <- logLik(Model(Model(object))[[i]],data=model.frame(object)[[i]],type="sat")
+
+ ll <- ll+l0
+ for (atr in c("nall","nobs","df"))
+ attributes(ll)[[atr]] <- attributes(ll)[[atr]]+attributes(l0)[[atr]]
+ }
+
+ }
+ return(logLik(object, type="sat"))
+ }
+ covar <- exogenous(object)
+ y <- endogenous(object)
+ m0 <- Model(object)
+ if (length(covar)>0)
+ suppressWarnings(m0 <- regression(m0,y,covar))
+ if (length(latent(m0))>0)
+ kill(m0) <- latent(m0)
+ cancel(m0) <- y
+ if (!regr)
+ suppressWarnings(covariance(m0) <- y)
+ else {
+ if (length(y)>1) {
+ for (i in seq_len(length(y)-1))
+ for (j in seq(i+1,length(y))) {
+ m0 <- regression(m0,y[i],y[j])
+ }
+ }
+ exogenous(m0) <- covar
+ }
+ if (is.null(control$start)) {
+ mystart <- rep(0,with(index(m0), npar.mean+npar))
+ mystart[variances(m0,mean=TRUE)] <- 1
+ control$start <- mystart
+ }
+ message("Calculating MLE of saturated model:\n")
+ e0 <- estimate(m0,data=data,weights=weights,estimator=estimator,silent=TRUE,control=control,missing=missing,...)
+ if (logLik)
+ return(logLik(e0))
+ return(e0)
+}
+
+condition <- function(A) {
+ suppressWarnings(with(eigen(A),tail(values,1)/head(values,1)))
+}
+
+
+
+##' Extract model summaries and GOF statistics for model object
+##'
+##' Calculates various GOF statistics for model object including global
+##' chi-squared test statistic and AIC. Extract model-specific mean and variance
+##' structure, residuals and various predicitions.
+##'
+##'
+##' @aliases gof gof.lvmfit moments moments.lvm information information.lvmfit
+##' score score.lvmfit logLik.lvmfit
+##' @param object Model object
+##' @param x Model object
+##' @param p Parameter vector used to calculate statistics
+##' @param data Data.frame to use
+##' @param latent If TRUE predictions of latent variables are included in output
+##' @param data2 Optional second data.frame (only for censored observations)
+##' @param weights Optional weight matrix
+##' @param n Number of observations
+##' @param conditional If TRUE the conditional moments given the covariates are
+##' calculated. Otherwise the joint moments are calculated
+##' @param model String defining estimator, e.g. "gaussian" (see
+##' \code{estimate})
+##' @param debug Debugging only
+##' @param chisq Boolean indicating whether to calculate chi-squared
+##' goodness-of-fit (always TRUE for estimator='gaussian')
+##' @param level Level of confidence limits for RMSEA
+##' @param rmsea.threshold Which probability to calculate, Pr(RMSEA<rmsea.treshold)
+##' @param all Calculate all (ad hoc) FIT indices: TLI, CFI, NFI, SRMR, ...
+##' @param \dots Additional arguments to be passed to the low level functions
+##' @usage
+##'
+##' gof(object, ...)
+##'
+##' \method{gof}{lvmfit}(object, chisq=FALSE, level=0.90, rmsea.threshold=0.05,all=FALSE,...)
+##'
+##' moments(x,...)
+##'
+##' \method{moments}{lvm}(x, p, debug=FALSE, conditional=FALSE, data=NULL, latent=FALSE, ...)
+##'
+##' \method{logLik}{lvmfit}(object, p=coef(object),
+##' data=model.frame(object),
+##' model=object$estimator,
+##' weights=Weights(object),
+##' data2=object$data$data2,
+##' ...)
+##'
+##' \method{score}{lvmfit}(x, data=model.frame(x), p=pars(x), model=x$estimator,
+##' weights=Weights(x), data2=x$data$data2, ...)
+##'
+##' \method{information}{lvmfit}(x,p=pars(x),n=x$data$n,data=model.frame(x),
+##' model=x$estimator,weights=Weights(x), data2=x$data$data2, ...)
+##'
+##' @return A \code{htest}-object.
+##' @author Klaus K. Holst
+##' @keywords methods models
+##' @export
+##' @examples
+##' m <- lvm(list(y~v1+v2+v3+v4,c(v1,v2,v3,v4)~x))
+##' set.seed(1)
+##' dd <- sim(m,1000)
+##' e <- estimate(m, dd)
+##' gof(e,all=TRUE,rmsea.threshold=0.05,level=0.9)
+##'
+##'
+##' set.seed(1)
+##' m <- lvm(list(c(y1,y2,y3)~u,y1~x)); latent(m) <- ~u
+##' regression(m,c(y2,y3)~u) <- "b"
+##' d <- sim(m,1000)
+##' e <- estimate(m,d)
+##' rsq(e)
+##' ##'
+##' rr <- rsq(e,TRUE)
+##' rr
+##' estimate(rr,contrast=rbind(c(1,-1,0),c(1,0,-1),c(0,1,-1)))
+##'
+`gof` <-
+ function(object,...) UseMethod("gof")
+
+##' @export
+gof.lvmfit <- function(object,chisq=FALSE,level=0.90,rmsea.threshold=0.05,all=FALSE,...) {
+ n <- object$data$n
+ if (class(object)[1]=="multigroupfit") n <- sum(unlist(lapply(object$model$data,nrow)))
+ loglik <- logLik(object,...)
+
+ df <- attributes(loglik)$df
+ nobs <- attributes(loglik)$nall*length(endogenous(object))
+ myAIC <- -2*(loglik - df); attributes(myAIC) <- NULL
+ myBIC <- -2*loglik + df*log(nobs); attributes(myBIC) <- NULL
+
+ xconstrain <- intersect(unlist(lapply(constrain(object),function(z) attributes(z)$args)),manifest(object))
+
+ l2D <- mean(object$opt$grad^2)
+ S <- vcov(object)
+ rnkV <- tryCatch(qr(S)$rank,error=function(...) 0)
+ minSV <- attr(S,"minSV")
+ condnum <- tryCatch(condition(vcov(object)),error=function(...) NULL)
+
+## if (class(object)[1]=="lvmfit" & (object$estimator=="gaussian" | chisq) & length(xconstrain)==0 ) {
+ if (((object$estimator=="gaussian" & class(object)[1]!="lvm.missing") | chisq) & length(xconstrain)==0 ) {
+ res <- list(fit=compare(object), n=n, logLik=loglik, BIC=myBIC, AIC=myAIC)
+ q <- res$fit$statistic
+ qdf <- res$fit$parameter
+ if (all) {
+ m0 <- lvm(manifest(object)); exogenous(m0) <- NULL
+ e0 <- estimate(m0,model.frame(object))
+ g0 <- gof(e0)
+ logLikbaseline <- g0$logLik
+ qbaseline <- g0$fit$statistic
+ qdfbaseline <- g0$fit$parameter
+ CFI <- ((qbaseline-qdfbaseline) - (q-qdf))/(qbaseline-qdfbaseline)
+ NFI <- (qbaseline-q)/qbaseline
+ TLI <- (qbaseline/qdfbaseline-q/qdf)/(qbaseline/qdfbaseline-1)
+ S <- object$data$S
+ mu <- object$data$mu
+ C <- modelVar(object)$C
+ xi <- as.vector(modelVar(object)$xi)
+ if (is.null(S)) S <- cov(model.frame(object))
+ if (is.null(mu)) mu <- colMeans(model.frame(object))
+ L <- diag(S)^0.5
+ idx <- index(object)$endo.idx
+ R <- (diag(1/L))%*%(S-C)%*%(diag(1/L))
+ R2 <- (mu-xi)/L
+ SRMR <- mean(c(R[upper.tri(R,diag=TRUE)],R2)^2)^0.5
+ res <- c(res,list(CFI=CFI,NFI=NFI,TLI=TLI,C=C,S=S,SRMR=SRMR))
+ ## if (length(latent(object))>0) {
+ ## SRMR.endo <- mean(c(R[idx,idx][upper.tri(R[idx,idx],diag=TRUE)],R2[idx])^2)^0.5
+ ## res <- c(res,list("SRMR(endogenous)"=SRMR.endo))
+ ## }
+ }
+ ## if (class(object)[1]=="lvmfit")
+ if (rnkV==ncol(vcov(object)) && (!is.null(minSV) && minSV>1e-12)) {
+
+ rmseafun <- function(...) {
+ epsilon <- function(lambda) sapply(lambda,function(x)
+ ifelse(x>0 & qdf>0,sqrt(x/(qdf*(n))),0)) ## n-1,n vs. n-df
+ opf <- function(l,p) suppressWarnings(p-pchisq(q,df=qdf,ncp=l))
+ ## pchisq(... lower.tail=FALSE)-1
+ alpha <- (1-level)/2
+ RMSEA <- epsilon(q-qdf)
+ B <- max(q-qdf,0)
+ lo <- hi <- list(root=0)
+ if (RMSEA>0 && opf(0,p=1-alpha)<0) {
+ hi <- uniroot(function(x) opf(x,p=1-alpha),c(0,B))
+ }
+ if (opf(B,p=alpha)<0) {
+ lo <- uniroot(function(x) opf(x,p=alpha),c(B,n))
+ }
+ ci <- c(epsilon(c(hi$root,lo$root)))
+ RMSEA <- c(RMSEA=RMSEA,ci);
+ names(RMSEA) <- c("RMSEA",paste0(100*c(alpha,(1-alpha)),"%"))
+ pval <- pchisq(q,qdf,(n*qdf*rmsea.threshold^2),lower.tail=FALSE)
+ res <- list(aa=((q-qdf)/(2*qdf)^0.5),RMSEA=RMSEA, level=level, rmsea.threshold=rmsea.threshold, pval.rmsea=pval)
+ return(res)
+ }
+ rmseaval <- tryCatch(rmseafun(),error=function(e) NULL)
+ res <- c(res,rmseaval)
+ }
+ } else {
+ res <- list(n=n, logLik=loglik, BIC=myBIC, AIC=myAIC)
+ }
+
+ res <- c(res, L2score=l2D, rankV=rnkV, cond=condnum, k=nrow(vcov(object)))
+ class(res) <- "gof.lvmfit"
+ return(res)
+}
+
+##' @export
+print.gof.lvmfit <- function(x,optim=TRUE,...) {
+ if (!is.null(x$n)) {
+ with(x,
+ cat("\n Number of observations =", n, "\n"))
+ }
+ if (is.null(x$fit)) {
+ with(x,
+ cat(" Log-Likelihood =", logLik, "\n"))
+ }
+ with(x, cat(" BIC =", BIC, "\n",
+ "AIC =", AIC, "\n"))
+ if (!is.null(x$fit))
+ with(x,
+ cat(" log-Likelihood of model =", fit$estimate[1], "\n\n",
+ "log-Likelihood of saturated model =", fit$estimate[2], "\n",
+ "Chi-squared statistic: q =", fit$statistic,
+ ", df =", fit$parameter,
+ "\n P(Q>q) =", fit$p.value, "\n"))
+ if (!is.null(x$RMSEA)) {
+ rr <- round(x$RMSEA*10000)/10000
+ rmsea <- paste0(rr[1]," (",rr[2],";",rr[3],")")
+ cat("\n RMSEA (",x$level*100,"% CI): ", rmsea,"\n",sep="")
+ cat(" P(RMSEA<",x$rmsea.threshold,")=", x$pval.rmsea,"\n",sep="")
+ }
+ for (i in c("TLI","CFI","NFI","SRMR","SRMR(endogenous)"))
+ if (!is.null(x[[i]])) cat("", i,"=",x[[i]],"\n")
+
+ if (optim) {
+ cat("\nrank(Information) = ",x$rankV," (p=", x$k,")\n",sep="")
+ cat("condition(Information) = ",x$cond,"\n",sep="")
+ cat("mean(score^2) =",x$L2score,"\n")
+ }
+
+ invisible(x)
+}
+
+
+
+## gof.multigroupfit <- function(object,...) {
+## L0 <- logLik(object); df0 <- attributes(L0)$df
+## L1 <- logLik(object,type="sat"); df1 <- attributes(L1)$df
+
+## df <- df1-df0; names(df) <- "df"
+## Q <- -2*(L0-L1); attributes(Q) <- NULL; names(Q) <- "chisq";
+## pQ <- pchisq(Q,df,lower.tail=FALSE)
+## values <- c(L0,L1); names(values) <- c("log likelihood (model)", "log likelihood (saturated model)")
+## res <- list(statistic = Q, parameter = df,
+## p.value=pQ, method = "Likelihood ratio test",
+## estimate = values)
+## class(res) <- "htest"
+## return(res)
+## }
diff --git a/R/graph.R b/R/graph.R
new file mode 100644
index 0000000..472d619
--- /dev/null
+++ b/R/graph.R
@@ -0,0 +1,49 @@
+##' Extract graph
+##'
+##' Extract or replace graph object
+##'
+##'
+##' @aliases Graph Graph<-
+##' @usage
+##'
+##' Graph(x, ...)
+##'
+##' Graph(x, ...) <- value
+##'
+##' @param x Model object
+##' @param value New \code{graphNEL} object
+##' @param \dots Additional arguments to be passed to the low level functions
+##' @author Klaus K. Holst
+##' @seealso \code{\link{Model}}
+##' @keywords graphs models
+##' @export
+##' @examples
+##'
+##' m <- lvm(y~x)
+##' Graph(m)
+##'
+##' @export
+`Graph` <-
+function(x,...) UseMethod("Graph")
+
+##' @export
+`Graph.lvm` <-
+function(x,add=FALSE,...) {
+ if ((is.null(x$graph) || length(x$graph)==0) & add) {
+ m <- Model(x)
+ return(plot(m,noplot=TRUE))
+ }
+ else return(x$graph)
+}
+
+##' @export
+`Graph.lvmfit` <- function(x,...) Graph.lvm(x,...)
+
+##' @export
+"Graph<-" <- function(x,...,value) UseMethod("Graph<-")
+
+##' @export
+"Graph<-.lvmfit" <- function(x,...,value) { x$graph <- value; return(x) }
+
+##' @export
+"Graph<-.lvm" <- function(x,...,value) { x$graph <- value; return(x) }
diff --git a/R/graph2lvm.R b/R/graph2lvm.R
new file mode 100644
index 0000000..7b3b655
--- /dev/null
+++ b/R/graph2lvm.R
@@ -0,0 +1,12 @@
+##' @export
+`graph2lvm` <-
+function(g, debug=FALSE, silent=TRUE) {
+ res <- lvm(graph::nodes(g), debug=debug,silent=silent)
+ M <- t(as(g, Class="matrix"))
+ for (i in seq_len(nrow(M))) {
+ if (any(M[,i]==1)) {
+ res <- regression(res, rownames(M)[M[,i]==1], rownames(M)[i], silent=silent)
+ }
+ }
+ res
+}
diff --git a/R/heavytail.R b/R/heavytail.R
new file mode 100644
index 0000000..3884e7b
--- /dev/null
+++ b/R/heavytail.R
@@ -0,0 +1,56 @@
+##' @export
+`heavytail` <- function(x,...) UseMethod("heavytail")
+##' @export
+"heavytail<-" <- function(x,...,value) UseMethod("heavytail<-")
+
+##' @export
+"heavytail<-.lvm" <- function(x,...,value) {
+ if (inherits(value,"formula")) {
+ return(heavytail(x,all.vars(value),...))
+ }
+ heavytail(x, value, ...)
+}
+
+##' @export
+`heavytail.lvm` <-
+function(x,var=NULL,df=1,...) {
+ if (is.null(var)) {
+ htidx <- x$attributes$heavytail
+ if (length(htidx)>0 && any(htidx!=0)) {
+ res <- htidx[htidx>0]
+ attributes(res)$couple <- unlist(x$attributes$heavytail.couple)[htidx>0]
+ return(res)
+ }
+ return(NULL)
+ }
+ couples <- attributes(heavytail(x))$couple
+ newval <- 1
+ if (length(couples)>0) newval <- max(couples)+1
+ x$attributes$heavytail.couple[var] <- newval
+ x$attributes$heavytail[var] <- df
+ return(x)
+}
+
+heavytail.init.hook <- function(x,...) {
+ x$attributes$heavytail <- list()
+ x$attributes$heavytail.couple <- list()
+ return(x)
+}
+
+heavytail.sim.hook <- function(x,data,...) {
+ n <- nrow(data)
+ hvar <- heavytail(x)
+ if (length(hvar)==0) return(data)
+ couples <- unique(attributes(hvar)$couple)
+ h.type <- list()
+ for (j in couples)
+ h.type <- c(h.type, list( hvar[(which(attributes(hvar)$couple==j))]))
+ for (i in seq_along(couples)) {
+ df <- hvar[[i]][1]
+ Z <- rchisq(n,df=df)/df
+ for (v in names(h.type[[i]])) {
+ data[,v] <- data[,v]/sqrt(Z)
+ }
+ }
+ return(data)
+}
diff --git a/R/iid.R b/R/iid.R
new file mode 100644
index 0000000..cf1c7b9
--- /dev/null
+++ b/R/iid.R
@@ -0,0 +1,122 @@
+##' Extract i.i.d. decomposition (influence function) from model object
+##'
+##' Extract i.i.d. decomposition (influence function) from model object
+##' @export
+##' @usage
+##'
+##' iid(x,...)
+##'
+##' \method{iid}{default}(x,bread,id=NULL,folds=0,maxsize=(folds>0)*1e6,...)
+##'
+##' @aliases iid.default
+##' @param x model object
+##' @param id (optional) id/cluster variable
+##' @param bread (optional) Inverse of derivative of mean score function
+##' @param folds (optional) Calculate aggregated iid decomposition (0:=disabled)
+##' @param maxsize (optional) Data is split in groups of size up to 'maxsize' (0:=disabled)
+##' @param ... additional arguments
+##' @examples
+##' m <- lvm(y~x+z)
+##' distribution(m, ~y+z) <- binomial.lvm("logit")
+##' d <- sim(m,1e3)
+##' g <- glm(y~x+z,data=d,family=binomial)
+##' crossprod(iid(g))
+##'
+iid <- function(x,...) UseMethod("iid")
+
+##' @export
+iid.default <- function(x,bread,id=NULL,folds=0,maxsize=(folds>0)*1e6,...) {
+ if (!any(paste("score",class(x),sep=".") %in% methods("score"))) {
+ warning("Not available for this class")
+ return(NULL)
+ }
+
+ if (folds>0 || maxsize>0 || (!missing(id) && lava.options()$cluster.index)) {
+ if (!requireNamespace("mets",quietly=TRUE)) stop("Requires 'mets'")
+ }
+
+ if (folds>0) {
+ U <- Reduce("rbind",mets::divide.conquer(function(data) score(x,data=data,...),
+ id=id,
+ data=data,size=round(nrow(data)/folds)))
+ } else {
+ U <- score(x,indiv=TRUE,...)
+ }
+ n <- NROW(U)
+ pp <- pars(x)
+ if (!missing(bread) && is.null(bread)) {
+ bread <- vcov(x)
+ }
+ if (missing(bread)) bread <- attributes(U)$bread
+ if (is.null(bread)) {
+ bread <- attributes(x)$bread
+ if (is.null(bread)) bread <- x$bread
+ if (is.null(bread)) {
+ if (maxsize>0) {
+ ff <- function(p) colSums(Reduce("rbind",mets::divide.conquer(function(data) score(x,data=data,p=p,...),
+ data=data,size=maxsize)))
+ I <- -numDeriv::jacobian(ff,pp,method=lava.options()$Dmethod)
+ } else {
+ I <- -numDeriv::jacobian(function(p) score(x,p=p,indiv=FALSE,...),pp,method=lava.options()$Dmethod)
+ }
+ bread <- Inverse(I)
+ }
+ }
+ iid0 <- U%*%bread
+ if (!missing(id)) {
+ N <- nrow(iid0)
+ if (!lava.options()$cluster.index) {
+ iid0 <- matrix(unlist(by(iid0,id,colSums)),byrow=TRUE,ncol=ncol(bread))
+ } else {
+ iid0 <- mets::cluster.index(id,mat=iid0,return.all=FALSE)
+ }
+ attributes(iid0)$N <- N
+ }
+ colnames(iid0) <- colnames(U)
+ return(structure(iid0,bread=bread))
+}
+
+
+##' @export
+iid.multigroupfit <- function(x,...) iid.default(x,combine=TRUE,...)
+
+##' @export
+iid.matrix <- function(x,...) {
+ p <- ncol(x); n <- nrow(x)
+ mu <- colMeans(x,na.rm=TRUE); S <- var(x,use="pairwise.complete.obs")*(n-1)/n
+ iid1 <- t(t(x)-mu)
+ iid2 <- matrix(ncol=(p+1)*p/2,nrow=n)
+ pos <- 0
+ nn <- c()
+ cc <- mu
+ for (i in seq(p))
+ for (j in seq(i,p)) {
+ pos <- pos+1
+ cc <- c(cc,S[i,j])
+ iid2[,pos] <- (iid1[,i]*iid1[,j])-cc[length(cc)]
+ nn <- c(nn,paste(colnames(x)[c(i,j)],collapse=lava.options()$symbols[2]))
+ }
+ colnames(iid1) <- colnames(x); colnames(iid2) <- nn
+ names(cc) <- c(colnames(iid1),colnames(iid2))
+ iid1[is.na(iid1)] <- 0
+ iid2[is.na(iid2)] <- 0
+ structure(cbind(iid1/n,iid2/n),
+ coef=cc,
+ mean=mu, var=S)
+}
+
+##' @export
+iid.numeric <- function(x,...) {
+ n <- length(x)
+ mu <- mean(x); S <- var(x)*(n-1)/n
+ iid1 <- t(t(x)-mu)
+ structure(cbind(mean=iid1/n,var=(iid1^2-S)/n),coef=c(mean=mu,var=S),mean=mu,var=S)
+}
+
+
+##' @export
+iid.data.frame <- function(x,...) {
+ if (!all(apply(x[1,,drop=FALSE],2,function(x) inherits(x,c("numeric","integer")))))
+ stop("Don't know how to handle data.frames of this type")
+ iid(as.matrix(x))
+}
diff --git a/R/img.R b/R/img.R
new file mode 100644
index 0000000..09581bc
--- /dev/null
+++ b/R/img.R
@@ -0,0 +1,128 @@
+img <- function(x,idx,col=list(gray.colors(10,1,0.2)),
+ ylab="Item",xlab="Subject",lab=TRUE,
+ border=1,rowcol=FALSE,plotfun=NULL,
+ axis1=TRUE,axis2=TRUE,yaxs="r",xaxs="r",cex.axis=0.4,...) {
+ x0 <- seq(nrow(x))
+ y0 <- seq(ncol(x))
+ image(x=x0,y=y0,as.matrix(x),col=col[[1]],axes=FALSE,ylab=ylab,xlab=xlab,xaxs=xaxs,yaxs=yaxs,...)
+ if (axis1) {
+ axis(1,at=seq(nrow(x)),lwd=0.5,cex.axis=cex.axis,las=3)
+ if (lab) suppressWarnings(title("",xlab=xlab,...))
+ }
+ if (axis2) {
+ axis(2,at=seq(ncol(x)),lwd=0.5,cex.axis=cex.axis,las=1)
+ if (lab) suppressWarnings(title("",ylab=ylab,...))
+ }
+ if (!is.null(plotfun)) {
+ plotfun(...)
+ }
+ if (!missing(idx)) {
+ if (rowcol) {
+ for (i in seq_len(length(idx)))
+ image(x=x0,y=idx[[i]],as.matrix(x[,idx[[i]]]),col=col[[i]],add=TRUE,xaxs=xaxs,yaxs=yaxs,...)
+ } else
+ for (i in seq_len(length(idx)))
+ image(x=idx[[i]],y=y0,as.matrix(x[idx[[i]],]),col=col[[i]],add=TRUE,xaxs=xaxs,yaxs=yaxs,...)
+ }
+}
+
+
+
+##' Visualize categorical by group variable
+##'
+##' @title Organize several image calls (for visualizing categorical data)
+##' @param x data.frame or matrix
+##' @param group group variable
+##' @param ncol number of columns in layout
+##' @param byrow organize by row if TRUE
+##' @param colorbar Add color bar
+##' @param colorbar.space Space around color bar
+##' @param label.offset label offset
+##' @param order order
+##' @param colorbar.border Add border around color bar
+##' @param main Main title
+##' @param rowcol switch rows and columns
+##' @param plotfun Alternative plot function (instead of 'image')
+##' @param axis1 Axis 1
+##' @param axis2 Axis 2
+##' @param mar Margins
+##' @param col Colours
+##' @param ... Additional arguments to lower level graphics functions
+##' @author Klaus Holst
+##' @examples
+##' X <- matrix(rbinom(400,3,0.5),20)
+##' group <- rep(1:4,each=5)
+##' images(X,colorbar=0,zlim=c(0,3))
+##' images(X,group=group,zlim=c(0,3))
+##' \dontrun{
+##' images(X,group=group,col=list(RColorBrewer::brewer.pal(4,"Purples"),
+##' RColorBrewer::brewer.pal(4,"Greys"),
+##' RColorBrewer::brewer.pal(4,"YlGn"),
+##' RColorBrewer::brewer.pal(4,"PuBuGn")),colorbar=2,zlim=c(0,3))
+##' }
+##' images(list(X,X,X,X),group=group,zlim=c(0,3))
+##' images(list(X,X,X,X),ncol=1,group=group,zlim=c(0,3))
+##' images(list(X,X),group,axis2=c(FALSE,FALSE),axis1=c(FALSE,FALSE),
+##' mar=list(c(0,0,0,0),c(0,0,0,0)),yaxs="i",xaxs="i",zlim=c(0,3))
+##' @export
+images <- function(x,group,ncol=2,byrow=TRUE,colorbar=1,colorbar.space=0.1,label.offset=0.02,
+ order=TRUE,colorbar.border=0,main,rowcol=FALSE,plotfun=NULL,
+ axis1,axis2,mar,
+ col=list(c("#EFF3FF", "#BDD7E7", "#6BAED6", "#2171B5"),
+ c("#FEE5D9", "#FCAE91", "#FB6A4A", "#CB181D"),
+ c("#EDF8E9", "#BAE4B3", "#74C476", "#238B45"),
+ c("#FEEDDE", "#FDBE85", "#FD8D3C", "#D94701")),
+ ...) {
+ if (is.data.frame(x) || is.matrix(x)) x <- list(x)
+ K <- length(x)
+ lout <- matrix(seq(K),ncol=ncol,byrow=byrow)
+ hei <- rep(1,nrow(lout))/nrow(lout)
+ wid <- rep(1,ncol)/ncol
+ if (colorbar==1) {
+ wid <- c(rep(1,ncol)/ncol*(1-colorbar.space),colorbar.space)
+ lout <- cbind(lout,K+1)
+ }
+ if (colorbar==2) {
+ hei <- c(rep(1,nrow(lout))/nrow(lout)*(1-colorbar.space),colorbar.space)
+ lout <- rbind(lout,K+1)
+ }
+ if (missing(group)) {
+ group <- rep(1,nrow(x[[1]]))
+ }
+ if (missing(main)) main <- rep("",K)
+ if (!is.list(col)) col <- list(col)
+ group <- factor(group)
+ idxs <- lapply(levels(group), function(x) which(group==x))
+ layout(lout,widths=wid,heights=hei)
+ ##if (missing(mar)) par(mar=c(4,4,3,0))
+ if (missing(axis2)) axis2 <- c(TRUE,rep(FALSE,K-1))
+ if (missing(axis1)) axis1 <- rep(TRUE,K)
+ for (i in seq(length(x))) {
+## if (!missing(mar)) par(mar=mar[[i]])
+ img(x[[i]],idxs,col,axis2=axis2[i],axis1=axis1[i],main=main[i],rowcol=rowcol,plotfun=plotfun[[i]],...)
+## if (missing(mar)) par(mar=c(4,2,3,2))
+ }
+ G <- nlevels(group)
+ M <- length(col[[1]])
+ if (colorbar==1) {
+ par(mar=c(0,0,0,2))
+ plot.new(); plot.window(xlim=c(0,1),ylim=c(0,1))
+ for (i in seq(G)) {
+ lava::colorbar(col[[i]],values=seq(M)-1,direction="horizontal",
+ y.range=c(1-i/(G+1),1-i/(G+1)+label.offset),
+ border=colorbar.border,x.range=c(0,1),srt=0,cex=0.6)
+ text(0.5,1-i/(G+1)-label.offset, levels(group)[i])
+ }
+ }
+ if (colorbar==2) {
+ par(mar=c(0,0,0,0))
+ plot.new(); plot.window(xlim=c(0,1),ylim=c(0,1))
+ for (i in seq(G)) {
+ xr <- c(1-i/(G+1),1-i/(G+1)+.1)-.1/2
+ lava::colorbar(col[[i]],values=seq(M)-1,direction="horizontal",
+ x.range=xr,
+ border=colorbar.border,y.range=c(0.3,0.5),srt=0,cex=0.6)
+ text(mean(xr),.1, levels(group)[i])
+ }
+ }
+}
diff --git a/R/index.sem.R b/R/index.sem.R
new file mode 100644
index 0000000..6f4c9fd
--- /dev/null
+++ b/R/index.sem.R
@@ -0,0 +1,303 @@
+##' @export
+updatelvm <- function(x,mean=TRUE,...) {
+ index(x) <- reindex(x,mean=mean,...)
+ x$parpos <- parpos(x,mean=mean,...)
+ return(x)
+}
+
+##' @export
+"index" <- function(x,...) UseMethod("index")
+
+##' @export
+"index<-" <- function(x,...,value) UseMethod("index<-")
+
+##' @export
+"index.lvm" <- function(x,...) { x$index }
+
+##' @export
+"index.lvmfit" <- function(x,...) { index(Model(x)) }
+
+##' @export
+"index<-.lvm" <- function(x,...,value) { x$index <- value; return(x) }
+
+##' @export
+"index<-.lvmfit" <- function(x,...,value) { Model(x)$index <- value; return(x) }
+
+
+### A ## Matrix with fixed parameters and ones where parameters are free
+### J ## Manifest variable selection matrix
+### M0 ## Index of free regression parameters
+### M1 ## Index of free and _unique_ regression parameters
+### P ## Matrix with fixed variance parameters and ones where parameters are free
+### P0 ## Index of free variance parameters
+### P1 ## Index of free and _unique_ regression parameters
+### npar.var ## Number of covariance parameters
+##' @export
+`reindex` <-
+function(x, sparse=FALSE,standard=TRUE,zeroones=FALSE,deriv=FALSE,mean=TRUE) { ## Extract indices of parameters from model
+ x$parpos <- NULL
+ M <- x$M
+
+ eta <- latent(x) ## Latent variables/Factors
+ m <- length(eta)
+ obs <- manifest(x) ## Manifest/Observed variables
+ endo <- endogenous(x)
+ exo <- exogenous(x) ##,index=FALSE)
+
+ allvars <- vars(x)
+ eta.idx <- na.omit(match(eta,allvars))
+ obs.idx <- na.omit(match(obs,allvars))
+ exo.idx <- na.omit(match(exo,allvars))
+ exo.obsidx <- na.omit(match(exo,obs))
+ endo.obsidx <- na.omit(match(endo,obs))
+
+ fix.idx <- !is.na(x$fix) ## Index of fixed parameters
+ covfix.idx <- !is.na(x$covfix) ## Index of fixed covariance parameters
+
+ constrain.par <- NULL
+ if (length(constrain(x))>0) constrain.par <- names(constrain(x))
+
+ M0 <- M; M0[fix.idx] <- 0 ## Matrix of indicators of free regression-parameters (removing fixed parameters)
+ M1 <- M0; ## Matrix of indiciator of free _unique_ regression parameters (removing fixed _and_ duplicate parameters)
+ parname <- unique(x$par[!is.na(x$par)])
+## parname.all <- unique(x$par[!is.na(x$par)])
+## parname <- setdiff(parname.all,constrain.par)
+ for (p in parname) {
+ ii <- which(x$par==p)
+ if (length(ii)>1)
+ M1[ii[-1]] <- 0
+ if (p %in% constrain.par)
+ M0[ii] <- M1[ii] <- 0
+ }
+ npar.reg <- sum(M1) ## Number of free regression parameters
+
+ P <- x$cov;
+
+ P0 <- P; P0[covfix.idx] <- 0 ## Matrix of indicators of free covariance-parameters (removing fixed parameters)
+ if (length(exo.idx)>0)
+ P0[exo.idx,exo.idx] <- 0 ## 6/1-2011
+ P1 <- P0 ## Matrix of indiciator of free _unique_ variance parameters (removing fixed _and_ duplicate parameters)
+ covparname <- unique(x$covpar[!is.na(x$covpar)])
+ for (p in covparname) {
+ ii <- which(x$covpar==p)
+ if (length(ii)>1)
+ P1[ii[-1]] <- 0
+ if (p%in%c(parname,constrain.par))
+ P0[ii] <- P1[ii] <- 0
+ }
+
+ ## P1. <- P1[-exo.idx,-exo.idx]
+ npar.var <- sum(c(diag(P1),P1[lower.tri(P1)]))
+ parnames <- paste0("p", seq_len(npar.reg+npar.var))
+
+ A <- M
+ A[fix.idx] <- x$fix[fix.idx] ## ... with fixed parameters in plac
+ P[covfix.idx] <- x$covfix[covfix.idx] ## ... with fixed parameters in plac
+
+
+ px <- Jy <- J <- I <- diag(nrow=length(vars(x)))
+ if (m>0) {
+ J[eta.idx,eta.idx] <- 0; J <- J[-eta.idx,,drop=FALSE]
+ } ## Selection matrix (selecting observed variables)
+ {
+ ## Selection matrix (selection endogenous variables)
+ if (length(c(eta.idx,exo.idx))>0) {
+ Jy[c(eta.idx,exo.idx),c(eta.idx,exo.idx)] <- 0; Jy <- Jy[-c(eta.idx,exo.idx),,drop=FALSE]
+ }
+ ## Cancelation matrix (cancels rows with exogenous variables)
+ px[exo.idx,exo.idx] <- 0
+ }
+
+ ## Creating indicitor of free mean-parameters
+ fixed <- sapply(x$mean, function(y) is.numeric(y) & !is.na(y))
+ named <- sapply(x$mean, function(y) is.character(y) & !is.na(y))
+ mparname <- NULL
+ if (length(named)>0)
+ mparname <- unlist(unique(x$mean[named]))
+ v0 <- rep(1,length(x$mean)) ## Vector of indicators of free mean-parameters
+
+ v0[exo.idx] <- 0
+ if (length(fixed)>0) v0[fixed] <- 0;
+ v1 <- v0
+ for (p in mparname) {
+ idx <- which(x$mean==p)
+ if (length(idx)>1) {
+## print(idx[-1])
+ v1[idx[-1]] <- 0
+ }
+ if (p%in%c(parname,covparname,constrain.par))
+ v0[idx] <- v1[idx] <- 0
+ } ## duplicate parameters
+
+ ###
+ ### Extra parameters
+ ###
+ efixed <- sapply(x$exfix, function(y) is.numeric(y) & !is.na(y))
+ enamed <- sapply(x$exfix, function(y) is.character(y) & !is.na(y))
+ if(length(enamed)>0){
+ eparname <- unlist(unique(x$exfix[enamed]))
+ } else{
+ eparname <- NULL
+ }
+ ## Extra parameters
+ e0 <- rep(1,length(x$expar)) ## Indicators of free extra par.
+ if (length(efixed)>0)
+ e0[efixed] <- 0
+ e1 <- e0
+ for (p in eparname) {
+ idx <- which(x$exfix==p)
+ if (length(idx)>1) {
+ e1[idx[-1]] <- 0
+ }
+ if (p%in%c(parname,covparname,constrain.par,mparname))
+ e0[idx] <- e1[idx] <- 0
+ } ## duplicate parameters
+
+
+ ## Return:
+ ## Adjacency-matrix (M)
+ ## Matrix of regression-parameters (0,1) _with_ fixed parameters (A)
+ ## Matrix of variance-parameters (indicators 0,1) (P)
+ ## Manifest selection matrix (J),
+ ## Position of variables matrix (Apos),
+ ## Position of covariance variables matrix (Ppos),
+ ## Position/Indicator matrix of free regression parameters (M0)
+ res <- list(vars=allvars, manifest=obs, exogenous=exo, latent=eta,
+ endogenous=endo,
+ exo.idx=exo.idx, eta.idx=eta.idx,
+ exo.obsidx=exo.obsidx, endo.obsidx=endo.obsidx,
+ obs.idx=obs.idx,
+ endo.idx=setdiff(obs.idx,exo.idx))
+
+ if (standard) {
+ res <- c(res, list(M=M, A=A, P=P,
+ P0=P0, P1=P1,
+ M0=M0, M1=M1,
+ v0=v0, v1=v1,
+ e0=e0, e1=e1,
+ npar=(npar.reg+npar.var),
+ npar.reg=npar.reg,
+ npar.var=npar.var,
+ npar.mean=sum(v1),
+ npar.ex=sum(e1),
+ constrain.par=constrain.par))
+ npar.total <- res$npar+res$npar.mean+res$npar.ex
+ which.diag <- NULL
+ if (length(P1)>0)
+ which.diag <- which(diag(P1==1))
+
+ res <- c(res, list(parname.all=parname, parname=setdiff(parname,constrain.par),
+ which.diag=which.diag,
+ covparname.all=covparname,
+ covparname=setdiff(covparname,constrain.par),
+ meanfixed=fixed, meannamed=named,
+ mparname.all=mparname,
+ mparname=setdiff(mparname,constrain.par),
+ eparname.all=eparname,
+ eparname=setdiff(eparname,constrain.par),
+ J=J, Jy=Jy, px=px, sparse=sparse))
+
+ parname.all.reg.idx <- parname.all.reg.tidx <-
+ parname.reg.tidx <- parname.reg.idx <- c()
+ for (p in res$parname.all) {
+ ipos <- which((x$par==p))
+ tipos <- which(t(x$par==p))
+ if (p%in%res$parname) {
+ parname.reg.idx <- c(parname.reg.idx, list(ipos))
+ parname.reg.tidx <- c(parname.reg.tidx, list(tipos))
+ }
+ parname.all.reg.idx <- c(parname.all.reg.idx, list(ipos))
+ parname.all.reg.tidx <- c(parname.all.reg.tidx, list(tipos))
+ };
+ if (length(parname.reg.idx)>0) {
+ names(parname.reg.idx) <- names(parname.reg.tidx) <- res$parname
+ }
+ if (length(parname.all.reg.idx)>0) {
+ names(parname.all.reg.idx) <- names(parname.all.reg.tidx) <- res$parname.all
+ }
+ covparname.all.idx <- covparname.idx <- c()
+ for (p in res$covparname.all) {
+ ipos <- which(x$covpar==p)
+ if (p%in%res$covparname)
+ covparname.idx <- c(covparname.idx, list(ipos))
+ covparname.all.idx <- c(covparname.all.idx, list(ipos))
+ };
+ if (length(covparname.idx)>0)
+ names(covparname.idx) <- res$covparname
+ if (length(covparname.all.idx)>0)
+ names(covparname.all.idx) <- res$covparname.all
+
+ mparname.all.idx <- mparname.idx <- c()
+ for (p in res$mparname.all) {
+ ipos <- which(x$mean==p)
+ if (p%in%mparname)
+ mparname.idx <- c(mparname.idx, list(ipos))
+ mparname.all.idx <- c(mparname.all.idx, list(ipos))
+ };
+ if (length(mparname.idx)>0)
+ names(mparname.idx) <- res$mparname
+ if (length(mparname.all.idx)>0)
+ names(mparname.all.idx) <- res$mparname.all
+
+ eparname.all.idx <- eparname.idx <- c()
+ for (p in res$eparname.all) {
+ ipos <- which(x$exfix==p)
+ if (p%in%eparname)
+ eparname.idx <- c(eparname.idx, list(ipos))
+ eparname.all.idx <- c(eparname.all.idx, list(ipos))
+ };
+ if (length(eparname.idx)>0)
+ names(eparname.idx) <- res$eparname
+ if (length(eparname.all.idx)>0)
+ names(eparname.all.idx) <- res$eparname.all
+
+
+ res <- c(res, list(mparname.idx=mparname.idx,
+ covparname.idx=covparname.idx,
+ parname.reg.idx=parname.reg.idx,
+ parname.reg.tidx=parname.reg.tidx,
+ mparname.all.idx=mparname.all.idx,
+ eparname.all.idx=eparname.all.idx,
+ covparname.all.idx=covparname.all.idx,
+ parname.all.reg.idx=parname.all.reg.idx,
+ parname.all.reg.tidx=parname.all.reg.tidx
+ ))
+
+ } else {
+ res <- index(x)
+ }
+
+ if (zeroones) {
+ if (sparse) {
+ if (!requireNamespace("Matrix",quietly=TRUE)) stop("package Matrix not available")
+ Ik <- Matrix::Diagonal(length(obs))
+ Im <- Matrix::Diagonal(ncol(A))
+ Kkk <- NULL
+ J <- as(J, "sparseMatrix")
+ Jy <- as(Jy, "sparseMatrix")
+ px <- as(px, "sparseMatrix")
+
+ } else {
+ Ik <- diag(nrow=length(obs))
+ Im <- diag(nrow=ncol(A))
+ }
+ Kkk <- NULL
+
+
+ res[c("Ik","Im","Kkk")] <- NULL
+ res <- c(res, list(Ik=Ik, Im=Im, Kkk=Kkk))
+ }
+ if (deriv && length(P)>0) {
+ if (res$npar.mean>0 & mean)
+ D <- deriv.lvm(x,meanpar=rep(1,res$npar.mean),zeroones=TRUE)
+ else
+ D <- deriv.lvm(x,meanpar=NULL,zeroones=TRUE)
+ res[c("dA","dP","dv")] <- NULL
+ res <- c(res, list(dA=D$dA, dP=D$dP, dv=D$dv))
+ }
+
+ if (length(P)>0)
+ res <- c(res,mat.lvm(x,res))
+
+ return(res)
+}
diff --git a/R/information.R b/R/information.R
new file mode 100644
index 0000000..a409bf8
--- /dev/null
+++ b/R/information.R
@@ -0,0 +1,235 @@
+##' @export
+`information` <-
+function(x,...) UseMethod("information")
+
+###{{{ information.lvm
+
+##' @export
+information.lvm <- function(x,p,n,type=ifelse(model=="gaussian",
+ c("E","hessian","varS","outer","sandwich","robust","num"),"outer"),
+ data,weights=NULL,
+ data2=NULL,
+ model="gaussian",
+ method=lava.options()$Dmethod,
+ inverse=FALSE, pinv=TRUE,
+ score=TRUE,...) {
+ if (missing(n))
+ n <- NROW(data)
+ if (type[1]%in%c("sandwich","robust")) {
+ cl <- match.call()
+ cl$inverse <- !inverse
+ cl$type <- "outer"
+ A <- eval.parent(cl)
+ cl$inverse <- !(cl$inverse)
+ cl$type <- ifelse(type[1]=="sandwich","E","hessian")
+ B <- eval.parent(cl)
+ return(B%*%A%*%B)
+ }
+ if (type[1]%in%c("num","hessian","obs","observed") | (type[1]%in%c("E","hessian") & model!="gaussian")) {
+ ## requireNamespace("numDeriv")
+ myf <- function(p0) score(x, p=p0, model=model,data=data, weights=weights,data2=data2,indiv=FALSE,n=n) ##...)
+ ## I <- -hessian(function(p0) logLik(x,p0,dd),p)
+ I <- -numDeriv::jacobian(myf,p,method=method)
+ res <- (I+t(I))/2 # Symmetric result
+ if (inverse) {
+ if (pinv)
+ iI <- Inverse(res)
+ else
+ iI <- solve(res)
+ return(iI)
+ }
+ return(res)
+ }
+ if (type[1]=="varS" | type[1]=="outer") {
+ S <- score(x,p=p,data=na.omit(data),model=model,weights=weights,data2=data2,indiv=TRUE,...)
+ ## print("...")
+ res <- t(S)%*%S
+ if (inverse) {
+ if (pinv)
+ iI <- Inverse(res)
+ else
+ iI <- solve(res)
+ return(iI)
+ }
+ attributes(res)$grad <- colSums(S)
+ return(res)
+ }
+
+ if (n>1) {
+ xfix <- colnames(data)[(colnames(data)%in%parlabels(x,exo=TRUE))]
+ xconstrain <- intersect(unlist(lapply(constrain(x),function(z) attributes(z)$args)),manifest(x))
+
+ if (length(xfix)>0 | length(xconstrain)>0) { ##### Random slopes!
+ x0 <- x
+ if (length(xfix)>0) {
+ nrow <- length(vars(x))
+ xpos <- lapply(xfix,function(y) which(regfix(x)$labels==y))
+ colpos <- lapply(xpos, function(y) ceiling(y/nrow))
+ rowpos <- lapply(xpos, function(y) (y-1)%%nrow+1)
+ myfix <- list(var=xfix, col=colpos, row=rowpos)
+ for (i in seq_along(myfix$var))
+ for (j in seq_along(myfix$col[[i]]))
+ regfix(x0, from=vars(x0)[myfix$row[[i]]][j],to=vars(x0)[myfix$col[[i]]][j]) <-
+ data[1,myfix$var[[i]]]
+ index(x0) <- reindex(x0,zeroones=TRUE,deriv=TRUE)
+ }
+ pp <- modelPar(x0,p)
+ p0 <- with(pp, c(meanpar,p,p2))
+ k <- length(index(x)$manifest)
+ myfun <- function(ii) {
+ if (length(xfix)>0)
+ for (i in seq_along(myfix$var)) {
+ for (j in seq_along(myfix$col[[i]])) {
+ index(x0)$A[cbind(myfix$row[[i]],myfix$col[[i]])] <- data[ii,myfix$var[[i]]]
+ }
+ }
+ ww <- NULL
+ if (!is.null(weights))
+ ww <- weights[ii,]
+ return(information(x0,p=p,n=1,type=type,weights=ww,data=data[ii,]))
+ }
+ L <- lapply(seq_len(nrow(data)),function(y) myfun(y))
+ val <- apply(array(unlist(L),dim=c(length(p0),length(p0),nrow(data))),c(1,2),sum)
+ if (inverse) {
+ if (pinv)
+ iI <- Inverse(val)
+ else
+ iI <- solve(val)
+ return(iI)
+ }
+ return(val)
+ }
+ }
+
+ if (!is.null(weights) && is.matrix(weights)) {
+ L <- lapply(seq_len(nrow(weights)),function(y) information(x,p=p,n=1,type=type,weights=weights[y,]))
+ val <- apply(array(unlist(L),dim=c(length(p),length(p),nrow(weights))),c(1,2),sum)
+ if (inverse) {
+ if (pinv)
+ iI <- Inverse(val)
+ else
+ iI <- solve(val)
+ return(iI)
+ }
+ return(val)
+ }
+ mp <- moments(x,p,data=data)
+ pp <- modelPar(x,p)
+ D <- deriv.lvm(x, meanpar=pp$meanpar, mom=mp, p=p)##, all=length(constrain(x))>0)
+ C <- mp$C
+ iC <- Inverse(C,det=FALSE, symmetric = TRUE)
+
+ if (is.null(weights)) {
+ ## W <- diag(ncol(iC))
+ } else {
+ if (length(weights)<ncol(iC)) {
+ oldweights <- weights
+ weights <- rbind(rep(1,ncol(iC))) ## Ones at exogenous var.
+ idx <- index(x)$vars%in%index(x)$exogenous
+ print(idx); print(oldweights)
+ weights[,idx] <- oldweights
+ }
+ W <- diag(nrow=as.numeric(weights))
+ iW <- W
+ diag(iW) <- 1/diag(iW)
+ }
+
+ if (is.null(weights)) {
+ ## information_Sigma <- n/2*t(D$dS)%*%((iC)%x%(iC))%*%(D$dS)
+ if (lava.options()$devel) {
+ information_Sigma <- matrix(0,length(p),length(p))
+ imean <- with(index(x)$parBelongsTo,mean)
+ information_Sigma[-imean,-imean] <- n/2*t(D$dS[,-imean])%*%kronprod(iC,iC,D$dS[,-imean])
+ } else {
+ information_Sigma <- n/2*t(D$dS)%*%kronprod(iC,iC,D$dS)
+ }
+ } else {
+ ## information_Sigma <- n/2*t(D$dS)%*%((iC)%x%(iC%*%W))%*%(D$dS)
+ information_Sigma <- n/2*t(D$dS)%*%kronprod(iC,iC%*%W,D$dS)
+ }
+
+ dxi <- D$dxi;
+
+ if (!any(dxi>0)) { ##is.null(pp$meanpar) && is.null(pp$p2)) {
+ if (inverse) {
+ if (pinv)
+ iI <- Inverse(information_Sigma)
+ else
+ iI <- solve(information_Sigma)
+ return(iI)
+ }
+ return(information_Sigma)
+ }
+ ii <- index(x)
+ if (is.null(weights)) {
+ information_mu <- n*t(dxi) %*% (iC) %*% (dxi)
+ } else {
+ information_mu <- n*t(dxi) %*% (iC%*%W) %*% (dxi)
+ }
+
+ if (!(lava.options()$devel)) {
+ information <- information_Sigma+information_mu
+ } else {
+ mparidx <- with(ii$parBelongsTo,c(mean,reg))
+ information <- information_Sigma
+ information[mparidx,mparidx] <- information[mparidx,mparidx] + information_mu
+ }
+
+ if (inverse) {
+ if (pinv)
+ iI <- Inverse(information, symmetric = TRUE)
+ else
+ iI <- solve(information)
+ return(iI)
+ }
+ return(information)
+}
+
+###}}} information.lvm
+
+###{{{ information.lvmfit
+
+##' @export
+information.lvmfit <- function(x,p=pars(x),n=x$data$n,data=model.frame(x),model=x$estimator,weights=Weights(x),
+ data2=x$data$data2,
+ ...) {
+ I <- information(x$model0,p=p,n=n,data=data,model=model,
+ weights=weights,data2=data2,...)
+ if (ncol(I)<length(p)) {
+ I <- blockdiag(I,matrix(0,length(p)-ncol(I),length(p)-ncol(I)))
+ }
+ return(I)
+}
+
+###}}} information.lvmfit
+
+
+##' @export
+information.lvm.missing <- function(x,
+ p=coef(x), estimator=x$estimator,
+ weights=Weights(x$estimate),
+ ...) {
+ information(x$estimate$model0, p=p, model=estimator, weights=weights,...)
+}
+
+##' @export
+information.multigroupfit <- function(x,p=pars(x), weights=Weights(x), estimator=x$estimator, ...) {
+ information(x$model0,p=p, weights=weights, model=estimator ,...)
+}
+
+##' @export
+information.multigroup <- function(x,data=x$data,weights=NULL,p,indiv=FALSE,...) {
+ rm <- procrandomslope(x)
+ pp <- with(rm, modelPar(model,p)$p)
+ parord <- modelPar(rm$model,seq_len(with(rm$model,npar+npar.mean)))$p
+ I <- matrix(0,nrow=length(p),ncol=length(p))
+ if (!indiv) {
+ for (i in seq_len(x$ngroup))
+ I[parord[[i]],parord[[i]]] <- I[parord[[i]],parord[[i]]] + information(x$lvm[[i]],p=pp[[i]],data=data[[i]],weights=weights[[i]],...)
+ } else {
+ I <- list()
+ for (i in seq_len(x$ngroup))
+ I <- c(I, list(information(x$lvm[[i]],p=pp[[i]],data=data[[i]],weights=weights[[i]],...)))
+ }
+ return(I)
+}
diff --git a/R/interactive.R b/R/interactive.R
new file mode 100644
index 0000000..443f163
--- /dev/null
+++ b/R/interactive.R
@@ -0,0 +1,106 @@
+##' @export
+colsel <- function(locate,...) {
+ ytop <- rep(seq(1/26,1,by=1/26),each=26)[1:657]
+ ybottom <- rep(seq(0,1-1/26,by=1/26),each=26)[1:657]
+ xleft <- rep(seq(0,1-1/26,by=1/26),times=26)[1:657]
+ xright <- rep(seq(1/26,1,by=1/26),times=26)[1:657]
+ pall <- round(col2rgb(colors())/256)
+ pall <- colSums(pall) ; pall2 <- character(0)
+ pall2[pall>0] <- "black"
+ pall2[pall==0] <- "white"
+
+ par(mar=c(0,0,1,0))
+
+ plot.new()
+ title(main="Palette of colors()")
+ rect(xleft,ybottom,xright,ytop,col=colors())
+ text(x=xleft+((1/26)/2)
+ ,y=ytop-((1/26)/2)
+ ,labels = 1:657
+ ,cex=0.55
+ ,col=pall2)
+
+ if (missing(locate)) return(invisible(NULL))
+ colmat <- matrix(c(1:657,rep(NA,26^2-657)),byrow=T,ncol=26,nrow=26)
+ cols <- NA
+ for(i in seq_len(locate))
+ {
+ h <- locator(1)
+ if(any(h$x<0,h$y<0,h$x>1,h$y>1)) stop("locator out of bounds!")
+ else {
+ cc <- floor(h$x/(1/26))+1
+ rr <- floor(h$y/(1/26))+1
+ cols[i] <- colors()[colmat[rr,cc]]
+ }
+ }
+ return(cols)
+}
+
+
+##' Extension of the \code{identify} function
+##'
+##' For the usual 'X11' device the identification process is
+##' terminated by pressing any mouse button other than the first. For
+##' the 'quartz' device the process is terminated by pressing either
+##' the pop-up menu equivalent (usually second mouse button or
+##' 'Ctrl'-click) or the 'ESC' key.
+##' @title Identify points on plot
+##' @usage
+##' \method{click}{default}(x, y=NULL, label=TRUE, n=length(x), pch=19, col="orange", cex=3, ...)
+##' idplot(x,y,...,id=list())
+##' @aliases idplot click.default click colsel
+##' @param x X coordinates
+##' @param y Y coordinates
+##' @param label Should labels be added?
+##' @param n Max number of inputs to expect
+##' @param pch Symbol
+##' @param col Colour
+##' @param cex Size
+##' @param id List of arguments parsed to \code{click} function
+##' @param \dots Additional arguments parsed to \code{plot} function
+##' @author Klaus K. Holst
+##' @seealso \code{\link{idplot}}, \code{identify}
+##' @examples
+##' if (interactive()) {
+##' n <- 10; x <- seq(n); y <- runif(n)
+##' plot(y ~ x); click(x,y)
+##'
+##' data(iris)
+##' l <- lm(Sepal.Length ~ Sepal.Width*Species,iris)
+##' res <- plotConf(l,var2="Species")## ylim=c(6,8), xlim=c(2.5,3.3))
+##' with(res, click(x,y))
+##'
+##' with(iris, idplot(Sepal.Length,Petal.Length))
+##' }
+##' @keywords iplot
+##' @export
+click <- function(x,...){
+ UseMethod("click")
+}
+
+##' @export
+click.default <-
+function(x, y=NULL, label=TRUE, n=length(x), pch=19, col="orange", cex=3, ...)
+ {
+ xy <- xy.coords(x, y); x <- xy$x; y <- xy$y
+ sel <- rep(FALSE, length(x)); res <- integer(0)
+ while(sum(sel) < n) {
+ ans <- identify(x[!sel], y[!sel], n=1, plot=FALSE, ...)
+ if(!length(ans)) break
+ ans <- which(!sel)[ans]
+ points(x[ans], y[ans], pch = pch, col=col, cex=cex)
+ if (label)
+ text(x[ans], y[ans], ans)
+ sel[ans] <- TRUE
+ res <- c(res, ans)
+ }
+ res
+
+ }
+
+##' @export
+idplot <- function(x,y,...,id=list()) {
+ plot(x,y,...)
+ id$x <- x; id$y <- y
+ do.call("click",id)
+}
diff --git a/R/iv.R b/R/iv.R
new file mode 100644
index 0000000..afccd1e
--- /dev/null
+++ b/R/iv.R
@@ -0,0 +1,323 @@
+###{{{ Objective
+
+IV_method.lvm <- NULL
+IV_objective.lvm <- function(x,p,data,...) {
+ IV2(x,data,...)
+}
+IV_variance.lvm <- function(x,p,data,opt,...) {
+ opt$vcov
+}
+
+IV0_method.lvm <- NULL
+IV0_objective.lvm <- function(x,p,data,...) {
+ IV2(x,data,type="non-robust",...)
+}
+IV0_variance.lvm <- function(x,p,data,opt,...) {
+ opt$vcov
+}
+
+IV1_method.lvm <- NULL
+IV1_objective.lvm <- function(x,p,data,...) {
+ IV(x,data)
+}
+IV1_variance.lvm <- function(x,p,data,opt,...) {
+ opt$vcov
+}
+
+###}}} Objective
+
+CondVar <- function(S,idx) {
+ idx2 <- setdiff(seq_len(ncol(S)),idx)
+ S11 <- S[idx2,idx2];
+ S22 <- S[idx,idx]
+ S12 <- S[idx2,idx]
+ S11-S12%*%solve(S22)%*%t(S12)
+}
+
+varest <- function(x,data) {
+ p <- IV(x,data)$estimate
+ idx <- match(names(p),coef(x,mean=TRUE))
+ x0 <- parfix(Model(x),idx,p)
+ index(x0) <- reindex(x0,zeroones=TRUE,deriv=TRUE)
+
+ A <- t(index(x)$A)
+ Afix <- A; Afix[t(index(x)$M0)==1] <- 0
+ A[A!=0] <- 1
+ k <- nrow(A)
+ I <- diag(nrow=k)
+ Ap <- modelVar(x)$A ## Estimated parameter matrix
+
+ indicators <- setdiff(vars(x)[rowSums(A)==1],exogenous(x))
+ responses <- endogenous(x,top=TRUE)
+ y.indicators <- responses[rowSums(A[responses,])==1]
+ Sigma <- var(data[,manifest(x)])
+
+ var.eta <- c()
+ for (eta in latent(x)) {
+ m.sub <- subset(Model(x),c(eta,indicators))
+ reachable <- acc(x$M,eta)
+ ys <- intersect(names(reachable),y.indicators)
+ lambdas <- c()
+ for (y in ys) {
+ pp <- path(Model(x), from=eta, to=y)
+ lambda1 <- 0
+ for (i in seq_along(pp)) {
+ lambda <- 1
+ for (j in seq_len(length(pp[[i]])-1))
+ lambda <- lambda*Ap[pp[[i]][j],pp[[i]][j+1]]
+ lambda1 <- lambda1+lambda
+ }
+ lambdas <- c(lambdas,lambda1)
+ }
+ val <- outer(1/lambdas,1/lambdas)*Sigma[ys,ys]
+ var.eta <- c(var.eta, mean(val[upper.tri(val)]))
+ }
+
+ S <- rep(0,k); S[match(manifest(x),vars(x))] <- diag(Sigma); S[match(latent(x),vars(x))] <- var.eta; names(S) <- vars(x)
+ I <- diag(nrow=k)
+ IA <- (I-t(Ap))
+ IA%*%cbind(S)%*%t(IA)
+
+}
+
+
+## Instrumental Variable Estimator / 2SLS
+##' @export
+IV <- function(m,data,R2thres=0,type="robust", ...) {
+ if (length(constrain(m))>0) stop("Nonlinear constrains not supported!")
+ if (inherits(m,"lvmfit")) {
+ m <- Model(m)
+ }
+ R2 <- cor(data[,manifest(m)])^2
+
+ A <- t(index(m)$A)
+ Afix <- A; Afix[t(index(m)$M0)==1] <- 0
+ A[A!=0] <- 1
+ P <- index(m)$P
+ k <- nrow(A)
+ I <- diag(nrow=k)
+ B <- rbind(I,solve(I-A))
+ VV <- B%*%P%*%t(B)
+ u.var <- index(m)$vars
+ all.idx <- seq_along(u.var)
+ lat.idx <- with(index(m), which(vars%in%latent))
+ if (length(lat.idx)==0) stop("Estimator only defined for models with latent variable")
+ y.var <- endogenous(m)
+ y.idx <- which(index(m)$vars%in%y.var)
+ x.idx <- which(vars(m)%in%exogenous(m))
+
+ ## Set of Indicator variables:
+ indicators <- c()
+ for (i in seq_len(nrow(A))) {
+ ifix <- (Afix[i,]==1)
+ if ((sum(ifix)==1) & all(A[i,-which(ifix)]==0))
+ indicators <- c(indicators, i)
+ }
+ y.indicators <- intersect(indicators,y.idx)
+
+ y.scale <- list()
+ for (eta in lat.idx) {
+ pred.eta <- intersect(y.idx, which(Afix[,eta]==1)) ## Candidates for
+ ## eta = y-epsilon
+ if (length(pred.eta)<1)
+ pred.eta <- intersect(lat.idx, which(Afix[,eta]==1))
+ myidx <- c()
+ for (y in pred.eta) {
+ y.pred <- setdiff(eta,which(A[y,]==1)) ## No other variables predicting y?
+ if (length(y.pred)==0)
+ myidx <- c(myidx,y)
+ }
+ y.scale <- c(y.scale, list(myidx))
+ }
+
+ if (any(unlist(lapply(y.scale, function(x) length(x)))<1)) stop("At least one scale-measurement pr. latent variable")
+
+ vv <- setdiff(seq_len(k),c(unlist(y.scale),x.idx))
+
+ Ecor <- list()
+ eta.surrogate <- c()
+ latno <- 0
+ for (e in lat.idx) {
+ latno <- latno+1
+ y0 <- y.scale[[latno]][1]
+ if (!(y0%in%lat.idx)) {
+ eta.surrogate <- c(eta.surrogate,vars(m)[y0])
+ Ecor <- c(Ecor,list(y0))
+ }
+ else {
+ v0 <- vars(m)[-c(e,indicators)]
+ ##m.sub <- subset(m,vars(m)[c(e,indicators)])
+ m.sub <- rmvar(m,v0)
+ i <- 0
+ while (i<length(y.indicators)) {
+ i <- i+1
+ pp <- path(m.sub,from=vars(m)[e],to=vars(m)[y.indicators[i]])[[1]]
+ if (!is.null(pp)) {
+ Ecor <- c(Ecor,
+ list(which(vars(m)%in%pp[-1])))
+ eta.surrogate <- c(eta.surrogate, tail(pp,1))
+ }
+ }
+ }
+ };
+ names(eta.surrogate) <- latent(m)
+
+ dd <- list()
+ ll <- list()
+ coefname <- coef(m,mean=TRUE)
+ mycoef <- rep(0,length(coefname))
+ A0 <- A
+ P0 <- P
+ D <- c()
+ V. <- list()
+ Z. <- list()
+ Y. <- list()
+ count <- 0
+ ff <- list()
+ instruments <- c()
+ parname <- c()
+ for (v in vv) {
+ pred <- which(A[v,]==1)
+ if (sum(pred)>0) {
+ Debug(vars(m)[v])
+ pred.lat <- intersect(pred,lat.idx) # Any latent predictors?
+ lpos <- match(v,lat.idx)
+ lppos <- match(pred.lat,lat.idx)
+ ecor <- c(v,unlist(Ecor[lppos]))
+ if (!is.na(lpos)) {
+ v0 <- match(eta.surrogate[lpos],vars(m))
+ ecor <- c(ecor,Ecor[[lpos]])
+ } else {
+ v0 <- v
+ }
+
+ ecor <- unique(c(v0,ecor))
+ XX <- vars(m)[A[v,]==1]
+ intpred <- exogenous(m)
+ newf <- c()
+ if (length(pred.lat)>0) {
+ intpred <- vars(m)
+ for (i in seq_along(pred.lat)) {
+ uncor <- which(colSums(VV[ecor,k+seq_len(k),drop=FALSE])==0)
+ uncor <- setdiff(uncor,c(lat.idx))
+ mypred <- vars(m)[uncor]
+ XX[XX==vars(m)[pred.lat[i]]] <- eta.surrogate[lppos[i]]
+ ## allpred <- c(allpred, mypred)
+ intpred <- intersect(intpred,mypred)
+ f <- toformula(eta.surrogate[lppos[i]],mypred)
+ ff <- c(ff,
+ f)
+ f2 <- list(f)
+ names(f2) <- vars(m)[i]
+ newf <- c(newf,f2)
+ }
+ }
+
+ intpred <- intersect(intpred,manifest(m))
+ R2max <- apply(R2[XX,intpred,drop=FALSE],2,max)
+ if (any(R2max<R2thres)) intpred <- intpred[R2max>=R2thres]
+ newf <- list(intpred); names(newf) <- vars(m)[v]
+ instruments <- c(instruments, newf)
+ covariates <- unique(c(setdiff(colnames(A)[A[v,]==1],latent(m)),intpred))##allpred)
+ if (length(covariates)==0) stop("No instruments")
+ Z <- model.matrix(toformula("",c("1",XX)),data)
+ Y <- as.matrix(data[,vars(m)[v0]])
+ V <- model.matrix(toformula("",c("1",unique(covariates))),data)
+ count <- count+1
+ V. <- c(V.,list(V))
+ Z. <- c(Z.,list(Z))
+ Y. <- c(Y.,list(Y))
+ XX <- vars(m)[A[v,]==1 & Afix[v,]!=1]
+ parname <- c(parname, c(vars(m)[v0],paste(vars(m)[v],XX,sep=lava.options()$symbol[1])))
+ } else {
+ if (vars(m)[v]%in%latent(m)) {
+ lpos <- match(v,lat.idx)
+ v0 <- match(eta.surrogate[lpos],vars(m))
+ Y <- matrix(data[,vars(m)[v0]],ncol=1)
+ Y. <- c(Y.,list(Y))
+ V. <- c(V.,list(cbind(rep(1,nrow(Y)))))
+ Z. <- c(Z.,list(cbind(rep(1,nrow(Y)))))
+ parname <- c(parname, names(eta.surrogate)[lpos])
+ }
+ }
+ }
+
+ LS <- function(X) {
+ with(svd(X), v%*%diag(1/d,nrow=length(d))%*%t(u))
+ }
+ projection <- function(X) X%*%LS(X)
+ P0 <- lapply(V.,LS)
+ Zhat <- list(); for (i in seq_along(Z.)) Zhat <- c(Zhat, list(V.[[i]]%*%(P0[[i]]%*%Z.[[i]])))
+ ZhatLS <- lapply(Zhat,LS)
+ theta <- list(); for (i in seq_along(Y.)) theta <- c(theta, list(ZhatLS[[i]]%*%Y.[[i]]))
+ u <- c()
+ for (i in seq_along(Y.))
+ u <- cbind(u, Y.[[i]]-Z.[[i]]%*%theta[[i]])
+
+ covu <- crossprod(u)/nrow(u)
+
+ theta.npar <- unlist(lapply(theta,length))
+ theta.ncum <- c(0,cumsum(theta.npar))
+ vartheta <- matrix(0,ncol=sum(theta.npar),nrow=sum(theta.npar))
+ for (i in seq_along(theta)) {
+ for (j in seq(i,length(theta))) {
+ idx1 <- seq_len(theta.npar[i]) + theta.ncum[i]
+ idx2 <- seq_len(theta.npar[j]) + theta.ncum[j]
+ if (type=="robust") {
+ zi <- ZhatLS[[i]]
+ for (k in seq(nrow(zi))) zi[k,] <- zi[k,]*u[,i]
+ zj <- ZhatLS[[j]]
+ for (k in seq(nrow(zj))) zj[k,] <- zj[k,]*u[,j]
+ uZZ <- zi%*%t(zj)
+ } else {
+ uZZ <- covu[i,j]* (ZhatLS[[i]]%*%t(ZhatLS[[j]]))
+ }
+ vartheta[idx1,idx2] <- uZZ
+ if (i!=j) {
+ vartheta[idx2,idx1] <- t(uZZ)
+ }
+ }
+ }
+
+ parname[which(parname%in%eta.surrogate)] <- names(eta.surrogate)[which(eta.surrogate%in%parname)]
+
+ coef <- cbind(unlist(theta),diag(vartheta)^0.5); rownames(coef) <- parname; colnames(coef) <- c("Estimate","Std.Err")
+ res <- list(estimate=coef[,1], vcov=vartheta)
+ attributes(res)$surrogates <- eta.surrogate
+ attributes(res)$instruments <- instruments
+ return(res)
+}
+
+IV2 <- function(m,data,control=list(),...) {
+ if (is.null(control$R2thres)) control$R2thres <- 0
+ res <- IV(m,data,R2thres=control$R2thres,...)
+ p <- res$estimate
+ idx <- match(names(p),coef(m,mean=TRUE))
+ x0 <- parfix(m,idx,p)
+ index(x0) <- reindex(x0,zeroones=TRUE,deriv=TRUE)
+ idx0 <- order(idx)
+ p0 <- p[idx0]
+ V0 <- res$vcov[idx0,idx0]
+ if (is.null(control$variance) || control$variance) {
+ suppressWarnings(e0 <- estimate(x0,data,...,silent=TRUE,quick=TRUE))
+ p0 <- c(p0,e0)
+ V0 <- V0%++%matrix(0,ncol=length(e0),nrow=length(e0))
+ }
+ R2 <- noquote(formatC(cor(data[,manifest(m)])^2))
+ colnames(R2) <- rownames(R2) <- manifest(m)
+ l1 <- noquote(rbind(paste(latent(m),collapse=","),
+ paste(attributes(res)$surrogates,collapse=","),
+ ""))
+ rownames(l1) <- c("Latent variables","Surrogate variables:","")
+ colnames(l1) <- ""
+ ii <- attributes(res)$instruments
+ I <- noquote(matrix(NA,ncol=2,nrow=length(ii)))
+ rownames(I) <- rep("",nrow(I))
+ colnames(I) <- c("Response","Instruments")
+ for (i in seq_along(ii)) {
+ I[i,] <- c(names(ii)[i],paste(ii[[i]],collapse=","))
+ }
+ mymsg <- list(l1,I);
+ list(estimate=p0,vcov=V0,summary.message=function(...) {
+ mymsg })
+}
diff --git a/R/kappa.R b/R/kappa.R
new file mode 100644
index 0000000..9928ae2
--- /dev/null
+++ b/R/kappa.R
@@ -0,0 +1,32 @@
+##################################################
+## Cohen's kappa
+##################################################
+
+##' @export
+kappa.multinomial <- function(z,all=FALSE,...) {
+ pp <- length(coef(z))
+ if ((length(z$levels)!=2) || !(identical(z$levels[[1]],z$levels[[2]])))
+ stop("Expected square table and same factor levels in rows and columns")
+ k <- length(z$levels[[1]])
+ zeros <- rbind(rep(0,pp))
+ A0 <- zeros; A0[diag(z$position)] <- 1
+ A <- matrix(0,ncol=pp,nrow=2*k)
+ for (i in seq(k)) A[i,z$position[i,]] <- 1
+ for (i in seq(k)) A[i+k,z$position[,i]] <- 1
+ b <- estimate(z,function(p) as.vector(rbind(A0,A)%*%p),iid=TRUE)
+ b2 <- estimate(b,function(p) c(p[1],sum(p[seq(k)+1]*p[seq(k)+k+1])),iid=TRUE)
+ if (!all) {
+ return(estimate(b2,function(p) list(kappa=(p[1]-p[2])/(1-p[2])),iid=TRUE,...))
+ }
+ estimate(b2,function(p) list(kappa=(p[1]-p[2])/(1-p[2]),agree=p[1], independence=p[2]),iid=TRUE,...)
+}
+
+##' @export
+kappa.table <- function(z,...) {
+ kappa(multinomial(Expand(z)),...)
+}
+
+##' @export
+kappa.data.frame <- function(z,...) {
+ kappa(multinomial(z),...)
+}
diff --git a/R/kill.R b/R/kill.R
new file mode 100644
index 0000000..4221c99
--- /dev/null
+++ b/R/kill.R
@@ -0,0 +1,81 @@
+##' Generic method for removing elements of object
+##'
+##' @title Remove variables from (model) object.
+##' @aliases rmvar rmvar<- kill kill<-
+##' @param x Model object
+##' @param value Vector of variables or formula specifying which nodes to
+##' remove
+##' @param \dots additional arguments to lower level functions
+##' @usage
+##' kill(x, ...) <- value
+##' @seealso \code{cancel}
+##' @author Klaus K. Holst
+##' @keywords models regression
+##' @export
+##' @examples
+##'
+##' m <- lvm()
+##' addvar(m) <- ~y1+y2+x
+##' covariance(m) <- y1~y2
+##' regression(m) <- c(y1,y2) ~ x
+##' ### Cancel the covariance between the residuals of y1 and y2
+##' cancel(m) <- y1~y2
+##' ### Remove y2 from the model
+##' rmvar(m) <- ~y2
+##'
+"rmvar" <- function(x, ...) UseMethod("rmvar")
+
+##' @export
+"kill" <- function(x, ...) UseMethod("kill")
+
+##' @export
+"kill<-" <- function(x, ..., value) UseMethod("kill<-")
+
+##' @export
+"rmvar<-" <- function(x, ..., value) UseMethod("rmvar<-")
+
+##' @export
+"kill<-.lvm" <- function(x, ..., value) {
+ kill(x,value)
+}
+
+##' @export
+"rmvar<-.lvm" <- get("kill<-.lvm")
+
+##' @export
+"kill.lvm" <- function(x, value, ...) {
+ if (inherits(value,"formula")) value <- all.vars(value)
+ idx <- which(names(x$exfix)%in%value)
+ if (length(idx)>0) {
+ x$attributes$parameter[idx] <- x$expar[idx] <- x$exfix[idx] <- NULL
+ if (length(x$exfix)==0) {
+ x$exfix <- x$expar <- x$attributes$parameter <- NULL
+ }
+ index(x) <- reindex(x)
+ }
+ idx <- which(vars(x)%in%value)
+ if (length(idx)!=0){
+ vv <- vars(x)[idx]
+ keep <- setdiff(seq_along(vars(x)),idx)
+ x$M <- x$M[keep,keep,drop=FALSE]
+ x$par <- x$par[keep,keep,drop=FALSE]
+ x$fix <- x$fix[keep,keep,drop=FALSE]
+ x$covpar <- x$covpar[keep,keep,drop=FALSE]
+ x$covfix <- x$covfix[keep,keep,drop=FALSE]
+ x$cov <- x$cov[keep,keep,drop=FALSE]
+ x$mean <- (x$mean)[-idx]
+ x$exogenous <- setdiff(exogenous(x),vv)
+ x$latent[vv] <- NULL
+ }else{ ## remove variables that cannot be accessed by vars in the hook
+ vv <- value
+ }
+ myhooks <- gethook("remove.hooks")
+ for (f in myhooks) {
+ x <- do.call(f, list(x=x,var=vv,...))
+ }
+ index(x) <- reindex(x)
+ return(x)
+}
+
+##' @export
+"rmvar.lvm" <- get("kill.lvm")
diff --git a/R/ksmooth.R b/R/ksmooth.R
new file mode 100644
index 0000000..4a2a10a
--- /dev/null
+++ b/R/ksmooth.R
@@ -0,0 +1,137 @@
+##' Plot/estimate surface
+##'
+##' @export
+##' @aliases ksmooth2 surface
+##' @param x formula or data
+##' @param data data.frame
+##' @param h bandwidth
+##' @param xlab X label
+##' @param ylab Y label
+##' @param zlab Z label
+##' @param gridsize grid size of kernel smoother
+##' @param ... Additional arguments to graphics routine (persp3d or persp)
+##' @examples
+##' ksmooth2(rmvn(1e4,sigma=diag(2)*.5+.5),c(-3.5,3.5),h=1,
+##' rgl=FALSE,theta=30)
+##'
+##' if (interactive()) {
+##' ksmooth2(rmvn(1e4,sigma=diag(2)*.5+.5),c(-3.5,3.5),h=1)
+##' ksmooth2(function(x,y) x^2+y^2, c(-20,20))
+##' ksmooth2(function(x,y) x^2+y^2, xlim=c(-5,5), ylim=c(0,10))
+##'
+##' f <- function(x,y) 1-sqrt(x^2+y^2)
+##' surface(f,xlim=c(-1,1),alpha=0.9,aspect=c(1,1,0.75))
+##' surface(f,xlim=c(-1,1),clut=heat.colors(128))
+##' ##play3d(spin3d(axis=c(0,0,1), rpm=8), duration=5)
+##' }
+##'
+##' if (interactive()) {
+##' surface(function(x) dmvn(x,sigma=diag(2)),c(-3,3),lit=FALSE,smooth=FALSE,box=FALSE,alpha=0.8)
+##' surface(function(x) dmvn(x,sigma=diag(2)),c(-3,3),box=FALSE,specular="black")##'
+##' }
+##'
+##' if (!inherits(try(find.package("fields"),silent=TRUE),"try-error")) {
+##' f <- function(x,y) 1-sqrt(x^2+y^2)
+##' ksmooth2(f,c(-1,1),rgl=FALSE,image=fields::image.plot)
+##' }
+ksmooth2 <- function(x,data,h=NULL,xlab=NULL,ylab=NULL,zlab="",gridsize=rep(51L,2),...) {
+ if (is.function(x)) {
+ args <- c(list(f=x,h=h,xlab=xlab,ylab=ylab,zlab=zlab),list(...))
+ if (is.null(args$xlim) && !missing(data)) {
+ if (is.list(data)) {
+ args$xlim <- data[[1]]
+ args$ylim <- data[[2]]
+ } else args$xlim <- data
+ }
+ return(do.call(surface,args))
+ }
+ if (inherits(x,"formula")) {
+ x <- model.frame(x,data)
+ }
+ if (length(gridsize)==1) gridsize <- rep(gridsize,2)
+ if (is.null(h)) h <- apply(as.matrix(x),2,sd)*nrow(x)^(-1/5)
+ est <- KernSmooth::bkde2D(x, bandwidth=h, gridsize=gridsize)
+ if (is.null(xlab)) xlab <- names(x)[1]
+ if (is.null(ylab)) ylab <- names(x)[2]
+ surface(est$fhat, x=est$x1, y=est$x2, est$fhat,
+ xlab=xlab, ylab=ylab, zlab=zlab, ...)
+ return(invisible(est))
+}
+
+
+##' @export
+surface <- function(f,xlim=c(0,1),ylim=xlim,n=rep(100,2),col,clut="gold",clut.center,x,y,rgl=TRUE,expand=0.5,nlevels=10,col.contour="black",contour=TRUE,persp=TRUE,image="image",...) {
+ if (missing(x)) {
+ if (length(n)==1) n <- rep(n,2)
+ x <- seq(xlim[1],xlim[2],length.out=n[1])
+ y <- seq(ylim[1],ylim[2],length.out=n[2])
+ }
+ if (is.function(f)) {
+ xy <- as.matrix(expand.grid(x,y))
+ if (inherits(try(f(c(x[1],y[1])),silent=TRUE),"try-error")) {
+ f <- matrix(f(xy[,1],xy[,2]),nrow=length(x),ncol=length(y))
+ } else {
+ val <- f(xy)
+ if (length(val)<NROW(xy)) {
+ f <- matrix(apply(xy,1,f),nrow=length(x),ncol=length(y))
+ } else {
+ f <- matrix(val,nrow=length(x),ncol=length(y))
+ }
+ }
+ }
+ zrg <- range(f)
+ zlen <- diff(zrg)
+ if (length(clut)==1) {
+ ncolour <- 128
+ clut <- switch(clut,
+ topo=topo.colors(ncolour),
+ red=colorRampPalette(c("yellow","red"),bias=1)(ncolour),
+ blue=colorRampPalette(c("white","blue"),bias=1)(ncolour),
+ gold=colorRampPalette(c("white","goldenrod1"),bias=1)(ncolour),
+ france=colorRampPalette(c("blue","white","red"))(ncolour),
+ rainbow=rainbow(n=128,start=0,end=1),
+ heat=heat.colors(ncolour),
+ heatrev=rev(heat.colors(ncolour)),
+ colorRampPalette(c("white","goldenrod1"),bias=1)(ncolour)
+ )
+ }
+ ncolour <- length(clut)
+ if (!rgl) {
+ if (missing(col)) {
+ nc <- ncol(f); nr <- nrow(f)
+ facet <- f[-1,-1]+f[-1,-nc]+f[-nr,-1]+f[-nr,-nc]
+ facetcol <- cut(facet, ncolour)
+ col <- clut[facetcol]
+ }
+ dots <- list(...)
+ parargs <- list()
+ if (persp) {
+ parargs$mar <- c(0.2,0,0,0)
+ if (contour || !is.null(image)) parargs$mfrow=c(2,1)
+ }
+ op <- do.call(par,parargs)
+ if (persp) graphics::persp(x=x,y=x,z=f, col=col, expand=expand, ...)
+ if (contour | !is.null(image)) {
+ par(mar=c(3,3,0.5,3)) ##c(bottom, left, top, right)
+ if (!is.null(image)) {
+ do.call(image,list(x=x,y=y,z=f,col=clut,xlim=range(x),ylim=range(y),xlab="",ylab=""))
+ }
+ if (contour) {
+ args <- c(list(x=x,y=y,z=f,nlevels=nlevels,col=col.contour,add=!is.null(image)),dots)
+ args <- args[names(formals(contour.default))]
+ do.call("contour",args) ##nlevels=20
+ }
+ }
+ suppressWarnings(par(op))
+ } else {
+ if (missing(col)) {
+ if (!missing(clut.center)) {
+ zmax <- max(abs(zrg))
+ zrg <- c(-zmax,zmax)
+ zlen <- 2*zmax
+ }
+ col <- clut[round((length(clut)-1)*(f-zrg[1])/zlen)+1]
+ }
+ rgl::persp3d(x, y, f, col=col,...)
+ }
+}
diff --git a/R/labels.R b/R/labels.R
new file mode 100644
index 0000000..09ca801
--- /dev/null
+++ b/R/labels.R
@@ -0,0 +1,398 @@
+###{{{ labels
+
+##' Define labels of graph
+##'
+##' Alters labels of nodes and edges in the graph of a latent variable model
+##'
+##'
+##' @aliases labels<- labels labels<-.default labels.lvm labels.lvmfit
+##' labels.graphNEL edgelabels edgelabels<- edgelabels<-.lvm nodecolor
+##' nodecolor<- nodecolor<-.default
+##' @author Klaus K. Holst
+##' @export
+##' @keywords graphs aplot
+##' @examples
+##' m <- lvm(c(y,v)~x+z)
+##' regression(m) <- c(v,x)~z
+##' labels(m) <- c(y=expression(psi), z=expression(zeta))
+##' nodecolor(m,~y+z+x,border=c("white","white","black"),
+##' labcol="white", lwd=c(1,1,5),
+##' lty=c(1,2)) <- c("orange","indianred","lightgreen")
+##' edgelabels(m,y~z+x, cex=c(2,1.5), col=c("orange","black"),labcol="darkblue",
+##' arrowhead=c("tee","dot"),
+##' lwd=c(3,1)) <- expression(phi,rho)
+##' edgelabels(m,c(v,x)~z, labcol="red", cex=0.8,arrowhead="none") <- 2
+##' if (interactive()) {
+##' plot(m,addstyle=FALSE)
+##' }
+##'
+##' m <- lvm(y~x)
+##' labels(m) <- list(x="multiple\nlines")
+##' if (interactive()) {
+##' op <- par(mfrow=c(1,2))
+##' plot(m,plain=TRUE)
+##' plot(m)
+##' par(op)
+##'
+##' d <- sim(m,100)
+##' e <- estimate(m,d)
+##' plot(e,type="sd")
+##' }
+##' @param object \code{lvm}-object.
+##' @param value node label/edge label/color
+##' @param to Formula specifying outcomes and predictors defining relevant
+##' edges.
+##' @param \dots Additional arguments (\code{lwd}, \code{cex}, \code{col},
+##' \code{labcol}), \code{border}.
+##' @param var Formula or character vector specifying the nodes/variables to
+##' alter.
+##' @param border Colors of borders
+##' @param labcol Text label colors
+##' @param shape Shape of node
+##' @param lwd Line width of border
+##' @usage
+##' \method{labels}{default}(object, ...) <- value
+##' \method{edgelabels}{lvm}(object, to, ...) <- value
+##' \method{nodecolor}{default}(object, var=vars(object),
+##' border, labcol, shape, lwd, ...) <- value
+`labels<-` <- function(object,...,value) UseMethod("labels<-")
+
+##' @export
+`labels<-.default` <- function(object,...,value) {
+ labels(object,value)
+}
+
+##' @export
+labels.graphNEL <- function(object,lab=NULL,...) {
+ if (is.null(lab))
+ return(graph::nodeRenderInfo(object)$label)
+ graph::nodeRenderInfo(object) <- list(label=lab)
+ names(graph::nodeRenderInfo(object)$label) <- graph::nodes(object);
+ return(object)
+}
+
+##' @export
+labels.lvmfit <- function(object,lab=NULL,...) {
+ if (is.null(lab)) return(object$noderender$label)
+ object$noderender$label <- lab
+ return(object)
+}
+
+##' @export
+`labels.lvm` <- function(object,lab=NULL,...) {
+ if (is.null(lab))
+ return(object$noderender$label)
+ if (is.null(object$noderender$label))
+ object$noderender$label <- lab
+ else
+ object$noderender$label[names(lab)] <- lab
+ return(object)
+}
+###}}} labels
+
+###{{{ edgelabels
+
+##' @export
+"edgelabels<-.lvmfit" <- function(object,to,from,est=TRUE,edges=NULL,cex=1,...,value) {
+ if (is.null(edges)) {
+ if (inherits(to,"formula")) {
+ yy <- decomp.specials(getoutcome(to))
+ from <- setdiff(all.vars(to),yy)
+ to <- yy
+ }
+ edges <- paste(from,to,sep="~")
+ }
+
+ edges. <- paste0("\"", edges, "\"")
+ fromto <- edge2pair(edges)
+ val <- c()
+ for (i in seq_along(edges)) {
+ val <- c(val,
+ formatC(effects(object,from=fromto[[i]][1],to=fromto[[i]][2],silent=TRUE)$directef[[1]])
+ )
+ }
+ if (est)
+ mytext <- paste("c(", paste(paste0(edges.,"=expression(",as.character(value),"==\"",val,"\")"),collapse=","),")")
+ else
+ mytext <- paste("c(", paste(paste0(edges.,"=expression(",as.character(value),")"),collapse=","),")")
+ graph::edgeRenderInfo(Graph(object))$label <- eval(parse(text=mytext))
+ graph::edgeRenderInfo(Graph(object))$cex[edges] <- cex
+ return(object)
+}
+
+##' @export
+edgelabels.lvmfit <- function(object,value,type,pthres,intercept=FALSE,format.fun=formatC,...) {
+ if (!missing(value)) {
+ edgelabels(object,...) <- value
+ return(object)
+ }
+ if (missing(type))
+ return(graph::edgeRenderInfo(Graph(object))$label)
+
+
+ Afix <- index(object)$A ## Matrix with fixed parameters and ones where parameters are free
+ Pfix <- index(object)$P ## Matrix with fixed covariance parameters and ones where param
+ mfix <- index(object)$v0
+
+ npar.mean <- index(object)$npar.mean
+ Par <- object$coef
+ mpar <- c()
+ if (npar.mean>0) {
+ mpar <- do.call(format.fun,list(Par[seq_len(npar.mean)]))
+ Par <- Par[-seq_len(npar.mean),,drop=FALSE]
+ }
+ Par <-
+ switch(type,
+ sd = paste0(do.call(format.fun,list(Par[,1,drop=FALSE])), " (", do.call(format.fun,list(Par[,2,drop=FALSE])), ")"),
+ est = do.call(format.fun,list(Par[,1,drop=FALSE])),
+ pval = do.call(format.fun,list(Par[,4,drop=FALSE])),
+ name = rownames(Par),
+ none = ""
+ )
+ AP <- matrices(Model(object), Par,mpar) ## Ignore expar
+ A <- AP$A; P <- AP$P
+ P[exogenous(object),exogenous(object)] <- NA
+
+ gr <- finalize(Model(object), ...)
+ Anz <- A; Anz[Afix==0] <- NA
+ gr <- edgelabels(gr, lab=Anz)
+ Pnz <- P; Pnz[Model(object)$cov==0] <- NA
+ if (intercept) {
+ idx <- which(!is.na(diag(Pnz)))
+ diag(Pnz)[idx] <- paste(paste0("[",AP$v[idx],"]"),diag(Pnz)[idx],sep="\n")
+ }
+ gr <- edgelabels(gr, lab=Pnz, expr=!intercept)
+ Graph(object) <- gr
+ return(object)
+}
+
+##' @export
+`edgelabels` <- function(object, ...) UseMethod("edgelabels")
+
+##' @export
+`edgelabels<-` <- function(object,...,value) UseMethod("edgelabels<-")
+
+##' @export
+`edgelabels<-.lvm` <- function(object,to,...,value) {
+ edgelabels(object,to=to, lab=value,...)
+}
+
+##' @export
+`edgelabels<-.graphNEL` <- function(object,...,value) {
+ edgelabels(object,lab=value,...)
+}
+
+##' @export
+`edgelabels.graphNEL` <- function(object, lab=NULL, to=NULL, from=NULL, cex=1.5, lwd=1, lty=1, col="black", labcol="black", arrowhead="closed",
+ expr=TRUE,
+ debug=FALSE,...) {
+ if (is.null(lab)) {
+ return(graph::edgeRenderInfo(object)$label)
+ }
+ if (inherits(to,"formula")) {
+ yy <- decomp.specials(getoutcome(to))
+ from <- all.vars(to[[3]])##setdiff(all.vars(to),yy)
+ if (length(from)==0) from <- yy
+ to <- yy
+ }
+
+ M <- as(object, Class="matrix")
+ nodes <- graph::nodes(object)
+
+ if (is.null(graph::edgeRenderInfo(object)$label))
+ graph::edgeRenderInfo(object)$label <- expression()
+
+
+ if (!is.null(lab)) {
+ if (!is.null(from) & !is.null(to)) {
+ estr <- paste0("\"",from,"~",to,"\"")
+ estr2 <- paste0(from,"~",to)
+ if (length(lab)!=length(estr2)) lab <- rep(lab,length(estr2))
+ if (length(col)!=length(estr2)) col <- rep(col,length(estr2))
+ if (length(cex)!=length(estr2)) cex <- rep(cex,length(estr2))
+ if (length(lwd)!=length(estr2)) lwd <- rep(lwd,length(estr2))
+ if (length(lty)!=length(estr2)) lty <- rep(lty,length(estr2))
+ if (length(arrowhead)!=length(estr2))
+ arrowhead <- rep(arrowhead,length(estr2))
+ if (length(labcol)!=length(estr2))
+ labcol <- rep(labcol,length(estr2))
+
+ curedges <- names(graph::edgeRenderInfo(object)$label)
+ Debug(estr,debug)
+
+ estr2.idx <- which(estr2%in%curedges)
+ newstr.idx <- setdiff(seq_along(estr2),estr2.idx)
+ newstr <- estr2[newstr.idx]
+ estr2 <- estr2[estr2.idx]
+ if (length(estr2)>0) {
+ if (!is.null(lab))
+ graph::edgeRenderInfo(object)$label[estr2] <- lab[estr2.idx]
+ if (!is.null(cex))
+ graph::edgeRenderInfo(object)$cex[estr2] <- cex[estr2.idx]
+ if (!is.null(col))
+ graph::edgeRenderInfo(object)$col[estr2] <- col[estr2.idx]
+ if (!is.null(lwd))
+ graph::edgeRenderInfo(object)$lwd[estr2] <- lwd[estr2.idx]
+ if (!is.null(lty))
+ graph::edgeRenderInfo(object)$lty[estr2] <- lty[estr2.idx]
+ if (!is.null(labcol))
+ graph::edgeRenderInfo(object)$textCol[estr2] <- labcol[estr2.idx]
+ if (!is.null(arrowhead))
+ graph::edgeRenderInfo(object)$arrowhead[estr2] <- arrowhead[estr2.idx]
+ }
+ if (length(newstr)>0) {
+
+ if (!is.null(lab))
+ graph::edgeDataDefaults(object)$futureinfo$label[newstr] <-
+ lab[newstr.idx]
+ if (!is.null(cex))
+ graph::edgeDataDefaults(object)$futureinfo$cex[newstr] <-
+ cex[newstr.idx]
+ if (!is.null(col))
+ graph::edgeDataDefaults(object)$futureinfo$col[newstr] <-
+ col[newstr.idx]
+ if (!is.null(lwd))
+ graph::edgeDataDefaults(object)$futureinfo$lwd[newstr] <-
+ lwd[newstr.idx]
+ if (!is.null(lty))
+ graph::edgeDataDefaults(object)$futureinfo$lty[newstr] <-
+ lty[newstr.idx]
+ if (!is.null(labcol))
+ graph::edgeDataDefaults(object)$futureinfo$textCol[newstr] <-
+ labcol[newstr.idx]
+ if (!is.null(arrowhead))
+ graph::edgeDataDefaults(object)$futureinfo$arrowhead[newstr] <-
+ arrowhead[newstr.idx]
+ }
+ return(object)
+ }
+
+ ## Used by "edgelabels.lvmfit"
+ for (r in seq_len(nrow(M)))
+ for (s in seq_len(ncol(M))) {
+ if (M[r,s]!=0 & !is.na(lab[r,s])) {
+ estr <- paste0("\"",nodes[r],"~",nodes[s],"\"")
+ estr2 <- paste0(nodes[r],"~",nodes[s])
+ Debug(estr, debug)
+ if (expr)
+ st <- eval(parse(text=paste0("expression(",lab[r,s],")")))
+ else
+ st <- lab[r,s]
+ graph::edgeRenderInfo(object)$label[estr2] <- st
+ }
+ }
+ }
+
+ return(object)
+}
+
+
+
+##' @export
+`edgelabels.lvm` <- function(object, lab=NULL, to=NULL, from=NULL,
+ cex=1.5, lwd=1, lty=1, col="black",
+ labcol="black", arrowhead="closed",
+ expr=TRUE, debug=FALSE,...) {
+ if (inherits(to,"formula")) {
+ yy <- decomp.specials(getoutcome(to))
+ from <- all.vars(to[[3]])##setdiff(all.vars(to),yy)
+ if (length(from)==0) from <- yy
+ to <- yy
+ }
+ if (is.null(lab)) {
+ res <- c(object$edgerender$label,object$edgerender$futureinfo$label)
+ if (!is.null(to) && !is.null(from)) {
+ estr <- apply(Expand(from,to),1,function(x) paste0(x,collapse="~"))
+ res <- res[estr]
+ }
+ return(res)
+ }
+
+ M <- object$M
+ nodes <- colnames(M)
+
+ if (is.null(object$edgerender$label))
+ object$edgerender$label <- expression()
+
+
+ if (!is.null(lab)) {
+ if (!is.null(from) & !is.null(to)) {
+ estr <- paste0("\"",from,"~",to,"\"")
+ estr2 <- paste0(from,"~",to)
+ if (length(lab)!=length(estr2)) lab <- rep(lab,length(estr2))
+ if (length(col)!=length(estr2)) col <- rep(col,length(estr2))
+ if (length(cex)!=length(estr2)) cex <- rep(cex,length(estr2))
+ if (length(lwd)!=length(estr2)) lwd <- rep(lwd,length(estr2))
+ if (length(lty)!=length(estr2)) lty <- rep(lty,length(estr2))
+ if (length(labcol)!=length(estr2)) labcol <- rep(labcol,length(estr2))
+ if (length(arrowhead)!=length(estr2)) arrowhead <- rep(arrowhead,length(estr2))
+
+ curedges <- names(object$edgerender$label)
+ Debug(estr,debug)
+
+ estr2.idx <- which(estr2%in%curedges)
+ newstr.idx <- setdiff(seq_along(estr2),estr2.idx)
+ newstr <- estr2[newstr.idx]
+ estr2 <- estr2[estr2.idx]
+ if (length(estr2)>0) {
+ if (!is.null(lab))
+ object$edgerenderlabel[estr2] <- lab[estr2.idx]
+ if (!is.null(cex))
+ object$edgerender$cex[estr2] <- cex[estr2.idx]
+ if (!is.null(col))
+ object$edgerender$col[estr2] <- col[estr2.idx]
+ if (!is.null(lwd))
+ object$edgerender$lwd[estr2] <- lwd[estr2.idx]
+ if (!is.null(lty))
+ object$edgerender$lty[estr2] <- lty[estr2.idx]
+ if (!is.null(labcol))
+ object$edgerender$textCol[estr2] <- labcol[estr2.idx]
+ if (!is.null(arrowhead))
+ object$edgerender$arrowhead[estr2] <- arrowhead[estr2.idx]
+ }
+ if (length(newstr)>0) {
+
+ if (!is.null(lab))
+ object$edgerender$futureinfo$label[newstr] <-
+ lab[newstr.idx]
+ if (!is.null(cex))
+ object$edgerender$futureinfo$cex[newstr] <-
+ cex[newstr.idx]
+ if (!is.null(col))
+ object$edgerender$futureinfo$col[newstr] <-
+ col[newstr.idx]
+ if (!is.null(lwd))
+ object$edgerender$futureinfo$lwd[newstr] <-
+ lwd[newstr.idx]
+ if (!is.null(lty))
+ object$edgerender$futureinfo$lty[newstr] <-
+ lty[newstr.idx]
+ if (!is.null(labcol))
+ object$edgerender$futureinfo$textCol[newstr] <-
+ labcol[newstr.idx]
+ if (!is.null(arrowhead))
+ object$edgerender$futureinfo$arrowhead[newstr] <-
+ arrowhead[newstr.idx]
+ }
+ return(object)
+ }
+
+ ## Used by "edgelabels.lvmfit"
+ for (r in seq_len(nrow(M)))
+ for (s in seq_len(ncol(M))) {
+ if (M[r,s]!=0 & !is.na(lab[r,s])) {
+ estr <- paste0("\"",nodes[r],"~",nodes[s],"\"")
+ estr2 <- paste0(nodes[r],"~",nodes[s])
+ Debug(estr, debug)
+ if (expr)
+ st <- eval(parse(text=paste0("expression(",lab[r,s],")")))
+ else
+ st <- lab[r,s]
+ object$edgerender$label[estr2] <- st
+ }
+ }
+ }
+ return(object)
+}
+
+###}}} edgelabels
diff --git a/R/latent.R b/R/latent.R
new file mode 100644
index 0000000..d345d32
--- /dev/null
+++ b/R/latent.R
@@ -0,0 +1,70 @@
+##' @export
+"latent<-" <- function(x,...,value) UseMethod("latent<-")
+
+##' @export
+"latent<-.lvm" <- function(x, clear=FALSE,..., value) {
+ if (inherits(value,"formula")) {
+ return(latent(x,all.vars(value),clear=clear,...))
+ }
+ latent(x, var=value, clear=clear,...)
+}
+
+##' @export
+`latent` <-
+function(x,...) UseMethod("latent")
+
+##' @export
+`latent.lvm` <- function(x,var,clear=FALSE,silent=lava.options()$silent,...) {
+ if (missing(var)) {
+ latentidx <- unlist(x$latent)
+ if (length(latentidx)>0)
+ return(names(latentidx))
+ else
+ return(NULL)
+ }
+ if (inherits(var,"formula")) var <- all.vars(var)
+ if (clear) {
+ x$noderender$shape[var] <- "rectangle"
+ x$latent[var] <- NULL
+ ## intfix(x,var) <- NA
+ } else {
+ if (!all(var%in%vars(x))) {
+ addvar(x,silent=silent,reindex=FALSE,) <- setdiff(var,vars(x))
+ }
+ x$noderender$shape[var] <- "ellipse"
+ x$latent[var] <- TRUE
+ ord <- intersect(var,ordinal(x))
+ if (length(ord)>0) ordinal(x,K=NULL) <- ord
+ }
+
+ xorg <- exogenous(x)
+ exoset <- setdiff(xorg,var)
+ if (length(exoset)<length(xorg)) {
+ exogenous(x) <- exoset
+ }
+
+ index(x) <- reindex(x)
+ return(x)
+}
+
+##' @export
+`latent.lvmfit` <-
+ function(x,clear=FALSE,...) {
+ latent(Model(x),...)
+ }
+
+##' @export
+latent.list <- function(x,...) {
+ latlist <- c()
+ for (i in seq_along(x)) {
+ latlist <- c(latlist, latent(x[[i]]))
+ }
+ latlist <- unique(latlist)
+ return(latlist)
+}
+
+##' @export
+`latent.multigroup` <-
+function(x,...) {
+ latent(Model(x))
+}
diff --git a/R/lava-package.R b/R/lava-package.R
new file mode 100644
index 0000000..97b47f2
--- /dev/null
+++ b/R/lava-package.R
@@ -0,0 +1,256 @@
+
+##' Estimation and simulation of latent variable models
+##'
+##' Framwork for estimating parameters and simulate data from Latent Variable
+##' Models.
+##'
+##' @name lava-package
+##' @importFrom graphics plot lines points abline points text layout
+##' par plot.new plot.window title rect locator segments image
+##' mtext box axis polygon matplot contour contour.default
+##' identify
+##' @importFrom grDevices xy.coords col2rgb rgb colors rainbow
+##' topo.colors gray.colors palette colorRampPalette heat.colors
+##' @importFrom utils stack combn read.csv getTxtProgressBar
+##' setTxtProgressBar txtProgressBar head tail modifyList
+##' getFromNamespace packageVersion write.table methods data
+##' glob2rx
+##' @importFrom stats density deriv effects lm family simulate vcov
+##' var cov cor coef model.frame model.weights as.formula
+##' model.matrix rnorm rchisq runif rlnorm pnorm qnorm na.omit AIC
+##' terms logLik qt pt update update.formula confint approxfun
+##' pchisq confint.default formula fft uniroot rbinom predict sd
+##' addmargins residuals dnorm quantile qf cov2cor qchisq
+##' get_all_vars p.adjust rpois rgamma printCoefmat rt glm nlminb
+##' na.pass na.omit
+##' @importFrom survival is.Surv
+##' @importFrom methods new as
+##' @aliases lava-package lava
+##' @docType package
+##' @author Klaus K. Holst Maintainer: <k.k.holst@@biostat.ku.dk>
+##' @keywords package
+##' @examples
+##'
+##' lava()
+##'
+NULL
+
+##' Longitudinal Bone Mineral Density Data
+##'
+##' Bone Mineral Density Data consisting of 112 girls randomized to receive
+##' calcium og placebo. Longitudinal measurements of bone mineral density
+##' (g/cm^2) measured approximately every 6th month in 3 years.
+##'
+##'
+##' @name calcium
+##' @docType data
+##' @format A data.frame containing 560 (incomplete) observations. The 'person'
+##' column defines the individual girls of the study with measurements at
+##' visiting times 'visit', and age in years 'age' at the time of visit. The
+##' bone mineral density variable is 'bmd' (g/cm^2).
+##' @source Vonesh & Chinchilli (1997), Table 5.4.1 on page 228.
+##' @keywords datasets
+NULL
+
+##' Longitudinal Bone Mineral Density Data (Wide format)
+##'
+##' Bone Mineral Density Data consisting of 112 girls randomized to receive
+##' calcium og placebo. Longitudinal measurements of bone mineral density
+##' (g/cm^2) measured approximately every 6th month in 3 years.
+##' @name bmd
+##' @docType data
+##' @source Vonesh & Chinchilli (1997), Table 5.4.1 on page 228.
+##' @format data.frame
+##' @keywords datasets
+##' @seealso calcium
+NULL
+
+##' Simulated data
+##'
+##' Simulated data
+##' @name brisa
+##' @docType data
+##' @format data.frame
+##' @source Simulated
+##' @keywords datasets
+NULL
+
+##' Data
+##'
+##' Description
+##' @name bmidata
+##' @docType data
+##' @format data.frame
+##' @keywords datasets
+NULL
+
+##' Hubble data
+##'
+##' Velocity (v) and distance (D) measures of 36 Type Ia super-novae from the Hubble
+##' Space Telescope
+##' @name hubble
+##' @docType data
+##' @format data.frame
+##' @source Freedman, W. L., et al. 2001, AstroPhysicalJournal, 553, 47.
+##' @keywords datasets
+NULL
+
+##' Hubble data
+##'
+##' @name hubble2
+##' @seealso hubble
+##' @docType data
+##' @format data.frame
+##' @keywords datasets
+NULL
+
+##' Data
+##'
+##' Description
+##' @name indoorenv
+##' @docType data
+##' @format data.frame
+##' @source Simulated
+##' @keywords datasets
+NULL
+
+##' Missing data example
+##'
+##' Simulated data generated from model
+##' \deqn{E(Y_i\mid X) = X, \quad cov(Y_1,Y_2\mid X)=0.5}
+##'
+##' The list contains four data sets
+##' 1) Complete data
+##' 2) MCAR
+##' 3) MAR
+##' 4) MNAR (missing mechanism depends on variable V correlated with Y1,Y2)
+##' @examples
+##' data(missingdata)
+##' e0 <- estimate(lvm(c(y1,y2)~b*x,y1~~y2),missingdata[[1]]) ## No missing
+##' e1 <- estimate(lvm(c(y1,y2)~b*x,y1~~y2),missingdata[[2]]) ## CC (MCAR)
+##' e2 <- estimate(lvm(c(y1,y2)~b*x,y1~~y2),missingdata[[2]],missing=TRUE) ## MCAR
+##' e3 <- estimate(lvm(c(y1,y2)~b*x,y1~~y2),missingdata[[3]]) ## CC (MAR)
+##' e4 <- estimate(lvm(c(y1,y2)~b*x,y1~~y2),missingdata[[3]],missing=TRUE) ## MAR
+##' @name missingdata
+##' @docType data
+##' @format list of data.frames
+##' @source Simulated
+##' @keywords datasets
+NULL
+
+##' Example data (nonlinear model)
+##'
+##' @name nldata
+##' @docType data
+##' @format data.frame
+##' @source Simulated
+##' @keywords datasets
+NULL
+
+##' Example SEM data (nonlinear)
+##'
+##' Simulated data
+##' @name nsem
+##' @docType data
+##' @format data.frame
+##' @source Simulated
+##' @keywords datasets
+NULL
+
+##' Example SEM data
+##'
+##' Simulated data
+##' @name semdata
+##' @docType data
+##' @source Simulated
+##' @format data.frame
+##' @keywords datasets
+NULL
+
+##' Serotonin data
+##'
+##' This simulated data mimics a PET imaging study where the 5-HT2A
+##' receptor and serotonin transporter (SERT) binding potential has
+##' been quantified into 8 different regions. The 5-HT2A
+##' cortical regions are considered high-binding regions
+## 'which are a priori known to yield quite similar and highly correlated
+##' measurements. These measurements can be regarded as proxy measures of
+##' the extra-cellular levels of serotonin in the brain
+##' \tabular{rll}{
+##' day \tab numeric \tab Scan day of the year \cr
+##' age \tab numeric \tab Age at baseline scan \cr
+##' mem \tab numeric \tab Memory performance score \cr
+##' depr \tab numeric \tab Depression (mild) status 500 days after baseline \cr
+##' gene1 \tab numeric \tab Gene marker 1 (HTR2A) \cr
+##' gene2 \tab numeric \tab Gene marker 2 (HTTTLPR) \cr
+##' cau \tab numeric \tab SERT binding, Caudate Nucleus \cr
+##' th \tab numeric \tab SERT binding, Thalamus \cr
+##' put \tab numeric \tab SERT binding, Putamen \cr
+##' mid \tab numeric \tab SERT binding, Midbrain \cr
+##' aci \tab numeric \tab 5-HT2A binding, Anterior cingulate gyrus \cr
+##' pci \tab numeric \tab 5-HT2A binding, Posterior cingulate gyrus \cr
+##' sfc \tab numeric \tab 5-HT2A binding, Superior frontal cortex \cr
+##' par \tab numeric \tab 5-HT2A binding, Parietal cortex \cr
+##' }
+##' @name serotonin
+##' @docType data
+##' @format data.frame
+##' @source Simulated
+##' @keywords datasets
+NULL
+
+##' Data
+##'
+##' Description
+##' @seealso serotonin
+##' @name serotonin2
+##' @docType data
+##' @format data.frame
+##' @source Simulated
+##' @keywords datasets
+NULL
+
+##' Twin menarche data
+##'
+##' Simulated data
+##' \tabular{rll}{
+##' id \tab numeric \tab Twin-pair id \cr
+##' zyg \tab character \tab Zygosity (MZ or DZ) \cr
+##' twinnum \tab numeric \tab Twin number (1 or 2) \cr
+##' agemena \tab numeric \tab Age at menarche (or censoring) \cr
+##' status \tab logical \tab Censoring status (observed:=T,censored:=F) \cr
+##' bw \tab numeric \tab Birth weight \cr
+##' msmoke \tab numeric \tab Did mother smoke? (yes:=1,no:=0) \cr
+##' }
+##' @name twindata
+##' @docType data
+##' @format data.frame
+##' @keywords datasets
+##' @source Simulated
+NULL
+
+
+##' For internal use
+##'
+##' @title For internal use
+##' @name startvalues
+##' @rdname internal
+##' @author Klaus K. Holst
+##' @keywords utilities
+##' @export
+##' @aliases
+##' startvalues0 startvalues1 startvalues2 startvalues3
+##' starter.multigroup
+##' addattr modelPar modelVar matrices pars pars.lvm
+##' pars.lvmfit pars.glm score.glm procdata.lvmfit modelPar modelVar
+##' matrices reorderdata graph2lvm igraph.lvm subgraph finalize
+##' index.lvm index.lvmfit index reindex index<-
+##' survival survival<- ordinal ordinal<-
+##' rmvn dmvn NR logit expit tigol
+##' randomslope randomslope<- lisrel variances offdiags describecoef
+##' parlabels rsq stdcoef CoefMat CoefMat.multigroupfit deriv updatelvm
+##' checkmultigroup profci estimate.MAR missingModel Inverse
+##' gaussian_logLik.lvm addhook gethook multigroup Weights fixsome
+##' parfix parfix<- merge IV parameter index index<-
+##' Specials procformula getoutcome decomp.specials
+NULL
diff --git a/R/lisrel.R b/R/lisrel.R
new file mode 100644
index 0000000..12b113c
--- /dev/null
+++ b/R/lisrel.R
@@ -0,0 +1,49 @@
+
+lisrel <- function(model,p,X=NULL,muX=NULL,varX=NULL,...) {
+ pp <- modelPar(model,p)
+ mom <- moments(model,p)
+ A <- t(index(model)$M)
+ J <- index(model)$J ## Observed var. selection matrix
+
+ eta.idx <- match(latent(model),vars(model))
+ obs.idx <- match(manifest(model),vars(model))
+ exo.idx <- match(exogenous(model),vars(model))
+ y <- setdiff(manifest(model), exogenous(model))
+ y.idx <- match(y, vars(model))
+
+## Jy <- Jx <- Jeta <- I <- diag(length(vars(model)))
+## if (length(eta.idx)>0)
+## J[eta.idx,eta.idx] <- 0; J <- J[-eta.idx,]
+## Jeta[obs.idx,obs.idx] <- 0; Jeta <- J[-obs.idx,]
+
+ A <- t(mom$A)
+ Lambda <- A[y.idx,eta.idx,drop=FALSE]
+ K <- A[y.idx,exo.idx,drop=FALSE]
+ B <- A[eta.idx,eta.idx,drop=FALSE]
+ I <- diag(nrow=nrow(B))
+ Gamma <- A[eta.idx,exo.idx,drop=FALSE]
+ V <- mom$P
+ Psi <- V[eta.idx,eta.idx] ## Residual variance
+
+ Theta <- V[y.idx,y.idx] ## -
+ IBi <- if (ncol(I)>0) solve(I-B) else I
+ LIBi <- Lambda%*%IBi
+ Phi <- LIBi%*%Gamma + K
+
+ Veta.x <- IBi%*%Psi%*%IBi ## Variance of eta given x
+ COVetay.x <- Veta.x%*%t(Lambda) ## Covariance of eta,y given x
+## Vy.x <- Lambda%*%COVetay.x + Theta ## Omega
+ Vy.x <- LIBi%*%Psi%*%t(LIBi) + Theta
+
+ if (!is.null(X)) {
+ Ey.x <- t(apply(as.matrix(X)%*% t(LIBi%*%Gamma + K),1,function(x) x + mom$v[y.idx]))
+ } else Ey.x <- NULL
+
+ Sigma <- mom$Cfull
+ CV <- COVetay.x%*%Vy.x
+
+## Sigma <- Vy.x + Phi%*%varX%*%t(Phi)
+
+ return(list(Lambda=Lambda, K=K, B=B, I=I, Gamma=Gamma, Psi=Psi, Theta=Theta, IBi=IBi, LIBi=LIBi, Phi=Phi,
+ Vy.x=Vy.x, Veta.x=Veta.x, COVetay.x=COVetay.x, CV=CV, Ey.x=Ey.x))
+}
diff --git a/R/lmers.R b/R/lmers.R
new file mode 100644
index 0000000..bd9dacd
--- /dev/null
+++ b/R/lmers.R
@@ -0,0 +1,62 @@
+##v <- lmerplot(l1,varcomp=TRUE,colorkey=TRUE,lwd=0,col=rainbow(20))
+lmerplot <- function(model,x,id,y,transform,re.form=NULL,varcomp=FALSE,colorbar=TRUE,mar=c(4,4,4,6),col,index=seq(50),...) {
+ if (varcomp) {
+ Z <- lme4::getME(model,"Z")
+ nn <- unlist(lapply(lme4::getME(model,"Ztlist"),nrow))
+ ve <- lme4::getME(model,"sigma")^2
+ vu <- varcomp(model,profile=FALSE)$varcomp
+ L <- Matrix::Diagonal(sum(nn),rep(vu,nn))
+ V <- Z%*%L%*%(Matrix::t(Z))
+ Matrix::diag(V) <- Matrix::diag(V)+ve
+ cV <- Matrix::cov2cor(V)
+ if (!is.null(index)) {
+ index <- intersect(seq(nrow(cV)),index)
+ cV <- cV[index,index,drop=FALSE]
+ }
+ if (colorbar) { opt <- par(mar=mar) }
+ ##if (missing(col)) col <- c("white",rev(heat.colors(16)))
+ if (missing(col)) col <- rev(gray.colors(16,0,1))
+ image(seq(nrow(cV)),seq(ncol(cV)),as.matrix(cV),xlab="",ylab="",col=col,zlim=c(0,1),...)
+ if (colorbar) {
+ uu <- devcoords()
+ xrange <- c(uu$fig.x2,uu$dev.x2)
+ xrange <- diff(xrange)/3*c(1,-1)+xrange
+ yrange <- c(uu$fig.y1,uu$fig.y2)
+ colorbar(direction="vertical",x.range=xrange,y.range=yrange,clut=col,values=seq(0,1,length.out=length(col)),srt=0,position=2)
+ par(opt)
+ }
+ return(invisible(V))
+ }
+ if (missing(y)) y <- model.frame(model)[,1]
+ yhat <- predict(model)
+ if (!is.null(re.form)) ymean <- predict(model,re.form=re.form)
+ if (!missing(transform)) {
+ yhat <- transform(yhat)
+ if (!is.null(re.form)) ymean <- transform(ymean)
+ y <- transform(y)
+ }
+ plot(y ~ x, col=Col(id,0.3), pch=16,...)
+ if (!is.null(re.form)) points(ymean ~ x, pch="-",cex=4);
+ for (i in unique(id)) {
+ idx <- which(id==i)
+ lines(yhat[idx]~x[idx],col=i)
+ }
+}
+
+varcomp <- function(x,profile=TRUE,...) {
+ cc <- cbind(lme4::fixef(x),diag(as.matrix(vcov(x)))^.5)
+ cc <- cbind(cc,cc[,1]-qnorm(0.975)*cc[,2],cc[,1]+qnorm(0.975)*cc[,2],
+ 2*(1-pnorm(abs(cc[,1])/cc[,2])))
+ pr <- NULL
+ if (profile) pr <- confint(x)
+ colnames(cc) <- c("Estimate","Std.Err","2.5%","97.5%","p-value")
+ vc <- lme4::VarCorr(x)
+ res <- structure(list(coef=lme4::fixef(x), vcov=as.matrix(vcov(x)),
+ coefmat=cc,
+ confint=pr,
+ varcomp=vc[[1]][,],
+ residual=attributes(vc)$sc^2
+ ),
+ class="estimate.lmer")
+ res
+}
diff --git a/R/logLik.R b/R/logLik.R
new file mode 100644
index 0000000..7e1e9cf
--- /dev/null
+++ b/R/logLik.R
@@ -0,0 +1,350 @@
+###{{{ logLik.lvm
+
+##' @export
+logLik.lvm <- function(object,p,data,model="gaussian",indiv=FALSE,S,mu,n,debug=FALSE,weights=NULL,data2=NULL,...) {
+ cl <- match.call()
+ xfix <- colnames(data)[(colnames(data)%in%parlabels(object,exo=TRUE))]
+
+ constr <- lapply(constrain(object), function(z)(attributes(z)$args))
+ xconstrain <- intersect(unlist(constr), manifest(object))
+ xconstrainM <- TRUE
+ if (length(xconstrain)>0) {
+ constrainM <- names(constr)%in%unlist(object$mean)
+ for (i in seq_len(length(constr))) {
+ if (!constrainM[i]) {
+ if (any(constr[[i]]%in%xconstrain)) xconstrainM <- FALSE
+ }
+ }
+ }
+
+ Debug(xfix,debug)
+ if (missing(n)) {
+ n <- nrow(data)
+ if (is.null(n)) n <- data$n
+ }
+ lname <- paste0(model,"_logLik.lvm")
+ logLikFun <- get(lname)
+
+
+ if (length(xfix)>0 | (length(xconstrain)>0 & !xconstrainM & !lava.options()$test & model!="gaussian")) { ##### Random slopes!
+ x0 <- object
+ if (length(xfix)>0) {
+ Debug("random slopes...",debug)
+ nrow <- length(vars(object))
+ xpos <- lapply(xfix,function(y) which(regfix(object)$labels==y))
+ colpos <- lapply(xpos, function(y) ceiling(y/nrow))
+ rowpos <- lapply(xpos, function(y) (y-1)%%nrow+1)
+ myfix <- list(var=xfix, col=colpos, row=rowpos)
+ for (i in seq_along(myfix$var))
+ for (j in seq_along(myfix$col[[i]])) {
+ regfix(x0, from=vars(x0)[myfix$row[[i]][j]],to=vars(x0)[myfix$col[[i]][j]]) <-
+ data[1,myfix$var[[i]]]
+ }
+ index(x0) <- reindex(x0,zeroones=TRUE,deriv=TRUE)
+ }
+ k <- length(index(x0)$manifest)
+ myfun <- function(ii) {
+ if (length(xfix)>0)
+ for (i in seq_along(myfix$var)) {
+ index(x0)$A[cbind(myfix$row[[i]],myfix$col[[i]])] <- data[ii,myfix$var[[i]]]
+ }
+ return(logLikFun(x0,data=data[ii,,drop=FALSE], p=p,weights=weights[ii,,drop=FALSE],data2=data2[ii,,drop=FALSE],
+ model=model,debug=debug,indiv=indiv,...))
+ }
+ loglik <- sapply(seq_len(nrow(data)),myfun)
+ if (!indiv) {
+ loglik <- sum(loglik)
+ n <- nrow(data)
+ attr(loglik, "nall") <- n
+ attr(loglik, "nobs") <- n
+ attr(loglik, "df") <- length(p)
+ class(loglik) <- "logLik"
+ }
+ return(loglik)
+ }
+
+ if (xconstrainM) {
+ xconstrain <- c()
+ for (i in seq_len(length(constrain(object)))) {
+ z <- constrain(object)[[i]]
+ xx <- intersect(attributes(z)$args,manifest(object))
+ if (length(xx)>0) {
+ warg <- setdiff(attributes(z)$args,xx)
+ wargidx <- which(attributes(z)$args%in%warg)
+ exoidx <- which(attributes(z)$args%in%xx)
+ parname <- names(constrain(object))[i]
+ y <- names(which(unlist(lapply(intercept(object),function(x) x==parname))))
+ el <- list(i,y,parname,xx,exoidx,warg,wargidx,z)
+ names(el) <- c("idx","endo","parname","exo","exoidx","warg","wargidx","func")
+ xconstrain <- c(xconstrain,list(el))
+ }
+ }
+ if (length(xconstrain)>0) {
+ yconstrain <- unlist(lapply(xconstrain,function(x) x$endo))
+ iconstrain <- unlist(lapply(xconstrain,function(x) x$idx))
+
+ Mu <- matrix(0,nrow(data),length(vars(object))); colnames(Mu) <- vars(object)
+ M <- modelVar(object,p=p,data=data)
+ M$parval <- c(M$parval, object$mean[unlist(lapply(object$mean,is.numeric))])
+ for (i in seq_len(length(xconstrain))) {
+ pp <- unlist(M$parval[xconstrain[[i]]$warg]);
+ myidx <- with(xconstrain[[i]],order(c(wargidx,exoidx)))
+ mu <- with(xconstrain[[i]],
+ apply(data[,exo,drop=FALSE],1,
+ function(x) {
+ func(unlist(c(pp,x))[myidx])
+ }))
+ Mu[,xconstrain[[i]]$endo] <- mu
+ }
+ offsets <- Mu%*%t(M$IAi)[,endogenous(object),drop=FALSE]
+ object$constrain[iconstrain] <- NULL
+ object$mean[yconstrain] <- 0
+ loglik <- do.call(lname, c(list(object=object,p=p,data=data,indiv=indiv,weights=weights,data2=data2,offset=offsets),list(...)))
+ } else {
+ cl[[1]] <- logLikFun
+ loglik <- eval.parent(cl)
+ }
+ } else {
+ loglik <- 0
+ if (length(xconstrain)>0 && NROW(data)>1) {
+ for (ii in seq(nrow(data))) {
+ cl$data <- data[ii,]
+ cl$weights <- weights[ii,]
+ cl$data2 <- data2[ii,]
+ loglik <- loglik+eval.parent(cl)
+ }
+ } else {
+ cl[[1]] <- logLikFun
+ loglik <- eval.parent(cl)
+ }
+ }
+
+ if (is.null(attr(loglik,"nall")))
+ attr(loglik, "nall") <- n
+ if (is.null(attr(loglik,"nobs")))
+ attr(loglik, "nobs") <- n##-length(p)
+ if (is.null(attr(loglik,"df")))
+ attr(loglik, "df") <- length(p)
+ class(loglik) <- "logLik"
+ return(loglik)
+}
+
+###}}}
+
+###{{{ gaussian_loglik
+
+##' @export
+gaussian_logLik.lvm <- function(object,p,data,
+ type=c("cond","sim","exo","sat","cond2"),
+ weights=NULL, indiv=FALSE, S, mu, n, offset=NULL, debug=FALSE, meanstructure=TRUE,...) {
+ exo.idx <- with(index(object), exo.obsidx)
+ endo.idx <- with(index(object), endo.obsidx)
+ if (type[1]=="exo") {
+ if (length(exo.idx)==0 || is.na(exo.idx))
+ return(0)
+ }
+
+ cl <- match.call()
+ if (type[1]=="cond") {
+ cl$type <- "sim"
+ L0 <- eval.parent(cl)
+ cl$type <- "exo"
+ L1 <- eval.parent(cl)
+ loglik <- L0-L1
+ return(loglik)
+ }
+
+ if (missing(n)) {
+ if (is.vector(data)) n <- 1
+ else n <- nrow(data)
+ }
+ k <- length(index(object)$manifest)
+
+ if (!is.null(offset) && type[1]!="exo") {
+ data[,colnames(offset)] <- data[,colnames(offset)]-offset
+ }
+
+ if (type[1]=="sat") {
+ if (missing(S)) {
+ d0 <- procdata.lvm(object,data=data)
+ S <- d0$S; mu <- d0$mu; n <- d0$n
+
+ }
+ if (missing(p)) p <- rep(1,length(coef(object)))
+ L1 <- logLik(object,p,data,type="exo",meanstructure=meanstructure)
+ ## Sigma <- (n-1)/n*S ## ML = 1/n * sum((xi-Ex)^2)
+ Sigma <- S
+ loglik <- -(n*k)/2*log(2*base::pi) -n/2*(log(det(Sigma)) + k) - L1
+ P <- length(endo.idx)
+ k <- length(exo.idx)
+ npar <- P*(1+(P-1)/2)
+ if (meanstructure) npar <- npar+ (P*k + P)
+ attr(loglik, "nall") <- n
+ attr(loglik, "nobs") <- n
+ attr(loglik, "df") <- npar
+ class(loglik) <- "logLik"
+ return(loglik)
+ }
+ myidx <- switch(type[1],
+ sim = seq_along(index(object)$manifest),
+ cond = { endo.idx },
+ cond2 = { endo.idx },
+ exo = { exo.idx } )
+
+ mom <- moments(object, p, conditional=(type[1]=="cond2"), data=data)
+
+ if (!lava.options()$allow.negative.variance && any(diag(mom$P)<0)) return(NaN)
+
+ C <- mom$C
+ xi <- mom$xi
+ if (type[1]=="exo") {
+ C <- C[exo.idx,exo.idx,drop=FALSE]
+ xi <- xi[exo.idx,drop=FALSE]
+ }
+ Debug(list("C=",C),debug)
+ k <- nrow(C)
+
+ iC <- Inverse(C,det=TRUE, symmetric = TRUE)
+ detC <- attributes(iC)$det
+
+ if (!is.null(weights)) {
+ weights <- cbind(weights)
+ K <- length(exo.idx)+length(endo.idx)
+ if (ncol(weights)!=1 & ncol(weights)!=K) {
+ w.temp <- weights
+ weights <- matrix(1,nrow=nrow(weights),ncol=K)
+ weights[,endo.idx] <- w.temp
+ }
+ if (type=="exo")
+ weights <- NULL
+ }
+
+ notdatalist <- (!is.list(data) | is.data.frame(data))
+ if (missing(n))
+ if (!missing(data)) n <- NROW(data)
+ if (!missing(n))
+ if (notdatalist & (n<2 | indiv | !is.null(weights))) {
+ if (n==1)
+ data <- rbind(data)
+ res <- numeric(n)
+ data <- data[,index(object)$manifest,drop=FALSE]
+ loglik <- 0;
+ for (i in seq_len(n)) {
+ ti <- as.numeric(data[i,myidx])
+ if (meanstructure) {
+ ti <- cbind(ti-as.numeric(xi))
+ }
+ if (!is.null(weights)) {
+ W <- diag(weights[i,],nrow=length(weights[i,]))
+ val <- -k/2*log(2*base::pi) -1/2*log(detC) - 1/2*(t(ti)%*%W)%*%iC%*%(ti)
+ } else {
+ val <- -k/2*log(2*base::pi) -1/2*log(detC) - 1/2*t(ti)%*%iC%*%(ti)
+ }
+ if (indiv)
+ res[i] <- val
+ loglik <- loglik + val
+ }
+ if (indiv)
+ return(res)
+ } else {
+ if (missing(S)) {
+ d0 <- procdata.lvm(object,data=data)
+ S <- d0$S; mu <- d0$mu; n <- d0$n
+ }
+ S <- S[myidx,myidx,drop=FALSE]
+ mu <- mu[myidx,drop=FALSE]
+ T <- S
+ if (meanstructure) {
+ W <- crossprod(rbind(mu-xi))
+ T <- S+W
+ }
+ loglik <- -(n*k)/2*log(2*base::pi) -n/2*(log(detC) + tr(T%*%iC))
+ }
+ return(loglik)
+}
+
+###}}}
+
+###{{{ logLik.lvmfit
+
+##' @export
+logLik.lvmfit <- function(object,
+ p=coef(object),
+ data=model.frame(object),
+ model=object$estimator,
+ weights=Weights(object),
+ data2=object$data$data2,
+ ...) {
+
+ logLikFun <- paste0(model,"_logLik.lvm")
+ if (!exists(logLikFun)) {
+ model <- "gaussian"
+ }
+ l <- logLik.lvm(object$model0,p,data,model=model,weights=weights,
+ data2=data2,
+ ...)
+ return(l)
+}
+
+###}}} logLik.lvmfit
+
+###{{{ logLik.lvm.missing
+
+##' @export
+logLik.lvm.missing <- function(object,
+ p=pars(object), model=object$estimator,
+ weights=Weights(object$estimate),
+ ...) {
+ logLik(object$estimate$model0, p=p, model=model, weights=weights, ...)
+}
+
+###}}}
+
+###{{{ logLik.multigroup
+
+##' @export
+logLik.multigroup <- function(object,p,data=object$data,weights=NULL,type=c("cond","sim","exo","sat"),...) {
+ res <- procrandomslope(object)
+ pp <- with(res, modelPar(model,p)$p)
+
+ if (type[1]=="sat") {
+ n <- 0
+ df <- 0
+ loglik <- 0
+ for (i in seq_len(object$ngroup)) {
+ m <- Model(object)[[i]]
+ L <- logLik(m,p=pp[[i]],data=object$data[[i]],type="sat")
+ df <- df + attributes(L)$df
+ loglik <- loglik + L
+ n <- n + object$samplestat[[i]]$n
+ }
+ attr(loglik, "nall") <- n
+ attr(loglik, "nobs") <- n##-df
+ attr(loglik, "df") <- df
+ class(loglik) <- "logLik"
+ return(loglik)
+ }
+
+ n <- 0
+ loglik <- 0; for (i in seq_len(object$ngroup)) {
+ n <- n + object$samplestat[[i]]$n
+ val <- logLik(object$lvm[[i]],pp[[i]],data[[i]],weights=weights[[i]],type=type,...)
+ loglik <- loglik + val
+ }
+ attr(loglik, "nall") <- n
+ attr(loglik, "nobs") <- n##-length(p)
+ attr(loglik, "df") <- length(p)
+ class(loglik) <- "logLik"
+ return(loglik)
+}
+
+###}}} logLik.multigroup
+
+###{{{ logLik.multigroupfit
+
+##' @export
+logLik.multigroupfit <- function(object,
+ p=pars(object), weights=Weights(object), model=object$estimator, ...) {
+ logLik(object$model0,p=p,weights=weights,model=model,...)
+}
+###}}} logLik.multigroup
diff --git a/R/logo.R b/R/logo.R
new file mode 100644
index 0000000..14b304f
--- /dev/null
+++ b/R/logo.R
@@ -0,0 +1,33 @@
+gfilter <- function(x,sigma=1) {
+ gridfn <- function(fn,width,height,center=TRUE) {
+ jx <- seq_len(height)
+ jy <- seq_len(width)
+ if (center) {
+ jx <- jx/height-0.5
+ jy <- jy/width-0.5
+ }
+ outer(jx, jy, FUN=fn)
+ }
+ width <- ncol(x); height <- nrow(x)
+ oscunits <- gridfn(function(x,y) ((-1)^(x+y)),height=height,width=width,center=FALSE)
+ x0 <- x*oscunits ## translate origo to center of image
+ X <- fft(x0)
+ d <- gridfn(function(x,y) (x^2+y^2),height=height,width=width,center=TRUE)
+ Gn <- exp(-2*(base::pi*sigma)^2*d) # frequency response
+ H <- X*Gn
+ res <- Re(fft(H,inverse=TRUE))/(width*height)*oscunits
+ return(res)
+}
+
+##' @export
+lava <- function(seed,w=128,h=w,bw=4,sigma=5000,bg=20000,numcol=128,col=grDevices::heat.colors(numcol),...) {
+ if (!missing(seed))
+ set.seed(seed)
+ x <- matrix(rnorm(w*h,bg,sigma),nrow=h, ncol=w)
+ x0 <- gfilter(x,sigma=bw)
+ y <- (x0-min(x0)+1)^1.2
+ opt <- graphics::par(mai=c(0,0,0,0))
+ graphics::image(y,axes=FALSE,col=col)
+ graphics::par(opt)
+ invisible(y)
+}
diff --git a/R/lvm.R b/R/lvm.R
new file mode 100644
index 0000000..88805a2
--- /dev/null
+++ b/R/lvm.R
@@ -0,0 +1,110 @@
+##' Initialize new latent variable model
+##'
+##' Function that constructs a new latent variable model object
+##'
+##' @aliases lvm print.lvm summary.lvm
+##' @param x Vector of variable names. Optional but gives control of the
+##' sequence of appearance of the variables. The argument can be given as a
+##' character vector or formula, e.g. \code{~y1+y2} is equivalent to
+##' \code{c("y1","y2")}. Alternatively the argument can be a formula specifying
+##' a linear model.
+##' @param \dots Additional arguments to be passed to the low level functions
+##' @param latent (optional) Latent variables
+##' @param silent Logical variable which indicates whether messages are turned
+##' on/off.
+##' @return Returns an object of class \code{lvm}.
+##' @author Klaus K. Holst
+##' @seealso \code{\link{regression}}, \code{\link{covariance}},
+##' \code{\link{intercept}}, ...
+##' @keywords models regression
+##' @export
+##' @examples
+##'
+##' m <- lvm() # Empty model
+##' m1 <- lvm(y~x) # Simple linear regression
+##' m2 <- lvm(~y1+y2) # Model with two independent variables (argument)
+##' m3 <- lvm(list(c(y1,y2,y3)~u,u~x+z)) # SEM with three items
+##'
+lvm <- function(x=NULL, ..., latent=NULL, silent=lava.options()$silent) {
+
+ M <- C <- par <- fix <- numeric(); mu <- list()
+
+ noderender <- list(
+ fill=c(),
+ shape=c(),
+ label=c()
+ )
+
+ edgerender <- list(lty=c(),
+ lwd=c(),
+ col=c(),
+ textCol=c(),
+ est=c(),
+ arrowhead=c(),
+ dir=c(),
+ cex=c(),
+ futureinfo=list())
+ graphrender <- list(recipEdges="distinct")
+
+ graphdefault <- list(
+ "fill"="white",
+ "shape"="rectangle",
+ "label"=expression(NA),
+ "lty"=1,
+ "lwd"=1,
+ "col"="black",
+ "textCol"="black",
+ "est"=0,
+ "arrowhead"="open",
+ "dir"="forward",
+ "cex"=1.5,
+ "label"=expression(),
+ "futureinfo"=c())
+
+ modelattr <- list(
+ randomslope=list(),
+ survival=list(),
+ parameter=list(),
+ categorical=list(),
+ distribution=list(),
+ nonlinear=list(),
+ functional=list(),
+ label=list())
+
+ res <- list(M=M, par=par, cov=C, covpar=C, fix=fix, covfix=fix,latent=list(),
+ mean=mu, index=NULL, exogenous=NA,
+ constrain=list(), constrainY=list(),
+ attributes=modelattr, noderender=noderender,
+ edgerender=edgerender, graphrender=graphrender,
+ graphdef=graphdefault)
+ class(res) <- "lvm"
+
+ myhooks <- gethook("init.hooks")
+ for (f in myhooks) {
+ res <- do.call(f, list(x=res))
+ }
+
+ myvar <- NULL
+ if (!is.list(x)) x <- list(x,...)
+ for (myvar in x) {
+ if (inherits(myvar,"formula")) {
+ ## if (length(getoutcome(myvar))>0) {
+ ## regression(res,...,silent=silent) <- myvar
+ ## } else {
+ ## myvar <- all.vars(myvar)
+ ## }
+ ## regression(res,...,silent=silent) <- myvar
+ regression(res,silent=silent) <- myvar
+ }
+ if (is.character(myvar)) {
+ res <- addvar(res, myvar, silent=silent) }
+ }
+ if (!is.null(myvar)) {
+ index(res) <- reindex(res,zeroones=TRUE) }
+
+ if (!is.null(latent)) {
+ latent(res) <- latent
+ }
+
+ return(res)
+}
diff --git a/R/makemissing.R b/R/makemissing.R
new file mode 100644
index 0000000..b929142
--- /dev/null
+++ b/R/makemissing.R
@@ -0,0 +1,22 @@
+##' Generates missing entries in data.frame/matrix
+##'
+##' @title Create random missing data
+##' @param data data.frame
+##' @param p Fraction of missing data in each column
+##' @param cols Which columns (name or index) to alter
+##' @param rowwise Should missing occur row-wise (either none or all selected columns are missing)
+##' @param nafun (Optional) function to be applied on data.frame before return (e.g. \code{na.omit} to return complete-cases only)
+##' @return data.frame
+##' @author Klaus K. Holst
+##' @keywords utilities
+##' @export
+makemissing <- function(data,p=0.2,cols=seq_len(ncol(data)),rowwise=FALSE,nafun=function(x) x) {
+ p <- rep(p,length.out=length(cols))
+ if (!rowwise)
+ for (i in seq_along(cols)) {
+ data[rbinom(nrow(data),1,p[i])==1,cols[i]] <- NA
+ }
+ else
+ data[which(rbinom(nrow(data),1,p)==1),cols] <- NA
+ return(nafun(data))
+}
diff --git a/R/manifest.R b/R/manifest.R
new file mode 100644
index 0000000..5c711e7
--- /dev/null
+++ b/R/manifest.R
@@ -0,0 +1,34 @@
+##' @export
+`manifest` <-
+function(x,...) UseMethod("manifest")
+
+##' @export
+`manifest.lvm` <-
+function(x,...) {
+ if (length(vars(x))>0)
+ setdiff(vars(x),latent(x))
+ else
+ NULL
+}
+
+##' @export
+`manifest.lvmfit` <-
+function(x,...) {
+ manifest(Model(x))
+}
+
+##' @export
+manifest.list <- function(x,...) {
+ manifestlist <- c()
+ for (i in seq_along(x)) {
+ manifestlist <- c(manifestlist, manifest(x[[i]]))
+ }
+ endolist <- unique(manifestlist)
+ return(manifestlist)
+}
+
+##' @export
+`manifest.multigroup` <-
+function(x,...) {
+ manifest(Model(x))
+}
diff --git a/R/matrices.R b/R/matrices.R
new file mode 100644
index 0000000..ccf487b
--- /dev/null
+++ b/R/matrices.R
@@ -0,0 +1,515 @@
+###{{{
+
+`matrices` <-
+ function(x,...) UseMethod("matrices")
+
+###{{{ matrices.lvm
+
+mat.lvm <- function(x,ii=index(x),...) {
+ A <- ii$A ## Matrix with fixed parameters and ones where parameters are free
+ J <- ii$J ## Manifest variable selection matrix
+ M1 <- ii$M1 ## Index of free and _unique_ regression parameters
+ P <- ii$P ## Matrix with fixed variance parameters and ones where parameters are free
+ P1 <- ii$P1 ## Index of free and _unique_ regression parameters
+
+ constrain.par <- names(constrain(x))
+ parval <- list()
+
+
+ parBelongsTo <- list(mean=seq_len(ii$npar.mean),
+ reg=seq_len(ii$npar.reg)+ii$npar.mean,
+ cov=seq_len(ii$npar.var)+ii$npar.mean+ii$npar.reg,
+ epar=seq_len(ii$npar.ex)+with(ii,npar.reg+npar.var+npar.mean),
+ cpar=numeric())
+
+ idxA <- which(M1==1)
+ pidxA <- parBelongsTo$reg
+ if (ii$npar.reg>0) {
+ A[idxA] <- pidxA
+ for (p in ii$parname) {
+ idx <- which((x$par==p))
+ newval <- A[idx[1]]
+ attributes(newval)$reg.idx <- idx
+ attributes(newval)$reg.tidx <- which(t(x$par==p))
+ parval[[p]] <- newval
+ if (length(idx)>1) {
+ idxA <- c(idxA,idx[-1])
+ pidxA <- c(pidxA,rep(A[idx[1]],length(idx)-1))
+ A[idx] <- A[idx[1]]
+ }
+ } ## duplicate parameters
+ }
+
+ pars.var <- parBelongsTo$cov
+ idxdiag <- (seq(ncol(P1))-1)*ncol(P1) + seq(ncol(P1))
+ idxP <- idxdiag[which(P1[idxdiag]==1)]
+ pidxP <- pars.var[seq_len(length(idxP))]
+ P[idxP] <- pidxP
+
+ pars.off.diag <- pars.var
+ if (length(pidxP)>0) {
+ pars.off.diag <- pars.off.diag[-seq_len(length(pidxP))]
+ }
+
+ counter <- 0
+ if (length(pars.off.diag)>0 & ncol(P)>1)
+ for (i in seq_len(ncol(P1)-1))
+ for (j in seq(i+1,nrow(P1))) {
+ if (ii$P1[j,i]!=0) {
+ counter <- counter+1
+ pos <- c(j+(i-1)*ncol(P1),
+ i+(j-1)*ncol(P1))
+ P[j,i] <- P[i,j] <- pars.off.diag[counter]
+ idxP <- c(idxP,pos); pidxP <- c(pidxP,P[j,i],P[i,j])
+ }
+ }
+
+ if (length(ii$covparname)>0)
+ for (p in ii$covparname) {
+ idx <- which(x$covpar==p)
+ isOffDiag <- !(idx[1]%in%idxdiag)
+ if (!(p%in%ii$parname)) {
+ parval[[p]] <- P[idx[1]]
+ }
+ attributes(parval[[p]])$cov.idx <- idx
+ if (length(idx)>1+isOffDiag) {
+ P[idx[-seq(1+isOffDiag)]] <- parval[[p]]
+ }
+ if (ii$npar.reg>0 && p%in%ii$parname) {
+ parBelongsTo$reg <- c(parBelongsTo$reg,p)
+ idx.reg <- which(x$par==p)
+ P[idx] <- A[idx.reg[1]]
+ atr <- attributes(parval[[p]])
+ parval[[p]] <- A[idx.reg[1]]
+ attributes(parval[[p]]) <- atr
+ idxP <- c(idxP,idx)
+ pidxP <- c(pidxP,rep(P[idx[1]],length(idx)))
+ } else {
+ idxP <- c(idxP,idx[-seq(1+isOffDiag)])
+ pidxP <- c(pidxP,rep(P[idx[1]],length(idx)-1-isOffDiag))
+ }
+ } ## duplicate parameters
+
+ idxM <- c()
+ pidxM <- seq_len(ii$npar.mean)
+ v <- NULL
+
+ named <- sapply(x$mean, function(y) is.character(y) & !is.na(y))
+ fixed <- sapply(x$mean, function(y) is.numeric(y) & !is.na(y))
+ v <- rep(0,length(x$mean))
+ names(v) <- colnames(P)
+ if (ii$npar.mean>0) {
+ idxM <- which(ii$v1==1)
+ v[idxM] <- pidxM
+ }
+ if (any(fixed))
+ v[fixed] <- unlist(x$mean[fixed])
+
+ for (p in ii$mparname) {
+ idx <- which(x$mean==p)
+ if (!(p%in%c(ii$parname,ii$covparname))) {
+ if (length(idx)>1) {
+ pidxM <- c(pidxM,rep(v[idx[1]],length(idx)-1))
+ idxM <- c(idxM,idx[-1])
+ }
+ parval[[p]] <- v[idx[1]]
+ v[idx] <- parval[[p]]
+ }
+ attributes(parval[[p]])$m.idx <- idx
+ if (p %in% ii$covparname & !(p %in% ii$parname)) {
+ parBelongsTo$cov <- c(parBelongsTo$cov,p)
+ idx.2 <- which(x$covpar==p)
+ v[idx] <- P[idx.2[1]]
+ pidxM <- c(pidxM,rep(P[idx.2[1]],length(idx)))
+ idxM <- c(idxM,idx)
+ }
+ if (p %in% ii$parname) {
+ parBelongsTo$reg <- c(parBelongsTo$reg,p)
+ idx.2 <- which(x$par==p)
+ v[idx] <- A[idx.2[1]]
+ pidxM <- c(pidxM,rep(A[idx.2[1]],length(idx)))
+ idxM <- c(idxM,idx)
+ }
+ }
+
+ ## Ex-parameters
+ idxE <- NULL
+ pidxE <- parBelongsTo$epar
+ named <- sapply(x$exfix, function(y) is.character(y) & !is.na(y))
+ fixed <- sapply(x$exfix, function(y) is.numeric(y) & !is.na(y))
+ epar <- rep(0,length(x$exfix))
+ names(epar) <- names(x$expar)
+ if (!(ii$npar.ex==0)) {
+ idxE <- which(ii$e1==1)
+ epar[idxE] <- pidxE
+ }
+ if (any(fixed))
+ epar[fixed] <- unlist(x$exfix[fixed])
+ for (p in ii$eparname) {
+ idx <- which(x$exfix==p)
+ if (!(p%in%c(ii$parname,ii$covparname,ii$mparname))) {
+ if (length(idx)>1) {
+ idxE <- c(idxE,idx[-1])
+ pidxE <- c(pidxE,rep(epar[idx[1]],length(idx)-1))
+ }
+ parval[[p]] <- epar[idx[1]]
+ }
+ attributes(parval[[p]])$e.idx <- idx
+
+ if (length(idx)>1)
+ epar[idx[-1]] <- parval[[p]]
+ if (p %in% setdiff(ii$covparname,c(ii$parname,ii$mparname))) {
+ parBelongsTo$cov <- c(parBelongsTo$cov,p)
+ idx.2 <- which(x$covpar==p)
+ epar[idx] <- P[idx.2[1]]
+ pidxE <- c(pidxE,rep(P[idx.2[1]],length(idx)))
+ idxE <- c(idxE,idx)
+ }
+ if (p %in% setdiff(ii$parname,ii$mparname)) {
+ parBelongsTo$reg <- c(parBelongsTo$reg,p)
+ idx.2 <- which(x$par==p)
+ epar[idx] <- A[idx.2[1]]
+ pidxE <- c(pidxE,rep(A[idx.2[1]],length(idx)))
+ idxE <- c(idxE,idx)
+ }
+ if (p %in% ii$mparname) {
+ parBelongsTo$mean <- c(parBelongsTo$mean,p)
+ idx.2 <- which(x$mean==p)
+ epar[idx] <- v[idx.2[1]]
+ pidxE <- c(pidxE,rep(v[idx.2[1]],length(idx)))
+ idxE <- c(idxE,idx)
+ }
+ }
+ ee <- cbind(idxE,pidxE); rownames(ee) <- names(x$expar)[ee[,1]]
+
+ ## Constrained...
+ constrain.par <- names(constrain(x))
+ constrain.idx <- NULL
+
+ if (length(constrain.par)>0) {
+ constrain.idx <- list()
+ for (p in constrain.par) {
+ reg.tidx <- reg.idx <- cov.idx <- m.idx <- e.idx <- NULL
+ myc <- constrain(x)[[p]]
+ xargs <- manifest(x)[na.omit(match(attributes(myc)$args,manifest(x)))]
+ if (length(xargs)>0) {
+ parval[xargs] <- 0
+ }
+ if (p%in%ii$parname.all) {
+ reg.idx <- which(x$par==p)
+ reg.tidx <- which(t(x$par==p))
+ }
+ if (p%in%ii$covparname.all) {
+ cov.idx <- which(x$covpar==p)
+ }
+ if (p%in%ii$mparname.all) {
+ m.idx <- which(x$mean==p)
+ }
+ if (p%in%ii$eparname.all) {
+ e.idx <- which(x$exfix==p)
+ }
+ constrain.idx[[p]] <- list(reg.idx=reg.idx,reg.tidx=reg.tidx,cov.idx=cov.idx,m.idx=m.idx,e.idx=e.idx)
+ }
+ }
+
+ parBelongsTo <- lapply(parBelongsTo,function(x) sort(unique(x)))
+
+
+ return(list(mean=cbind(idxM,pidxM),
+ reg=cbind(idxA,pidxA),
+ cov=cbind(idxP,pidxP),
+ epar=ee,
+ parval=parval,
+ constrain.idx=constrain.idx,
+ parBelongsTo=parBelongsTo))
+
+}
+
+
+
+matrices.lvm <- function(x,pars,meanpar=NULL,epars=NULL,data=NULL,...) {
+ ii <- index(x)
+ pp <- c(rep(NA,ii$npar.mean),pars,epars)
+ ##v <- NULL
+ v <- ii$v0
+ if (!is.null(meanpar) && length(meanpar)>0) {
+ pp[seq(ii$npar.mean)] <- meanpar
+ v[ii$mean[,1]] <- meanpar[ii$mean[,2]]
+ }
+
+ A <- ii$A
+ A[ii$reg[,1]] <- pp[ii$reg[,2]]
+ P <- ii$P
+ P[ii$cov[,1]] <- pp[ii$cov[,2]]
+ e <- NULL
+
+ if (length(x$expar)>0) {
+ e <- rep(0,length(x$expar))
+ fixed <- sapply(x$exfix, function(y) is.numeric(y) & !is.na(y))
+ if (any(fixed))
+ e[fixed] <- unlist(x$exfix[fixed])
+ if (nrow(ii$epar)>0)
+ e[ii$epar[,1]] <- pp[ii$epar[,2]]
+ names(e) <- names(x$expar)
+ }
+
+ parval <- lapply(ii$parval,function(x) {
+ res <- pp[x];
+ attributes(res) <- attributes(x);
+ res })
+ ## Constrained...
+ constrain.par <- names(constrain(x))
+ constrain.idx <- NULL
+ cname <- constrainpar <- c()
+ if (length(constrain.par)>0 && is.numeric(c(pars,meanpar))) {
+ constrain.idx <- list()
+ for (p in constrain.par) {
+ cname <- c(cname,p)
+ myc <- constrain(x)[[p]]
+ xargs <- manifest(x)[na.omit(match(attributes(myc)$args,manifest(x)))]
+ if (length(xargs)>0) {
+ if (!is.null(data)) {
+ parval[xargs] <- (data)[xargs]
+ } else parval[xargs] <- 0
+ }
+ val <- unlist(c(parval,constrainpar,x$mean,e)[attributes(myc)$args])
+ cpar <- myc(val);
+ constrainpar <- c(constrainpar,list(cpar)); names(constrainpar) <- cname
+ if (p%in%ii$parname.all) {
+ if (!is.null(val))
+ A[ii$constrain.idx[[p]]$reg.idx] <- cpar
+ }
+ if (p%in%ii$covparname.all) {
+ if (!is.null(val))
+ P[ii$constrain.idx[[p]]$cov.idx] <- cpar
+ }
+ if (p%in%ii$mparname.all) {
+ if (!is.null(val))
+ v[ii$constrain.idx[[p]]$m.idx] <- cpar
+ }
+ if (p%in%ii$eparname.all) {
+ if (!is.null(val))
+ e[ii$constrain.idx[[p]]$e.idx] <- cpar
+ }
+ }
+ }
+
+ return(list(A=A, P=P, v=v, e=e, parval=parval,
+ constrain.idx=ii$constrain.idx, constrainpar=constrainpar))
+}
+
+###}}} matrices.lvm
+
+###{{{ matrices.multigroup
+
+matrices.multigroup <- function(x, p, ...) {
+ pp <- modelPar(x,p)
+ res <- list()
+ for (i in seq_len(x$ngroup))
+ res <- c(res, list(matrices2(x$lvm[[i]],pp$p[[i]])))
+ return(res)
+}
+
+###}}}
+
+matrices2 <- function(x,p,...) {
+ m0 <- p[seq_len(index(x)$npar.mean)]
+ p0 <- p[with(index(x),seq_len(npar)+npar.mean)]
+ e0 <- p[with(index(x),seq_len(npar.ex)+npar.mean+npar)]
+ matrices(x,p0,m0,e0,...)
+}
+
+###{{{ matrices, to be superseeded by above definition
+
+matrices.lvm <- function(x,pars,meanpar=NULL,epars=NULL,data=NULL,...) {
+ ii <- index(x)
+ A <- ii$A ## Matrix with fixed parameters and ones where parameters are free
+ J <- ii$J ## Manifest variable selection matrix
+ M0 <- ii$M0 ## Index of free regression parameters
+ M1 <- ii$M1 ## Index of free and _unique_ regression parameters
+ P <- ii$P ## Matrix with fixed variance parameters and ones where parameters are free
+ P0 <- ii$P0 ## Index of free variance parameters
+ P1 <- ii$P1 ## Index of free and _unique_ regression parameters
+
+ P1.lower <- P1[lower.tri(P1)]
+ constrain.par <- names(constrain(x))
+ parval <- list()
+
+ if (ii$npar.reg>0) {
+ A[which(M1==1)] <- pars[seq_len(ii$npar.reg)]
+ for (p in ii$parname) {
+ idx <- which((x$par==p))
+ newval <- A[idx[1]]
+ attributes(newval)$reg.idx <- idx
+ attributes(newval)$reg.tidx <- which(t(x$par==p))
+ parval[[p]] <- newval
+ if (length(idx)>1) {
+ A[idx[-1]] <- parval[[p]]
+ }
+ } ## duplicate parameters
+ }
+
+ if (ii$npar.reg==0) {
+ pars.var <- pars
+ } else {
+ pars.var <- pars[-seq_len(ii$npar.reg)]
+ }
+
+ diag(P)[ii$which.diag] <- pars.var[seq_along(ii$which.diag)]
+ pars.off.diag <- pars.var
+ if (length(ii$which.diag)>0)
+ pars.off.diag <- pars.off.diag[-seq_along(ii$which.diag)]
+ counter <- 0
+ if (length(pars.off.diag)>0 & ncol(P)>1)
+ for (i in seq_len(ncol(P1)-1))
+ for (j in seq(i+1,nrow(P1))) {
+ if (ii$P1[j,i]!=0) {
+ counter <- counter+1
+ P[j,i] <- pars.off.diag[counter]
+ }
+ }
+
+ if (length(ii$covparname)>0)
+ for (p in ii$covparname) {
+ idx <- which(x$covpar==p)
+ if (!(p%in%ii$parname)) {
+ parval[[p]] <- P[idx[1]]
+ }
+ attributes(parval[[p]])$cov.idx <- idx
+ if (length(idx)>1) {
+ P[idx[-1]] <- parval[[p]]
+ }
+ if (ii$npar.reg>0 && p%in%ii$parname) {
+ idx.reg <- which(x$par==p)
+ P[idx] <- A[idx.reg[1]]
+ atr <- attributes(parval[[p]])
+ parval[[p]] <- A[idx.reg[1]] ###?????
+ attributes(parval[[p]]) <- atr
+ }
+ } ## duplicate parameters
+ P[upper.tri(P)] <- t(P)[upper.tri(P)] ## Symmetrize...
+
+
+ v <- NULL
+ {
+ named <- sapply(x$mean, function(y) is.character(y) & !is.na(y))
+ fixed <- sapply(x$mean, function(y) is.numeric(y) & !is.na(y))
+ v <- rep(0,length(x$mean))
+ names(v) <- colnames(P)
+ if (!(is.null(meanpar) | ii$npar.mean==0))
+ v[ii$v1==1] <- meanpar
+ if (any(fixed))
+ v[fixed] <- unlist(x$mean[fixed])
+
+ for (p in ii$mparname) {
+ idx <- which(x$mean==p)
+
+ if (!(p%in%c(ii$parname,ii$covparname))) {
+ parval[[p]] <- v[idx[1]]
+ }
+ attributes(parval[[p]])$m.idx <- idx
+
+ if (length(idx)>1)
+ v[idx[-1]] <- parval[[p]]
+ if (p %in% ii$covparname & !(p %in% ii$parname)) {
+ idx.2 <- which(x$covpar==p)
+ v[idx] <- P[idx.2[1]]
+ }
+ if (p %in% ii$parname) {
+ idx.2 <- which(x$par==p)
+ v[idx] <- A[idx.2[1]]
+ }
+ }
+ }
+
+
+ ## Ex-parameters
+ e <- NULL
+ {
+ named <- sapply(x$exfix, function(y) is.character(y) & !is.na(y))
+ fixed <- sapply(x$exfix, function(y) is.numeric(y) & !is.na(y))
+
+ e <- rep(0,length(x$exfix))
+
+ names(e) <- names(x$expar)
+ if (!(is.null(epars) | ii$npar.ex==0))
+ e[which(ii$e1==1)] <- epars
+ if (any(fixed))
+ e[fixed] <- unlist(x$exfix[fixed])
+ for (p in ii$eparname) {
+ idx <- which(x$exfix==p)
+ if (!(p%in%c(ii$parname,ii$covparname,ii$mparname))) {
+ parval[[p]] <- e[idx[1]]
+ }
+ attributes(parval[[p]])$e.idx <- idx
+
+ if (length(idx)>1)
+ e[idx[-1]] <- parval[[p]]
+ if (p %in% setdiff(ii$covparname,c(ii$parname,ii$mparname))) {
+ idx.2 <- which(x$covpar==p)
+ e[idx] <- P[idx.2[1]]
+ }
+ if (p %in% setdiff(ii$parname,ii$mparname)) {
+ idx.2 <- which(x$par==p)
+ e[idx] <- A[idx.2[1]]
+ }
+ if (p %in% ii$mparname) {
+ idx.2 <- which(x$mean==p)
+ e[idx] <- v[idx.2[1]]
+ }
+ }
+ }
+
+ ## Constrained...
+ constrain.idx <- NULL
+ cname <- constrainpar <- c()
+ if (length(constrain.par)>0 && is.numeric(c(pars,meanpar,e))) {
+ constrain.idx <- list()
+ for (p in constrain.par) {
+ cname <- c(cname,p)
+ reg.tidx <- reg.idx <- cov.idx <- m.idx <- e.idx <- NULL
+ myc <- constrain(x)[[p]]
+ xargs <- manifest(x)[na.omit(match(attributes(myc)$args,manifest(x)))]
+ if (length(xargs)>0) {
+ if (!is.null(data)) {
+ parval[xargs] <- (data)[xargs]
+ } else parval[xargs] <- 0
+ }
+ val <- rbind(unlist(c(parval,constrainpar,x$mean,e)[attributes(myc)$args]))
+ cpar <- myc(val);
+ constrainpar <- c(constrainpar,list(cpar)); names(constrainpar) <- cname
+ if (p%in%ii$parname.all) {
+ reg.idx <- which(x$par==p)
+ reg.tidx <- which(t(x$par==p))
+ if (!is.null(val))
+ A[reg.idx] <- cpar##myc(val)
+ }
+ if (p%in%ii$covparname.all) {
+ cov.idx <- which(x$covpar==p)
+ if (!is.null(val))
+ P[cov.idx] <- cpar##myc(val)
+ }
+ if (p%in%ii$mparname.all) {
+ m.idx <- which(x$mean==p)
+ if (!is.null(val))
+ v[m.idx] <- cpar##myc(val)
+ }
+ if (p%in%ii$eparname.all) {
+ e.idx <- which(x$exfix==p)
+ if (!is.null(val))
+ e[e.idx] <- cpar##myc(val)
+ }
+ constrain.idx[[p]] <- list(reg.idx=reg.idx,reg.tidx=reg.tidx,cov.idx=cov.idx,m.idx=m.idx,e.idx=e.idx)
+ }
+ }
+
+ if (x$index$sparse & !is.character(class(pars)[1])) {
+ A <- as(A,"sparseMatrix")
+ P <- as(P,"sparseMatrix")
+ v <- as(v,"sparseMatrix")
+ }
+ return(list(A=A, P=P, v=v, e=e, parval=parval, constrain.idx=constrain.idx, constrainpar=constrainpar))
+}
+
+###}}} matrices Obsolete
+
diff --git a/R/measurement.R b/R/measurement.R
new file mode 100644
index 0000000..376aa15
--- /dev/null
+++ b/R/measurement.R
@@ -0,0 +1,26 @@
+##' @export
+`measurement` <-
+ function(x, ...) {
+ M <- x$M
+ latent.idx <- match(latent(x),vars(x))
+ obs.idx <- match(manifest(x),vars(x))
+ if (length(latent.idx)==0)
+ return(NULL)
+
+ measurementmodels <- c()
+ for (i in seq_along(latent.idx)) {
+ ii <- latent.idx[i]
+
+ relation <- M[ii,obs.idx]==1
+ byNodes <- names(relation)[relation]
+ newnodes <- c(latent(x)[i],byNodes)
+ lvm1 <- subset(x,newnodes)
+ ## g0 <- graph::subGraph(newnodes, Graph(x,add=TRUE))
+ ## lvm1 <- latent(graph2lvm(g0, debug=TRUE), latent(x)[i])
+ ## g0fix<- x$fix[newnodes, newnodes]; lvm1$fix <- g0fix
+ ## index(lvm1) <- reindex(lvm1)
+ measurementmodels <- c(measurementmodels, list(lvm1))
+ }
+
+ measurementmodels
+ }
diff --git a/R/measurement.error.R b/R/measurement.error.R
new file mode 100644
index 0000000..af3417a
--- /dev/null
+++ b/R/measurement.error.R
@@ -0,0 +1,75 @@
+##' Two-stage (non-linear) measurement error
+##'
+##' Two-stage measurement error
+##' @param model1 Stage 1 model
+##' @param formula Formula specifying observed covariates in stage 2 model
+##' @param data data.frame
+##' @param predictfun Predictions to be used in stage 2
+##' @param id1 Optional id-vector of stage 1
+##' @param id2 Optional id-vector of stage 2
+##' @param ... Additional arguments to lower level functions
+##' @seealso stack.estimate
+##' @export
+##' @examples
+##' m <- lvm(c(y1,y2,y3)~u,c(y3,y4,y5)~v,u~~v,c(u,v)~x)
+##' transform(m,u2~u) <- function(x) x^2
+##' transform(m,uv~u+v) <- prod
+##' regression(m) <- z~u2+u+v+uv+x
+##' set.seed(1)
+##' d <- sim(m,1000,p=c("u,u"=1))
+##'
+##' ## Stage 1
+##' m1 <- lvm(c(y1[0:s],y2[0:s],y3[0:s])~1*u,c(y3[0:s],y4[0:s],y5[0:s])~1*v,u~b*x,u~~v)
+##' latent(m1) <- ~u+v
+##' e1 <- estimate(m1,d)
+##'
+##' pp <- function(mu,var,data,...) {
+##' cbind(u=mu[,"u"],u2=mu[,"u"]^2+var["u","u"],v=mu[,"v"],uv=mu[,"u"]*mu[,"v"]+var["u","v"])
+##' }
+##' (e <- measurement.error(e1, z~1+x, data=d, predictfun=pp))
+##'
+##' ## uu <- seq(-1,1,length.out=100)
+##' ## pp <- estimate(e,function(p,...) p["(Intercept)"]+p["u"]*uu+p["u2"]*uu^2)$coefmat
+##' if (interactive()) {
+##' plot(e,intercept=TRUE,vline=0)
+##'
+##' f <- function(p) p[1]+p["u"]*u+p["u2"]*u^2
+##' u <- seq(-1,1,length.out=100)
+##' plot(e, f, data=data.frame(u), ylim=c(-.5,2.5))
+##' }
+measurement.error <- function(model1, formula, data=parent.frame(),
+ predictfun=function(mu,var,data,...) mu[,1]^2+var[1],
+ id1, id2, ...) {
+ if (!inherits(model1,c("lvmfit","lvm.mixture"))) stop("Expected lava object ('lvmfit','lvm.mixture',...)")
+ if (missing(formula)) stop("formula needed for stage two (right-hand side additional covariates)")
+ p1 <- coef(model1,full=TRUE)
+ uhat <- function(p=p1) {
+ P <- predict(model1,p=p,x=manifest(model1))
+ cbind(predictfun(P,attributes(P)$cond.var,data))
+ }
+ if (missing(id1)) id1 <- seq(nrow(model.frame(model1)))
+ if (missing(id2)) id2 <- seq(nrow(model.frame(model1)))
+ if (!inherits(model1,"estimate"))
+ e1 <- estimate(NULL,coef=p1,id=id1,iid=iid(model1))
+ u <- uhat()
+ X0 <- model.matrix(formula, data)
+ Y <- model.frame(formula,data)[,1]
+ X <- cbind(X0,u)
+ stage.two <- lm(Y~-1+X)
+ names(stage.two$coefficients) <- colnames(X)
+ if (!inherits(stage.two,"estimate"))
+ e2 <- estimate(stage.two, id=id2)
+ U <- function(alpha=p1,beta=coef(stage.two)) {
+ X <- cbind(X0,uhat(alpha))
+ r <- (Y-X%*%beta)/summary(stage.two)$sigma^2
+ apply(X,2,function(x) sum(x*r))
+ }
+ Ia <- -numDeriv::jacobian(function(p) U(p),p1)
+ stacked <- stack(e1,e2,Ia)
+ res <- c(stacked,list(naive=e2,lm=coef(summary(stage.two)),fun=predictfun))
+ ## res <- list(estimate=stacked, naive=e2, lm=coef(summary(stage.two)),
+ ## fun=predictfun)
+ structure(res,class=c("measurement.error","estimate"))
+}
+
+
diff --git a/R/merge.R b/R/merge.R
new file mode 100644
index 0000000..2934b84
--- /dev/null
+++ b/R/merge.R
@@ -0,0 +1,164 @@
+##' @export
+`%++%.lvm` <- function(x,y) merge(x,y)
+
+##' @export
+"+.lvm" <- function(x,...) {
+ merge(x,...)
+}
+
+## ##' @export
+## "+.lm" <- function(x,...) {
+## merge(x,...)
+## }
+
+##' @export
+merge.lvm <- function(x,y,...) {
+ objects <- list(x,y,...)
+ if (length(objects)<2) return(x)
+ m <- objects[[1]]
+ for (i in seq(2,length(objects))) {
+ m2 <- objects[[i]]
+ if (length(latent(m2))>0)
+ latent(m) <- latent(m2)
+ if (length(m2$constrain)>0)
+ m$constrain <- c(m$constrain,m2$constrain)
+ M <- (index(m2)$A)
+ P <- (index(m2)$P)
+ nn <- vars(m2)
+ for (j in seq_len(nrow(M))) {
+ if (any(idx <- M[j,]!=0)) {
+ val <- as.list(rep(NA,sum(idx==TRUE)))
+ if (any(idx. <- !is.na(m2$par[j,idx])))
+ val[idx.] <- m2$par[j,idx][idx.]
+ if (any(idx. <- !is.na(m2$fix[j,idx])))
+ val[idx.] <- m2$fix[j,idx][idx.]
+ regression(m,to=nn[idx],from=nn[j],silent=TRUE) <- val
+ }
+ P0 <- P[j,]; P0[seq_len(j-1)] <- 0
+ if (any(idx <- P[j,]!=0)) {
+ val <- as.list(rep(NA,sum(idx==TRUE)))
+ if (any(idx. <- !is.na(m2$covpar[j,idx])))
+ val[idx.] <- m2$covpar[j,idx][idx.]
+ if (any(idx. <- !is.na(m2$covfix[j,idx])))
+ val[idx.] <- m2$covfix[j,idx][idx.]
+ covariance(m,nn[idx],nn[j],silent=TRUE) <- val
+ }
+ }
+ intercept(m,nn) <- intercept(m2)
+ m2x <- exogenous(m2)
+ if (length(m2x)>0)
+ exogenous(m) <- c(exogenous(m),m2x)
+ }
+ index(m) <- reindex(m)
+ return(m)
+}
+
+
+##' @export
+"+.estimate" <- function(x,...) {
+ merge(x,...)
+}
+
+##' @export
+merge.estimate <- function(x,y,...,id,paired=FALSE,labels=NULL,keep=NULL,subset=NULL) {
+ objects <- list(x,y, ...)
+ if (length(nai <- names(objects)=="NA")>0)
+ names(objects)[which(nai)] <- ""
+ if (!missing(subset)) {
+ coefs <- unlist(lapply(objects, function(x) coef(x)[subset]))
+ } else {
+ coefs <- unlist(lapply(objects,coef))
+ }
+ if (!is.null(labels)) {
+ names(coefs) <- labels
+ } else {
+ names(coefs) <- make.unique(names(coefs))
+ }
+ if (!missing(id) && is.null(id)) { ## Independence between datasets in x,y,...
+ nn <- unlist(lapply(objects,function(x) nrow(x$iid)))
+ cnn <- c(0,cumsum(nn))
+ id <- list()
+ for (i in seq_along(nn)) id <- c(id,list(seq(nn[i])+cnn[i]))
+ }
+ if (missing(id)) {
+ if (paired) { ## One-to-one dependence between observations in x,y,...
+ id <- rep(list(seq(nrow(x$iid))),length(objects))
+ } else {
+ id <- lapply(objects,function(x) x$id)
+ }
+ } else {
+ nn <- unlist(lapply(objects,function(x) NROW(iid(x))))
+ if (length(id)==1 && is.logical(id)) {
+ if (id) {
+ if (any(nn[1]!=nn)) stop("Expected objects of the same size: ", paste(nn,collapse=","))
+ id0 <- seq(nn[1]); id <- c()
+ for (i in seq(length(nn))) id <- c(id,list(id0))
+ } else {
+ id <- c()
+ N <- cumsum(c(0,nn))
+ for (i in seq(length(nn))) id <- c(id,list(seq(nn[i])+N[i]))
+ }
+ }
+ if (length(id)!=length(objects)) stop("Same number of id-elements as model objects expected")
+ idlen <- unlist(lapply(id,length))
+ if (!identical(idlen,nn)) stop("Wrong lengths of 'id': ", paste(idlen,collapse=","), "; ", paste(nn,collapse=","))
+ }
+ if (any(unlist(lapply(id,is.null)))) stop("Id needed for each model object")
+ ##iid <- Reduce("cbind",lapply(objects,iid))
+ ids <- iidall <- c(); count <- 0
+ for (z in objects) {
+ count <- count+1
+ clidx <- NULL
+ id0 <- id[[count]]
+ iidz <- iid(z)
+ if (!missing(subset)) iidz <- iidz[,subset,drop=FALSE]
+ if (!lava.options()$cluster.index) {
+ iid0 <- matrix(unlist(by(iidz,id0,colSums)),byrow=TRUE,ncol=ncol(iidz))
+ ids <- c(ids, list(sort(unique(id0))))
+
+ } else {
+ if (!requireNamespace("mets",quietly=TRUE)) stop("'mets' package required")
+ clidx <- mets::cluster.index(id0,mat=iidz,return.all=TRUE)
+ iid0 <- clidx$X
+ ids <- c(ids, list(id0[as.vector(clidx$firstclustid)+1]))
+ }
+ iidall <- c(iidall, list(iid0))
+ }
+ id <- unique(unlist(ids))
+ iid0 <- matrix(0,nrow=length(id),ncol=length(coefs))
+ colpos <- 0
+ for (i in seq(length(objects))) {
+ relpos <- seq_along(coef(objects[[i]]))
+ if (!missing(subset)) relpos <- seq_along(subset)
+ iid0[match(ids[[i]],id),relpos+colpos] <- iidall[[i]]
+ colpos <- colpos+tail(relpos,1)
+ }
+ rownames(iid0) <- id
+ estimate.default(NULL, coef=coefs, stack=FALSE, data=NULL, iid=iid0, id=id, keep=keep)
+}
+
+
+##' @export
+merge.lm <- function(x,y,...) {
+ args <- c(list(x,y),list(...))
+ nn <- names(formals(merge.estimate)[-seq(3)])
+ idx <- na.omit(match(nn,names(args)))
+ models <- args; models[idx] <- NULL
+ mm <- lapply(args,function(x) tryCatch(estimate(x),error=function(e) NULL))
+ names(mm)[1:2] <- c("x","y")
+ ii <- which(unlist(lapply(mm,is.null)))
+ if (length(ii)>0) mm[ii] <- NULL
+ do.call(merge,c(mm,args[idx]))
+}
+
+##' @export
+merge.glm <- merge.lm
+
+##' @export
+merge.lvmfit <- merge.lm
+
+##' @export
+merge.multinomial <- function(x,...) {
+ merge.estimate(x,...)
+}
+
diff --git a/R/missingMLE.R b/R/missingMLE.R
new file mode 100644
index 0000000..cfcacbd
--- /dev/null
+++ b/R/missingMLE.R
@@ -0,0 +1,292 @@
+###{{{ missingModel
+
+missingModel <- function(model,data,var=endogenous(model),fix=FALSE,type=2,keep=NULL,weights=NULL,data2=NULL,cluster=NULL,...) {
+ if (!inherits(model,"lvm")) stop("Needs a lvm-object")
+ if (type==3) {
+ var <- manifest(model)
+ }
+
+ data.mis <- is.na(data[,var,drop=FALSE])
+ colnames(data.mis) <- var
+ patterns <- unique(data.mis,MARGIN=1)
+
+ mis.type <- apply(data.mis,1,
+ function(x) which(apply(patterns,1,function(y) identical(x,y))))
+ pattern.allmis <- which(apply(patterns,1,all)) ## Remove entry with all missing
+
+ models <- datasets <- weights <- data2 <- clusters <- c()
+ mymodel <- baptize(model)
+ pattern.compl <- 0
+ count <- 0
+ A <- index(model)$A
+ topendo <- endogenous(model,top=TRUE)
+ exo <- exogenous(model)
+ exclude <- c()
+
+ warned <- FALSE
+ for (i in setdiff(seq_len(nrow(patterns)),pattern.allmis)) {
+ exoremove <- c()
+ includemodel <- TRUE
+ count <- count+1
+ mypattern <- patterns[i,]
+ m0 <- mymodel;
+ if (any(mypattern)) {
+ latent(m0) <- colnames(data.mis)[mypattern]
+ if (type>1) {
+ mytop <- intersect(topendo,colnames(data.mis)[mypattern])
+ if (!is.null(mytop)) {
+ kill(m0) <- mytop
+ for (xx in exo) {
+ ## If exogenous variable only have effect on missing variables,
+ ## then remove it from the model
+ if (all(c(rownames(A)[A[xx,]==1])%in%mytop) &&
+ !(xx%in%m0$par)
+ ##&& !(xx%in%names(index(m0))$parval)
+ ) {
+ exoremove <- c(exoremove,xx)
+ kill(m0) <- xx
+ }
+ }
+ }
+ }
+ } else
+ pattern.compl <- count
+ ## d0 <- data[mis.type==i,manifest(m0),drop=FALSE];
+ d0 <- data[which(mis.type==i),c(manifest(m0),keep),drop=FALSE];
+ if (!is.list(weights)) {
+ w0.var <- intersect(manifest(m0),colnames(weights))
+ w0 <- weights[which(mis.type==i),w0.var,drop=FALSE];
+ }
+ if (!is.list(data2)) {
+ w02.var <- intersect(manifest(m0),colnames(data2))
+ w02 <- data2[which(mis.type==i),w02.var,drop=FALSE];
+ }
+
+ clust0 <- cluster[which(mis.type==i)]
+ ex0 <- exogenous(m0) <- setdiff(exo,exoremove)
+ xmis <- which(apply(d0[,ex0,drop=FALSE],1,function(x) any(is.na(x))))
+
+ if (length(xmis)>0) {
+ misx <- ex0[apply(d0[xmis,ex0,drop=FALSE],2,function(x) any(is.na(x)))]
+ if (!warned)
+ warning("Missing exogenous variables: ", paste(misx,collapse=","),
+ ". Removing rows...")
+ warned <- TRUE
+ d0 <- d0[-xmis,,drop=FALSE]
+ w0 <- w0[-xmis,,drop=FALSE]
+ clust0 <- clust0[-xmis]
+ w02 <- w02[-xmis,,drop=FALSE]
+ }
+ if (length(misx <- intersect(ex0,latent(m0)))>0) {
+ warning("Missing exogenous variables:", paste(misx,collapse=","),
+ "! Remove manually!.")
+ }
+## else
+ {
+ if( sum(unlist(index(m0)[c("npar","npar.mean")]))>0 ) {
+ models <- c(models, list(m0))
+ datasets <- c(datasets, list(d0))
+ weights <- c(weights, list(w0))
+ if (!is.list(data2))
+ data2 <- c(data2, list(w02))
+ clusters <- c(clusters, list(clust0))
+ } else {
+ exclude <- c(exclude,count)
+ }
+ }
+ }
+
+ rmset <- c()
+ for (i in seq_len(length(datasets))) {
+ if (nrow(datasets[[i]])==0) rmset <- c(rmset,i)
+ }
+ if (length(rmset)>0) {
+ models[[rmset]] <- NULL
+ datasets[[rmset]] <- NULL
+ weights[[rmset]] <- NULL
+ data2[[rmset]] <- NULL
+ clusters[[rmset]] <- NULL
+ patterns <- patterns[-rmset,,drop=FALSE]
+ }
+
+ Patterns <- patterns
+ if (length(exclude)>0)
+ Patterns <- Patterns[-exclude,]
+ pattern.allcomp<- which(apply(Patterns,1,function(x) all(!x))) ## Complete cases
+
+ res <- list(models=models, datasets=datasets,
+ weights=weights,
+ data2=data2,
+ clusters=clusters,
+ patterns=Patterns,
+ pattern.compl=pattern.compl,
+ pattern.allmis=pattern.allmis,
+ pattern.allcomp=pattern.allcomp,
+ mis.type=mis.type)
+ return(res)
+}
+
+###}}}
+
+###{{{ estimate.MAR.lvm
+
+##' @export
+estimate.MAR <- function(x,data,which=endogenous(x),fix,type=2,startcc=FALSE,control=list(),silent=FALSE,weights,data2,cluster,onlymodel=FALSE,estimator="gaussian",hessian=TRUE,keep=NULL,...) {
+ cl <- match.call()
+
+ Debug("estimate.MAR")
+ redvar <- intersect(intersect(parlabels(x),latent(x)),colnames(data))
+ if (length(redvar)>0 & !silent)
+ warning(paste("Remove latent variable colnames from dataset",redvar))
+
+ xfix <- setdiff(colnames(data)[(colnames(data)%in%parlabels(x,exo=TRUE))],latent(x))
+ if (missing(fix))
+ fix <- ifelse(length(xfix)>0,FALSE,TRUE)
+
+ S <- diag(nrow=length(manifest(x)));
+ mu <- rep(0,nrow(S));
+ K <- length(exogenous(x))
+ vnames <- index(x)$manifest
+ names(mu) <- rownames(S) <- colnames(S) <- vnames
+ if (K>0) {
+ xx <- subset(Model(x),exogenous(x))
+ exogenous(xx) <- NULL
+ covfix(xx, vars(xx)) <- NA
+ xx <- covariance(xx,exogenous(x),exogenous(x))
+ datax <- data[,exogenous(x),drop=FALSE]
+ exo.idx <- match(exogenous(x),manifest(x))
+
+ mu0 <- colMeans(datax,na.rm=TRUE)
+ cov0 <- cov(datax,use="pairwise.complete.obs")*(nrow(datax)-1)/nrow(datax)
+ cov0upper <- cov0[upper.tri(cov0,diag=TRUE)]
+ exogenous(xx) <- NULL
+ coefpos <- matrices(xx,seq_len(K*(K-1)/2+K))$P
+ ii <- coefpos[upper.tri(coefpos,diag=TRUE)]
+ start <- c(mu0, cov0upper[order(ii)])
+ S[exo.idx,exo.idx] <- cov0
+ mu[exo.idx] <- mu0
+ ## message("\n")
+ }
+
+ x0 <- x
+ x <- fixsome(x, measurement.fix=fix, exo.fix=TRUE, S=S, mu=mu, n=1)
+ if (!silent)
+ message("Identifying missing patterns...")
+
+ val <- missingModel(x,data,var=which,type=type,keep=c(keep,xfix),weights=weights,data2=data2,cluster=cluster,...)
+ if (!silent)
+ message("\n")
+
+ if (nrow(val$patterns)==1) {
+ res <- estimate(x,data=data,fix=fix,weights=weights,data2=data2,estimator=estimator,silent=silent,control=control,...)
+ return(res)
+ }
+
+ if (startcc & is.null(control$start)) {
+ if (!silent)
+ message("Obtaining starting value...")
+ start0 <- rep(1,sum(unlist(index(x)[c("npar","npar.mean")])))
+ mystart <- tryCatch(
+ (estimate(x,data=na.omit(data),silent=TRUE,
+ weights=weights,data2=data2,estimator=estimator,quick=TRUE,...
+ )),
+ error=function(e) rep(1,sum(unlist(index(x)[c("npar","npar.mean")])))
+ )
+ control$start <- mystart
+ if (!silent)
+ message("\n")
+ }
+ if (is.null(control$meanstructure))
+ control$meanstructure <- TRUE
+ mg0 <- with(val, suppressWarnings(multigroup(models,datasets,fix=FALSE,exo.fix=FALSE,missing=FALSE)))
+ if (!is.null(names(control$start))) {
+ parorder1 <- attributes(parpos(mg0,p=names(control$start)))$name
+ paridx <- match(parorder1,names(control$start))
+ newpos <- paridx[which(!is.na(paridx))]
+ start0 <- control$start
+ start0[which(!is.na(paridx))] <- control$start[na.omit(paridx)]
+ names(start0)[which(!is.na(paridx))] <- names(control$start[na.omit(paridx)])
+ control$start <- start0
+ }
+
+
+ if (onlymodel) return(list(mg=mg0,val=val,weights=val$weights,data2=val$data2,cluster=val$clusters))
+
+ if (all(unlist(lapply(val$weights,is.null)))) val$weights <- NULL
+ if (all(unlist(lapply(val$data2,is.null)))) val$data2 <- NULL
+ if (all(unlist(lapply(val$clusters,is.null)))) val$clusters <- NULL
+
+ e.mis <- estimate(mg0,control=control,silent=silent,
+ weights=val$weights,data2=val$data2,
+ cluster=val$clusters,estimator=estimator,...)
+
+ cc <- coef(e.mis,level=1)
+ mynames <- c()
+ if (e.mis$model$npar.mean>0)
+ mynames <- c(mynames,paste0("m",seq_len(e.mis$model$npar.mean)))
+ if (e.mis$model$npar>0)
+ mynames <- c(mynames,paste0("p",seq_len(e.mis$model$npar)))
+ rownames(cc) <- mynames
+
+
+ mycc <- val$pattern.allcomp ## Position of complete-case model
+ nmis <- with(val, as.numeric(table(mis.type)[pattern.allmis])) ## Number of completely missing observations
+ if (length(nmis)>0 & length(mycc)>0) ## Any individuals with all missing?
+ if (val$pattern.allmis<mycc)
+ mycc <- mycc-1
+
+ if (length(xfix)>0) {
+ nrow <- length(vars(x))
+ xpos <- lapply(xfix,function(y) which(regfix(x)$labels==y))
+ colpos <- lapply(xpos, function(y) ceiling(y/nrow))
+ rowpos <- lapply(xpos, function(y) (y-1)%%nrow+1)
+ myfix <- list(var=xfix, col=colpos, row=rowpos)
+ for (i in seq_along(xfix))
+ regfix(x, from=vars(x)[rowpos[[i]]],to=vars(x)[colpos[[i]]]) <-
+ rep(colMeans(data[,xfix[i],drop=FALSE],na.rm=TRUE),length(rowpos[[i]]))
+ x <- updatelvm(x,zeroones=TRUE,deriv=TRUE)
+ }
+
+ ord <- c()
+ ordlist <- list()
+ for (i in seq_len(nrow(val$patterns))) {
+ ordlist <- c(ordlist, list(which(val$mis.type==i)))
+ ord <- c(ord, ordlist[[i]])
+ }
+
+ res <- with(val, list(coef=cc,
+ patterns=patterns, table=table(mis.type),
+ mis.type=mis.type,
+ order=ord,
+ orderlist=ordlist,
+ nmis=nmis,
+ allmis=pattern.allmis,
+ cc=mycc,
+ ncc=as.numeric(table(mis.type)[pattern.allcomp]),
+ multigroup=e.mis$model,
+ estimate=e.mis,
+ model=x,
+ model0=x0,
+ vcov=e.mis$vcov, opt=e.mis$opt,
+ control=control,
+ data=list(model.frame=data),
+ estimator=estimator,
+ call=cl
+ ))
+ class(res) <- c("lvm.missing","lvmfit")
+ if (inherits(e.mis,"lvmfit.randomslope"))
+ class(res) <- c(class(res),"lvmfit.randomslope")
+
+ if (hessian & is.null(cluster)) {
+ if (!silent)
+ message("Calculating asymptotic variance...\n")
+ res$vcov <- solve(information(res$estimate,type="hessian"))
+ cc[] <- coef(e.mis,level=1,vcov=res$vcov)
+ res$coef <- cc
+ }
+
+ return(res)
+}
+
+###}}} estimate.MAR.lvm
+
diff --git a/R/model.R b/R/model.R
new file mode 100644
index 0000000..65c12d7
--- /dev/null
+++ b/R/model.R
@@ -0,0 +1,55 @@
+##' Extract model
+##'
+##' Extract or replace model object
+##'
+##'
+##' @aliases Model Model<-
+##' @usage
+##'
+##' Model(x, ...)
+##'
+##' Model(x, ...) <- value
+##'
+##' @param x Fitted model
+##' @param value New model object (e.g. \code{lvm} or \code{multigroup})
+##' @param \dots Additional arguments to be passed to the low level functions
+##' @return Returns a model object (e.g. \code{lvm} or \code{multigroup})
+##' @author Klaus K. Holst
+##' @seealso \code{\link{Graph}}
+##' @keywords models
+##' @examples
+##'
+##' m <- lvm(y~x)
+##' e <- estimate(m, sim(m,100))
+##' Model(e)
+##'
+##' @export
+`Model` <- function(x,...) UseMethod("Model")
+
+
+##' @export
+`Model.default` <- function(x,...) x
+
+##' @export
+`Model.lvm` <- function(x,...) x
+
+##' @export
+`Model.lvmfit` <- function(x,...) x$model
+
+##' @export
+`Model.multigroup` <- function(x,...) x$lvm
+
+##' @export
+`Model.multigroupfit` <- function(x,...) x$model
+
+##' @export
+"Model<-" <- function(x,...,value) UseMethod("Model<-")
+
+##' @export
+"Model<-.lvm" <- function(x,...,value) { x <- value; return(x) }
+##' @export
+"Model<-.lvmfit" <- function(x,...,value) { x$model <- value; return(x) }
+##' @export
+"Model<-.multigroup" <- function(x,...,value) { x$lvm <- value; return(x) }
+##' @export
+"Model<-.multigroupfit" <- function(x,...,value) { x$model <- value; return(x) }
diff --git a/R/model.frame.R b/R/model.frame.R
new file mode 100644
index 0000000..9689053
--- /dev/null
+++ b/R/model.frame.R
@@ -0,0 +1,18 @@
+##' @export
+model.frame.lvmfit <- function(formula, all=FALSE,...) {
+ dots <- list(...)
+ mydata <- formula$data$model.frame
+ if (!is.data.frame(mydata) & !is.matrix(mydata))
+ return(mydata)
+ if (all) return(mydata)
+## xfix <- colnames(mydata)[(colnames(mydata)%in%parlabels(formula$model0,exo=TRUE))]
+ xfix <- colnames(mydata)[(colnames(mydata)%in%parlabels(formula$model0))]
+ return( mydata[,c(manifest(formula),xfix),drop=FALSE] )
+}
+
+##' @export
+model.frame.multigroupfit <- function(formula,...) {
+ dots <- list(...)
+ mydata <- formula$model$data
+ return(mydata)
+}
diff --git a/R/modelPar.R b/R/modelPar.R
new file mode 100644
index 0000000..70c54a2
--- /dev/null
+++ b/R/modelPar.R
@@ -0,0 +1,122 @@
+
+##' @export
+`modelPar` <-
+ function(x,p,...) UseMethod("modelPar")
+
+###{{{ modelPar.lvmfit
+##' @export
+modelPar.lvmfit <- function(x, p=pars(x), ...) modelPar(Model(x),p=p,...)
+
+###}}} modelPar.lvmfit
+
+###{{{ modelPar
+
+##' @export
+modelPar.lvm <- function(x,p, ...) {
+ npar <- index(x)$npar
+ npar.mean <- index(x)$npar.mean
+ if (length(p)!=npar & length(p)<(npar+npar.mean)) stop("Wrong dimension of parameter vector!")
+ p2 <- NULL
+ if (length(p)!=npar) { ## if meanstructure
+ meanpar <- p[seq_len(npar.mean)]
+ p. <- p
+ if (length(meanpar)>0) {
+ p. <- p[-seq_len(npar.mean)]
+ } else meanpar <- NULL
+ p <- p.[seq_len(npar)]
+ if (npar>0) {
+ p2 <- p.[-seq_len(npar)]
+ } else p2 <- p.
+ } else {
+ meanpar <- NULL
+ p2 <- NULL
+ }
+ return(list(p=p,meanpar=meanpar,p2=p2))
+}
+
+###}}} modelpar.lvm
+
+###{{{ modelPar.multigroupfit
+
+##' @export
+modelPar.multigroupfit <- function(x,p=pars(x),...) {
+ modelPar(Model(x),p,...)
+}
+###}}}
+
+###{{{ modelPar.multigroup
+
+##' @export
+modelPar.multigroup <- function(x,p, ...) {
+ if (length(p)==x$npar) {
+ pp <- lapply(x$parposN,function(z) p[z])
+ res <- list(p=pp, par=pp, mean=NULL)
+ return(res)
+ }
+ Nmean <- unlist(lapply(x$meanposN,length))
+ Npar <- unlist(lapply(x$parposN,length))
+ ##ppos <- mapply("+",x$parposN,as.list(Nmean),SIMPLIFY=FALSE)
+ ppos <- x$parposN
+ pp <- lapply(ppos,function(z) p[z+x$npar.mean])
+
+ if (length(pp)==0) pp <- lapply(seq_len(x$ngroup),function(x) logical())
+ mm <- lapply(x$meanposN,function(x) p[x])
+ if (is.null(mm)) mm <- lapply(seq_len(x$ngroup),logical())
+ pm <- mm
+ for (i in seq_len(length(pm))) pm[[i]] <- c(pm[[i]],pp[[i]])
+ res <- list(p=pm,par=pp,mean=mm)
+ return(res)
+}
+
+###}}}
+
+modelPar2.multigroup <-
+ function(x,p, ...) {
+ npar <- x$npar
+ npar.mean <- x$npar.mean
+ k <- x$ngroup
+ if (length(p)!=npar & length(p)!=(npar+npar.mean)) stop("Wrong dimension of parameter vector!")
+ if (length(p)!=npar) { ## if meanstructure
+ meanpar <- p[seq_len(npar.mean)]
+ p. <- p[-seq_len(npar.mean)]
+ } else {
+ meanpar <- NULL
+ p. <- p
+ }
+
+
+ parlist <- list(); for (i in seq_len(k)) parlist[[i]] <- numeric(length(x$parlist[[i]]))
+ if (!is.null(meanpar)) {
+ meanlist <- list(); for (i in seq_len(k)) meanlist[[i]] <- numeric(length(x$meanlist[[i]]))
+ }
+
+ if (length(p.)>0)
+ for (i in seq_along(p.)) {
+ for (j in seq_len(k)) {
+ idx <- match(paste0("p",i), x$parlist[[j]])
+ if (!is.na(idx))
+ parlist[[j]][idx] <- p.[i]
+ if (!is.null(meanpar)) {
+ midx <- match(paste0("p",i), x$meanlist[[j]])
+ if (!is.na(midx))
+ meanlist[[j]][midx] <- p.[i]
+ }
+ }
+ }
+
+ if (!is.null(meanpar)) {
+ for (i in seq_along(meanpar)) {
+ for (j in seq_len(k)) {
+ idx <- match(paste0("m",i), x$meanlist[[j]])
+ if (!is.na(idx))
+ meanlist[[j]][idx] <- meanpar[i]
+ }
+ }
+ } else {
+ meanlist <- NULL
+ }
+ p0 <- parlist
+ for (i in seq_along(p0))
+ p0[[i]] <- c(meanlist[[i]],parlist[[i]])
+ return(list(p=p0, par=parlist, mean=meanlist))
+}
diff --git a/R/modelVar.R b/R/modelVar.R
new file mode 100644
index 0000000..90173e6
--- /dev/null
+++ b/R/modelVar.R
@@ -0,0 +1,20 @@
+
+###{{{ modelVar
+
+##' @export
+`modelVar` <-
+ function(x,p,...) UseMethod("modelVar")
+
+##' @export
+modelVar.lvmfit <- function(x, p=pars(x), ...) modelVar(Model(x),p=p,...)
+
+##' @export
+modelVar.lvm <- function(x,p,data,...) {
+ pp <- modelPar(x,p)
+ res <- moments(x, p=p, data=data,...)
+ attr(res, "pars") <- pp$p
+ attr(res, "meanpar") <- pp$meanpar
+ attr(res, "epar") <- pp$epar
+ res
+}
+###}}} modelVar
diff --git a/R/modelsearch.R b/R/modelsearch.R
new file mode 100644
index 0000000..643d03a
--- /dev/null
+++ b/R/modelsearch.R
@@ -0,0 +1,308 @@
+##' Model searching
+##'
+##' Performs Wald or score tests
+##'
+##'
+##' @aliases modelsearch
+##' @param x \code{lvmfit}-object
+##' @param k Number of parameters to test simultaneously. For \code{equivalence}
+##' the number of additional associations to be added instead of \code{rel}.
+##' @param dir Direction to do model search. "forward" := add
+##' associations/arrows to model/graph (score tests), "backward" := remove
+##' associations/arrows from model/graph (wald test)
+##' @param type If equal to 'correlation' only consider score tests for covariance parameters. If equal to 'regression' go through direct effects only (default 'all' is to do both)
+##' @param ... Additional arguments to be passed to the low level functions
+##' @return Matrix of test-statistics and p-values
+##' @author Klaus K. Holst
+##' @seealso \code{\link{compare}}, \code{\link{equivalence}}
+##' @keywords htest
+##' @examples
+##'
+##' m <- lvm();
+##' regression(m) <- c(y1,y2,y3) ~ eta; latent(m) <- ~eta
+##' regression(m) <- eta ~ x
+##' m0 <- m; regression(m0) <- y2 ~ x
+##' dd <- sim(m0,100)[,manifest(m0)]
+##' e <- estimate(m,dd);
+##' modelsearch(e,silent=TRUE)
+##' modelsearch(e,silent=TRUE,type="cor")
+##' @export
+modelsearch <- function(x,k=1,dir="forward",type='all',...) {
+ if (dir=="forward") {
+ res <- forwardsearch(x,k,type=type,...)
+ return(res)
+ }
+ if (dir=="backstep") {
+ res <- backwardeliminate(x,...)
+ return(res)
+ }
+ res <- backwardsearch(x,k,...)
+ return(res)
+}
+
+backwardeliminate <- function(x,
+ keep=NULL,
+ pthres=0.05,
+ AIC=FALSE,
+ silent=TRUE,
+ missing=FALSE,
+ intercepts=FALSE,
+ maxsteps=Inf,
+ information="E",
+ messages=TRUE,
+ data,
+ ...) {
+
+ if (inherits(x,"lvm")) { M <- x } else { M <- Model(x) }
+ if(missing(data)) data <- model.frame(x)
+
+ dots <- list(...)
+ if (is.null(dots$control$start)) {
+ p0 <- estimate(M,data,quick=TRUE,silent=silent,missing=FALSE,...)
+ dots$control <- c(dots$control, list(start=p0,information="E"))
+ }
+
+ if (intercepts) ii <- NULL
+ ff <- function() {
+ ii <- grep("m",names(coef(M)))
+ vv <- variances(M,mean=TRUE)
+ args <- c(list(x=M,data=data,missing=missing,quick=TRUE,silent=silent),dots)
+ cc <- do.call("estimate",args)
+ if (is.numeric(cc)) {
+ I0 <- information(M,p=cc,data=data,type=information)[-c(ii,vv),-c(ii,vv)]
+ cc0 <- cc[-c(ii,vv)]
+ res <- (pnorm(abs(cc0/sqrt(diag(solve(I0)))),lower.tail=FALSE))*2
+ attributes(res)$coef <- cc
+ } else {
+ coefs <- coef(cc)
+ res <- (pnorm(abs(coefs/sqrt(diag(vcov(cc)))),lower.tail=FALSE))*2
+ res <- res[-c(ii,vv)]
+ attributes(res)$coef <- coefs
+ }
+ return(res)
+ }
+
+ done <- FALSE; i <- 0;
+ while (!done & i<maxsteps) {
+ p <- ff()
+ ordp <- order(p,decreasing=TRUE)
+ curp <- p[ordp[1]]
+ if (curp<pthres) break;
+ dots$control$start <- attributes(p)$coef[-ordp[1]]
+ if (messages) message("Removed: ",names(curp)," p-value: ",round(curp,3))
+ ##var1 <- unlist(strsplit(names(curp),lava.options()$symbol[1]))
+ nn <- strsplit(names(curp),paste0(lava.options()$symbol,collapse="|"))[[1]]
+ cancel(M) <- nn
+ }
+
+ if (messages) message("")
+ return(M)
+}
+
+backwardsearch <- function(x,k=1,...) {
+ if (!inherits(x,"lvmfit")) stop("Expected an object of class 'lvmfit'.")
+ p <- pars(x)
+ cur <- Model(x)
+ pp <- modelPar(cur,p)
+ Y <- endogenous(x)
+ X <- exogenous(x)
+ V <- vars(x)
+
+ p1 <- pp$p
+ Tests <- c(); Vars <- list()
+
+ parnotvar<- setdiff(seq_along(p1), variances(Model(x))) ## We don't want to perform tests on the boundary of the parameter space
+ freecomb <- utils::combn(parnotvar, k)
+
+ for (i in seq_len(ncol(freecomb)))
+ {
+ cc0 <- coef(cur, mean=FALSE,silent=TRUE,symbol=lava.options()$symbol)
+ ii <- freecomb[,i]
+ p0 <- p1; p0[ii] <- 0
+ R <- diag(nrow=length(p0)); R <- matrix(R[ii,],nrow=length(ii))
+ I <- information(Model(x), p=p1, n=x$data$n, data=model.frame(x))
+ if (!is.null(pp$meanpar)) {
+ rmidx <- seq_along(pp$meanpar)
+ I <- I[-rmidx,-rmidx]
+ }
+ iI <- solve(I)
+ W <- t(rbind(R)%*%p1)%*%solve(R%*%iI%*%t(R))%*%(cbind(R)%*%p1)
+ Tests <- c(Tests, W)
+ Vars <- c(Vars, list(cc0[ii]))
+ }
+ ord <- order(Tests, decreasing=TRUE);
+ Tests <- cbind(Tests, pchisq(Tests,k,lower.tail=FALSE)); colnames(Tests) <- c("Test Statistic", "P-value")
+ res <- list(test=Tests[ord,,drop=FALSE], var=Vars[ord])
+ PM <- matrix(ncol=3,nrow=0)
+ for (i in seq_len(nrow(Tests))) {
+ if (!is.na(res$test[i,1])) {
+ newrow <- c(formatC(res$test[i,1]), formatC(res$test[i,2]), paste(res$var[[i]],collapse=", "))
+ PM <- rbind(PM, newrow)
+ }
+ }
+ colnames(PM) <- c("Wald: W", "P(W>w)", "Index"); rownames(PM) <- rep("",nrow(PM))
+
+ res <- list(res=PM,test=res$test)
+ class(res) <- "modelsearch"
+ res
+}
+
+forwardsearch <- function(x,k=1,silent=FALSE,type='all',exclude.var=NULL,...) {
+ if (!inherits(x,"lvmfit")) stop("Expected an object of class 'lvmfit'.")
+
+ p <- pars(x,reorder=TRUE)
+ cur <- Model(x)
+ pp <- modelPar(cur,p)
+ Y <- endogenous(x)
+ X <- exogenous(x)
+ V <- vars(x)
+ q <- length(Y); qx <- length(X)
+ npar.sat <- q+q*(q-1)/2 + q*qx
+ npar.cur <- index(cur)$npar
+ npar.mean <- index(cur)$npar.mean
+ nfree <- npar.sat-npar.cur
+ if (nfree<k) {
+ message("Cannot free ",k," variables from model.\n");
+ return()
+ }
+
+ directional <- !(tolower(type)%in%c("cor","correlation","cov","covariance"))
+ all <- tolower(type)%in%c("all","both")
+
+ Tests <- c(); Vars <- list()
+ AP <- with(index(cur),A+t(A)+P)
+ restricted <- c()
+ ## idx1 <- seq_len(ncol(AP)-1)
+ ## idx2 <- seq(i+1,nrow(AP))
+
+ idx <- seq_len(ncol(AP))
+ if (!is.null(exclude.var)) {
+ if (is.character(exclude.var))
+ exclude.var <- match(exclude.var,V)
+ idx <- setdiff(idx,exclude.var)
+ }
+ for (i0 in seq_len(length(idx)-1))
+ for (j0 in seq(i0+1,length(idx))) {
+ i <- idx[i0]; j <- idx[j0]
+ if ( AP[j,i]==0 ) {
+ restricted <- rbind(restricted, c(i,j))
+ }
+ }
+
+ if (is.null(restricted)) return(NULL)
+ if (all) {
+ ntest <- nrow(restricted)
+ directional <- rep(FALSE,ntest)
+ restricted <- rbind(restricted,restricted,restricted[,2:1])
+ directional <- c(directional,rep(TRUE,2*ntest))
+ } else {
+ if (directional) {
+ restricted <- rbind(restricted,restricted[,2:1])
+ }
+ directional <- rep(directional, nrow(restricted))
+ }
+
+ restrictedcomb <- utils::combn(seq_len(nrow(restricted)), k) # Combinations of k-additions to the model
+
+ if (!inherits(model.frame(x),c("data.frame","matrix"))) {
+ n <- model.frame(x)$n
+ S <- model.frame(x)$S
+ mu <- model.frame(x)$mu
+ } else {
+ n <- nrow(model.frame(x))
+ S <- (n-1)/n*var(model.frame(x),na.rm=TRUE)
+ mu <- colMeans(model.frame(x),na.rm=TRUE)
+ }
+ if (!silent) {
+ message("Calculating score test for ",ncol(restrictedcomb), " models:")
+ count <- 0
+ pb <- txtProgressBar(style=lava.options()$progressbarstyle,width=40)
+ }
+ for (i in seq_len(ncol(restrictedcomb))) {
+ if (!silent) {
+ count <- count+1
+ setTxtProgressBar(pb, count/ncol(restrictedcomb))
+ }
+ varlist <- c()
+ altmodel <- cur ## HA: altmodel, H0: cur
+ for (j in seq_len(k)) {
+ myvar <- restricted[restrictedcomb[j,i],]
+ if (any(wx <- V[myvar]%in%X)) {
+ altmodel <- regression(altmodel,V[myvar][which(!wx)],V[myvar][which(wx)])
+ } else {
+ if (directional[i]) {
+ covariance(altmodel,pairwise=TRUE) <- V[myvar]
+ }
+ covariance(altmodel,pairwise=TRUE) <- V[myvar]
+ }
+ varlist <- rbind(varlist, V[myvar])
+ }
+ altmodel$parpos <- NULL
+ altmodel <- updatelvm(altmodel,deriv=TRUE,zeroones=TRUE,mean=TRUE)
+ cc <- coef(altmodel, mean=TRUE,silent=TRUE,symbol=lava.options()$symbol)
+ cc0 <- coef(cur, mean=TRUE,silent=TRUE,symbol=lava.options()$symbol)
+ p1 <- numeric(length(p)+k)
+ ## Need to be sure we place 0 at the correct position
+ for (ic in seq_along(cc)) {
+ idx <- match(cc[ic],cc0)
+ if (!is.na(idx))
+ p1[ic] <- p[idx]
+ }
+ if (x$estimator=="gaussian" && !inherits(x,"lvm.missing")) {
+ Sc2 <- score(altmodel,p=p1,data=NULL,
+ model=x$estimator,weights=Weights(x),S=S,mu=mu,n=n)
+ } else {
+ Sc2 <- score(altmodel,p=p1,data=model.frame(x),
+ model=x$estimator,weights=Weights(x))
+ }
+ I <- information(altmodel,p=p1,n=n,data=model.frame(x),weights=Weights(x),estimator=x$estimator) ##[-rmidx,-rmidx]
+
+ iI <- try(Inverse(I), silent=TRUE)
+ Q <- ifelse (inherits(iI, "try-error"), NA, ## Score test
+ (Sc2)%*%iI%*%t(Sc2)
+ )
+ Tests <- c(Tests, Q)
+ Vars <- c(Vars, list(varlist))
+ }
+
+ Tests0 <- Tests
+ Vars0 <- Vars
+
+ if (!silent) close(pb)
+ ord <- order(Tests);
+ Tests <- cbind(Tests, pchisq(Tests,k,lower.tail=FALSE)); colnames(Tests) <- c("Test Statistic", "P-value")
+ PM <- c()
+ for (i in seq_len(nrow(Tests))) {
+ if (!is.na(Tests[i,1])) {
+ vv <- apply(Vars[[i]],1,function(x) paste(x,collapse=lava.options()$symbol[2-directional[i]]))
+ newrow <- c(formatC(Tests[i,1]), formatC(Tests[i,2]),
+ paste(vv,collapse=","))
+ PM <- rbind(PM, newrow)
+ }
+ }
+ if (is.null(PM)) {
+ message("Saturated model")
+ return(invisible(NULL))
+ }
+ Tests <- Tests[ord,,drop=FALSE]
+ Vars <- Vars[ord]
+ PM <- PM[ord,,drop=FALSE]
+
+ colnames(PM) <- c("Score: S", "P(S>s)", "Index"); rownames(PM) <- rep("",nrow(PM))
+ res <- list(res=PM, test=Tests, var=Vars, directional=directional)
+ class(res) <- "modelsearch"
+ return(res)
+}
+
+##' @export
+print.modelsearch <- function(x,tail=nrow(x$res),adj=c("holm","BH"),...) {
+ N <- nrow(x$res)
+ if (!is.null(adj)) {
+ ## adjp <- rev(holm(as.numeric(x$test[,2])))
+ adjp <- rbind(sapply(adj,function(i) p.adjust(x$test[,2],method=i)))
+ colnames(adjp) <- adj
+ x$res <- cbind(x$res,rbind(formatC(adjp)))
+ }
+ print(x$res[seq(N-tail+1,N),], quote=FALSE, ...)
+ invisible(x)
+}
diff --git a/R/moments.R b/R/moments.R
new file mode 100644
index 0000000..e1bc69b
--- /dev/null
+++ b/R/moments.R
@@ -0,0 +1,72 @@
+Moments <- function(x,p,data,conditional=TRUE,...) {
+
+}
+
+##' @export
+`moments` <-
+ function(x,...) UseMethod("moments")
+
+##' @export
+moments.lvmfit <- function(x, p=pars(x),...) moments(Model(x),p=p,...)
+
+##' @export
+moments.lvm.missing <- function(x, p=pars(x), ...) {
+ idx <- match(coef(Model(x)),names(coef(x)))
+ moments.lvmfit(x,p=p[idx],...)
+}
+
+
+##' @export
+moments.lvm <- function(x, p, debug=FALSE, conditional=FALSE, data=NULL, latent=FALSE, ...) {
+### p: model-parameters as obtained from e.g. 'startvalues'.
+### (vector of regression parameters and variance parameters)
+### meanpar: mean-parameters (optional)
+
+ ii <- index(x)
+ pp <- modelPar(x,p)
+ AP <- with(pp, matrices(x,p,meanpar=meanpar,epars=p2,data=data,...))
+ P <- AP$P
+ v <- AP$v
+ if (!is.null(v)) {
+ names(v) <- ii$vars
+ }
+
+ J <- ii$J
+ if (conditional) {
+ J <- ii$Jy
+ if (latent) {
+ J <- diag(nrow=length(ii$vars))[sort(c(ii$endo.idx,ii$eta.idx)),,drop=FALSE]
+ }
+ px <- ii$px
+ exo <- exogenous(x)
+ ## if (missing(row)) {
+ v <- rbind(v) %x% cbind(rep(1,nrow(data)))
+ if (length(ii$exo.idx)>0) {
+ v[,ii$exo.idx] <- as.matrix(data[,exo])
+ }
+ ## } else {
+ ## if (!is.null(v))
+ ## v[exo] <- as.numeric(data[row,exo])
+ ## }
+ P <- px%*% tcrossprod(P, px)
+ }
+
+ Im <- diag(nrow=nrow(AP$A))
+ if (ii$sparse) {
+ IAi <- with(AP, as(Inverse(Im-t(A)),"sparseMatrix"))
+ ##IAi <- as(solve(Matrix::Diagonal(nrow(A))-t(A)),"sparseMatrix")
+ G <- as(J%*%IAi,"sparseMatrix")
+ } else {
+ IAi <- Inverse(Im-t(AP$A))
+ G <- J%*%IAi
+ }
+
+ xi <- NULL
+ if (!is.null(v)) {
+ xi <- v%*%t(G) ## Model-specific mean vector
+ }
+ Cfull <- as.matrix(IAi %*% tcrossprod(P,IAi))
+ C <- as.matrix(J %*% tcrossprod(Cfull,J))
+
+ return(list(Cfull=Cfull, C=C, v=v, e=AP$e, xi=xi, A=AP$A, P=P, IAi=IAi, J=J, G=G, npar=ii$npar, npar.reg=ii$npar.reg, npar.mean=ii$npar.mean, npar.ex=ii$npar.ex, parval=AP$parval, constrain.idx=AP$constrain.idx, constrainpar=AP$constrainpar))
+}
diff --git a/R/multigroup.R b/R/multigroup.R
new file mode 100644
index 0000000..76f717c
--- /dev/null
+++ b/R/multigroup.R
@@ -0,0 +1,330 @@
+###{{{ multigroup
+
+##' @export
+multigroup <- function(models, datasets, fix, exo.fix=TRUE, keep=NULL, missing=FALSE, ...) {
+ nm <- length(models)
+ if (nm!=length(datasets)) stop("Supply dataset for each model")
+ if (nm<2) stop("Two or more groups neeeded")
+ mynames <- names(models)
+
+ ## Check for random slopes
+ xfix <- list()
+ for (i in seq_len(nm)) {
+ x0 <- models[[i]]
+ data0 <- datasets[[i]]
+ xfix0 <- colnames(data0)[(colnames(data0)%in%parlabels(x0,exo=TRUE))]
+ xfix <- c(xfix, list(xfix0))
+ }
+ if (missing(fix)) {
+ fix <- !any(unlist(lapply(xfix, function(x) length(x)>0)))
+ }
+
+ for (i in seq_len(nm)) {
+ x0 <- models[[i]]
+ data0 <- datasets[[i]]
+ if (length(exogenous(x0)>0)) {
+ catx <- categorical2dummy(x0,data0)
+ models[[i]] <- catx$x; datasets[[i]] <- catx$data
+ }
+ if (!lava.options()$exogenous) exogenous(models[[i]]) <- NULL
+ }
+
+ models.orig <- NULL
+######################
+### MLE with MAR mechanism
+######################
+ if (missing) {
+
+ parcount <- 0
+ reservedpars <- c()
+ mynpar <- c()
+ for (i in seq_len(nm)) {
+ ## Fix some parameters (predictors,latent variables,...)
+
+ d0 <- datasets[[i]][1,,drop=FALSE]; d0[,] <- 1
+ if (fix)
+ models[[i]] <- fixsome(models[[i]], exo.fix=exo.fix, measurement.fix=fix, data=d0)
+ ## Find named/labelled parameters
+ rpar <- unique(parlabels(models[[i]]))
+ reservedpars <- c(reservedpars, rpar)
+ mynpar <- c(mynpar, with(index(models[[1]]), npar+npar.mean+npar.ex))
+ }; reservedpars <- unique(reservedpars)
+ nonamepar <- sum(mynpar)
+ ## Find unique parameter-names for all parameters
+ newpars <- c()
+ i <- 0
+ pos <- 1
+ while(pos<=nonamepar) {
+ i <- i+1
+ newname <- paste0("par",i)
+ if (!(newname%in%reservedpars)) {
+ newpars <- c(newpars,newname)
+ pos <- pos+1
+ }
+ }
+
+ pos <- 0
+ models0 <- list()
+ datasets0 <- list()
+ complidx <- c()
+ nmodels <- 0
+ modelclass <- c()
+ nmis <- c()
+ for (i in seq_len(nm)) {
+ myvars <- unlist(intersect(colnames(datasets[[i]]),c(vars(models[[i]]),xfix[[i]],keep)))
+ mydata <- datasets[[i]][,myvars]
+ if (any(is.na(mydata))) {
+ if (i>1) pos <- pos+mynpar[i-1]
+ models[[i]] <- baptize(models[[i]],newpars[pos+seq_len(mynpar[i])] ,overwrite=FALSE)
+ val <- missingModel(models[[i]],mydata,fix=FALSE,keep=keep,...)
+ nmodels <- c(nmodels,length(val$models))
+ complidx <- c(complidx,val$pattern.allcomp+nmodels[i]+1)
+ nmis0 <- rowSums(val$patterns);
+ allmis <- which(nmis0==ncol(val$patterns))
+ if (length(allmis)>0) nmis0 <- nmis0[-allmis]
+ nmis <- c(nmis,nmis0)
+ datasets0 <- c(datasets0, val$datasets)
+ models0 <- c(models0, val$models)
+ modelclass <- c(modelclass,rep(i,length(val$models)))
+ } else {
+ datasets0 <- c(datasets0, list(mydata))
+ models0 <- c(models0, list(models[[i]]))
+ modelclass <- c(modelclass,i)
+ nmis <- c(nmis,0)
+ }
+ }
+
+ models.orig <- models
+
+ suppressWarnings(
+ val <- multigroup(models0,datasets0,fix=FALSE,missing=FALSE,exo.fix=TRUE,...)
+ )
+ val$models.orig <- models.orig; val$missing <- TRUE
+ val$complete <- complidx-1
+ val$mnames <- mynames
+ attributes(val)$modelclass <- modelclass
+ attributes(val)$nmis <- nmis
+ return(val)
+ }
+
+
+######################
+### Usual analysis:
+######################
+ warned <- FALSE
+ for (i in seq_len(nm)) {
+ if (inherits(datasets[[i]],c("data.frame","matrix"))) {
+ myvars <- intersect(colnames(datasets[[i]]),c(vars(models[[i]]),xfix[[i]],keep))
+ if (any(is.na(datasets[[i]][,myvars]))) {
+ if (!warned) warning(paste0("Missing data encountered. Going for complete-case analysis"))
+ warned <- TRUE
+ datasets[[i]] <- na.omit(datasets[[i]][,myvars,drop=FALSE])
+ }
+ }
+ }
+
+ exo <- exogenous(models)
+ means <- lvms <- As <- Ps <- ps <- exs <- datas <- samplestat <- list()
+ for (i in seq_len(nm)) {
+
+ if (!is.null(exogenous(models[[i]]))) {
+ if (any(is.na(exogenous(models[[i]])))) {
+ exogenous(models[[i]]) <- exo
+ }
+ }
+
+ mydata <- datasets[[i]]
+ mymodel <- fixsome(models[[i]], data=mydata, measurement.fix=fix, exo.fix=exo.fix)
+ mymodel <- updatelvm(mymodel,zeroones=TRUE,deriv=TRUE)
+
+ P <- index(mymodel)$P1; P[P==0] <- NA
+ P[!is.na(P) & !is.na(mymodel$covpar)] <- mymodel$covpar[!is.na(P) & !is.na(mymodel$covpar)]
+
+ A <- index(mymodel)$M1; A[A==0] <- NA
+ A[!is.na(A) & !is.na(mymodel$par)] <- mymodel$par[!is.na(A) & !is.na(mymodel$par)]
+
+ mu <- unlist(mymodel$mean)[which(index(mymodel)$v1==1)]
+ #ex <- names(mymodel$expar)[which(index(mymodel)$e1==1)]
+ ex <- mymodel$exfix
+ if (length(ex)>0) {
+ if (any(is.na(ex))) ex[is.na(ex)] <- mymodel$expar[is.na(ex)]
+ ex <- ex[which(index(mymodel)$e1==1)]
+ }
+
+ p <- pars(mymodel, A, P, e=ex)
+ p[p=="1"] <- NA
+
+ means <- c(means, list(mu))
+ lvms <- c(lvms, list(mymodel))
+ datas <- c(datas, list(mydata))
+ samplestat <- c(samplestat, list(procdata.lvm(models[[i]],data=mydata)))
+ As <- c(As, list(A))
+ Ps <- c(Ps, list(P))
+ ps <- c(ps, list(p))
+ exs <- c(exs, list(ex))
+ };
+
+######
+ pp <- unlist(ps)
+ parname <- unique(pp[!is.na(pp)])
+ pidx <- is.na(char2num(parname))
+ parname <- unique(unlist(pp[!is.na(pp)]));
+ nfree <- sum(is.na(pp)) + length(parname)
+
+ if (nfree>0) {
+ pp0 <- lapply(ps, is.na)
+ usedname <- cbind(parname, rep(NA,length(parname)))
+ counter <- 1
+ pres <- pres0 <- pp0
+ for (i in seq_len(length(pp0))) {
+ if (length(pp0[[i]]>0))
+ for (j in seq_len(length(pp0[[i]]))) {
+ pidx <- match(ps[[i]][j],parname)
+ if (pp0[[i]][j]) {
+ pres[[i]][j] <- paste0("p",counter)
+ pres0[[i]][j] <- counter
+ counter <- counter+1
+ } else if (!is.na(pidx)) {
+ if (!is.na(usedname[pidx,2])) {
+ pres[[i]][j] <- usedname[pidx,2]
+ pres0[[i]][j] <- char2num(substr(pres[[i]][j],2,nchar(pres[[i]][j])))
+ } else {
+ val <- paste0("p",counter)
+ pres[[i]][j] <- val
+ pres0[[i]][j] <- counter
+ usedname[pidx,2] <- val
+ counter <- counter+1
+ }
+ } else {
+ pres[[i]][j] <- NA
+ }
+ }
+ }
+ mypar <- paste0("p",seq_len(nfree))
+ myparPos <- pres0
+ myparpos <- pres
+ myparlist <- lapply(pres, function(x) x[!is.na(x)])
+ } else {
+ myparPos <- NULL
+ mypar <- NULL
+ myparpos <- NULL
+ myparlist <- NULL
+ }
+
+ ### Mean parameter
+
+ mm <- unlist(means)
+ meanparname <- unique(mm[!is.na(mm)])
+ midx <- is.na(char2num(meanparname));
+ meanparname <- meanparname[midx]
+ any.mean <- sum(is.na(mm)) + length(meanparname)
+ nfree.mean <- sum(is.na(mm)) + length(setdiff(meanparname,parname))
+ ## mean.fixed <- na.omit(match(parname,mm))
+ mean.omit <- lapply(means,function(x) na.omit(match(parname,x)))
+ nmean <- lapply(means,length)
+
+ if (any.mean>0) {
+ mm0 <- lapply(means, is.na)
+ usedname <- cbind(meanparname, rep(NA,length(meanparname)))
+ counter <- 1
+ res0 <- res <- mm0
+ for (i in seq_len(length(mm0))) {
+ if (length(mm0[[i]])>0)
+ for (j in seq_len(length(mm0[[i]]))) {
+ midx <- match(means[[i]][j],meanparname)
+ if (mm0[[i]][j]) {
+ res[[i]][j] <- paste0("m",counter)
+ res0[[i]][j] <- counter
+ counter <- counter+1
+ } else if (!is.na(midx)) {
+ pidx <- match(meanparname[midx],pp)
+ if (!is.na(pidx)) {
+ res[[i]][j] <- unlist(myparlist)[pidx]
+ res0[[i]][j] <- char2num(substr(res[[i]][j],2,nchar(res[[i]][j]))) +
+ nfree.mean
+ ##nmean[[i]]
+ } else {
+ if (!is.na(usedname[midx,2])) {
+ res[[i]][j] <- usedname[midx,2]
+ res0[[i]][j] <- char2num(substr(res[[i]][j],2,nchar(res[[i]][j])))
+ } else {
+ val <- paste0("m",counter)
+ res[[i]][j] <- val
+ res0[[i]][j] <- counter
+ usedname[midx,2] <- val
+ counter <- counter+1
+ }
+ }
+ } else {
+ res[[i]][j] <- NA
+ }
+ }
+ }
+ mymeanPos <- res0
+ mymeanpos <- res
+ mymeanlist <- lapply(res, function(x) x[!is.na(x)])
+ mymean <- unique(unlist(mymeanlist))
+ } else {
+ mymeanPos <- NULL
+ mymean <- NULL
+ mymeanpos <- NULL
+ mymeanlist <- NULL
+ }
+
+### Extra parameters
+
+ N <- nfree+nfree.mean
+ m0 <- p0 <- c()
+ coefs <- coefsm <- mm0 <- mm <- pp0 <- pp <- c()
+ for (i in seq_len(length(myparPos))) {
+ mi <- mymeanPos[[i]]
+ nmi <- length(mi)
+ pi <- myparPos[[i]]
+ p1 <- setdiff(pi,p0)
+ p0 <- c(p0,p1)
+ ## pp0 <- c(pp0,list(match(p1,pi)+nfree.mean))
+ pp0 <- c(pp0,list(match(p1,pi)))
+ if (length(mean.omit[[i]])>0) mi <- mi[-mean.omit[[i]]]
+ m1 <- setdiff(mi,m0)
+ m0 <- c(m0,m1)
+ mm0 <- c(mm0,list(match(m1,mi)))
+ pp <- c(pp,list(c(m1,p1+nfree.mean)))
+ if (length(p1)>0)
+ coefs <- c(coefs,paste(i,coef(lvms[[i]],fix=FALSE,mean=FALSE)[pp0[[i]]],sep="@"))
+ if (length(m1)>0) {
+ coefsm0 <- paste(i,coef(lvms[[i]],fix=FALSE,mean=TRUE)[mm0[[i]]],sep="@")
+ coefsm <- c(coefsm,coefsm0)
+ }
+ }
+ coefs <- c(coefsm,coefs)
+
+ res <- list(npar=nfree, npar.mean=nfree.mean,
+ ngroup=length(lvms), names=mynames,
+ lvm=lvms, data=datas, samplestat=samplestat,
+ A=As, P=Ps, expar=exs,
+ meanpar=names(mu), name=coefs, coef=pp, coef.idx=pp0,
+ par=mypar, parlist=myparlist, parpos=myparpos,
+ mean=mymean, meanlist=mymeanlist, meanpos=mymeanpos,
+ parposN=myparPos,
+ meanposN=mymeanPos,
+ models.orig=models.orig, missing=missing
+ )
+ class(res) <- "multigroup"
+ checkmultigroup(res)
+ return(res)
+}
+
+###}}}
+
+###{{{ checkmultigroup
+
+checkmultigroup <- function(x) {
+ ## Check validity:
+ for (i in seq_len(x$ngroup)) {
+ if (nrow(x$data[[i]])<2) {
+ warning("With only one observation in the group, all parameters should be inherited from another a group!")
+ }
+ }
+}
+
+###}}} checkmultigroup
diff --git a/R/multinomial.R b/R/multinomial.R
new file mode 100644
index 0000000..b23e15c
--- /dev/null
+++ b/R/multinomial.R
@@ -0,0 +1,241 @@
+
+##' Estimate probabilities in contingency table
+##'
+##' @title Estimate probabilities in contingency table
+##' @aliases multinomial kappa.multinomial kappa.table gkgamma
+##' @param x Formula (or matrix or data.frame with observations, 1 or 2 columns)
+##' @param data Optional data.frame
+##' @param marginal If TRUE the marginals are estimated
+##' @param transform Optional transformation of parameters (e.g., logit)
+##' @param vcov Calculate asymptotic variance (default TRUE)
+##' @param iid Return iid decomposition (default TRUE)
+##' @param ... Additional arguments to lower-level functions
+##' @export
+##' @examples
+##' set.seed(1)
+##' breaks <- c(-Inf,-1,0,Inf)
+##' m <- lvm(); covariance(m,pairwise=TRUE) <- ~y1+y2+y3+y4
+##' d <- transform(sim(m,5e2),
+##' z1=cut(y1,breaks=breaks),
+##' z2=cut(y2,breaks=breaks),
+##' z3=cut(y3,breaks=breaks),
+##' z4=cut(y4,breaks=breaks))
+##'
+##' multinomial(d[,5])
+##' (a1 <- multinomial(d[,5:6]))
+##' (K1 <- kappa(a1)) ## Cohen's kappa
+##'
+##' K2 <- kappa(d[,7:8])
+##' ## Testing difference K1-K2:
+##' estimate(merge(K1,K2,id=TRUE),diff)
+##'
+##' estimate(merge(K1,K2,id=FALSE),diff) ## Wrong std.err ignoring dependence
+##' sqrt(vcov(K1)+vcov(K2))
+##'
+##' ## Average of the two kappas:
+##' estimate(merge(K1,K2,id=TRUE),function(x) mean(x))
+##' estimate(merge(K1,K2,id=FALSE),function(x) mean(x)) ## Independence
+##' ##'
+##' ## Goodman-Kruskal's gamma
+##' m2 <- lvm(); covariance(m2) <- y1~y2
+##' breaks1 <- c(-Inf,-1,0,Inf)
+##' breaks2 <- c(-Inf,0,Inf)
+##' d2 <- transform(sim(m2,5e2),
+##' z1=cut(y1,breaks=breaks1),
+##' z2=cut(y2,breaks=breaks2))
+##'
+##' (g1 <- gkgamma(d2[,3:4]))
+##' ## same as
+##' \dontrun{
+##' gkgamma(table(d2[,3:4]))
+##' gkgamma(multinomial(d2[,3:4]))
+##' }
+##'
+##' ##partial gamma
+##' d2$x <- rbinom(nrow(d2),2,0.5)
+##' gkgamma(z1~z2|x,data=d2)
+##' @author Klaus K. Holst
+multinomial <- function(x,data=parent.frame(),marginal=FALSE,transform,vcov=TRUE,iid=TRUE,...) {
+ formula <- NULL
+ if (inherits(x,"formula")) {
+ trm <- terms(x)
+ if (length(attr(trm,"term.labels"))>1) {
+ x <- update(x,as.formula(paste0(".~ interaction(",
+ paste0(attr(trm,"term.labels"),collapse=","),")")))
+ trm <- terms(x)
+
+ }
+ formula <- x
+ x <- as.matrix(model.frame(trm,data))
+ if (ncol(x)>1)
+ x <- x[,c(seq(ncol(x)-1)+1,1),drop=FALSE]
+ } else {
+ trm <- NULL
+ }
+ if (!vcov) iid <- FALSE
+ if (is.table(x) && iid) x <- lava::Expand(x)
+ if (NCOL(x)==1) {
+ if (!is.table(x)) {
+ x <- as.factor(x)
+ lev <- levels(x)
+ k <- length(lev)
+ n <- length(x)
+ P <- table(x)/n
+ } else {
+ n <- sum(x)
+ P <- x/n
+ lev <- names(x)
+ k <- length(lev)
+ }
+ if (iid) {
+ iid <- matrix(0,n,k)
+ for (i in seq(k)) {
+ iid[,i] <- (1*(x==lev[i])-P[i])/n
+ };
+ varcov <- crossprod(iid)
+ } else {
+ iid <- varcov <- NULL
+ if (vcov) {
+ varcov <- tcrossprod(cbind(P))/n
+ diag(varcov) <- P*(1-P)/n
+ }
+ }
+ coefs <- as.vector(P); names(coefs) <- paste0("p",seq(k))
+ res <- list(call=match.call(), coef=coefs,P=P,vcov=varcov,iid=iid,position=seq(k),levels=list(lev),data=x, terms=trm)
+ class(res) <- "multinomial"
+ return(res)
+ }
+
+ if (!is.table(x)) {
+ if (NCOL(x)!=2L) stop("Matrix or data.frame with one or two columns expected")
+ x <- as.data.frame(x)
+ x[,1] <- as.factor(x[,1])
+ x[,2] <- as.factor(x[,2])
+ lev1 <- levels(x[,1])
+ lev2 <- levels(x[,2])
+ k1 <- length(lev1)
+ k2 <- length(lev2)
+ M <- table(x)
+ n <- sum(M)
+ } else {
+ lev1 <- rownames(x)
+ lev2 <- colnames(x)
+ k1 <- length(lev1)
+ k2 <- length(lev2)
+ M <- x
+ n <- sum(x)
+ }
+ Pos <- P <- M/n
+ if (iid) {
+ iid <- matrix(0,n,k1*k2)
+ for (j in seq(k2)) {
+ for (i in seq(k1)) {
+ pos <- (j-1)*k1+i
+ iid[,pos] <- (x[,1]==lev1[i])*(x[,2]==lev2[j])-P[i,j]
+ Pos[i,j] <- pos
+ }
+ }; iid <- iid/n
+ } else {
+ iid <- varcov <- NULL
+ }
+
+ coefs <- as.vector(P);
+ names(coefs) <- as.vector(outer(seq(k1),seq(k2),function(...) paste0("p",...)))
+ position1 <- position2 <- NULL
+ if (marginal) {
+ p1 <- rowSums(P)
+ p2 <- colSums(P)
+ names(p1) <- paste0("p",seq(k1),".")
+ names(p2) <- paste0("p",".",seq(k2))
+ coefs <- c(coefs,p1,p2)
+ position1 <- length(P)+seq(k1)
+ position2 <- length(P)+k1+seq(k2)
+ if (!is.null(iid)) {
+ iid1 <- apply(Pos,1,function(x) rowSums(iid[,x]))
+ iid2 <- apply(Pos,2,function(x) rowSums(iid[,x]))
+ iid <- cbind(iid,iid1,iid2)
+ colnames(iid) <- names(coefs)
+ }
+ }
+ if (!missing(transform) && !is.null(iid)) {
+ f <- function(p) do.call(transform,list(p))
+ D <- diag(numDeriv::grad(f,coefs),ncol=length(coefs))
+ coefs <- f(coefs)
+ iid <- iid%*%t(D)
+ }
+ if (vcov && !is.null(iid)) varcov <- crossprod(iid)
+ res <- list(call=match.call(),
+ formula=formula,
+ coef=coefs,P=P,vcov=varcov,iid=iid, position=Pos, call=match.call(), levels=list(lev1,lev2), data=x,
+ position1=position1,position2=position2, ## Position of marginals)
+ terms=trm
+ )
+ class(res) <- "multinomial"
+ if (length(list(...))>0) {
+ res <- structure(estimate(res,...),class=c("multinomial","estimate"))
+ }
+ res
+}
+
+##' @export
+model.frame.multinomial <- function(formula,...) {
+ formula$data
+}
+
+##' @export
+iid.multinomial <- function(x,...) {
+ x$iid
+}
+
+##' @export
+coef.multinomial <- function(object,...) {
+ object$coef
+}
+
+##' @export
+vcov.multinomial <- function(object,...) {
+ object$vcov
+}
+
+##' @export
+predict.multinomial <- function(object,newdata,type=c("prob","map"),...) {
+ if (missing(newdata) || is.null(newdata)) newdata <- object$data
+ if (!is.null(object$formula) && is.data.frame(newdata)) {
+ trm <- terms(object$formula)
+ newdata <- model.frame(trm,newdata)[,-1]
+ }
+ px <- rowSums(object$P)
+ idx <- match(trim(as.character(newdata)),trim(rownames(object$P)))
+ pcond <- object$P
+ for (i in seq(nrow(pcond))) pcond[i,] <- pcond[i,]/px[i]
+ pr <- pcond[idx,,drop=FALSE]
+ if (tolower(type[1])%in%c("map","class")) {
+ pr <- colnames(pr)[apply(pr,1,which.max)]
+ }
+ return(pr)
+}
+
+## logLik.multinomial <- function(object,...) {
+## }
+
+##' @export
+print.multinomial <- function(x,...) {
+ cat("Call: "); print(x$call)
+ cat("\nJoint probabilities:\n")
+ print(x$P,quote=FALSE)
+ if (length(dim(x$P))>1) {
+ cat("\nConditional probabilities:\n")
+ print(predict(x,newdata=rownames(x$P)),quote=FALSE)
+ }
+ cat("\n")
+ print(estimate(NULL,coef=coef(x),vcov=vcov(x)))
+ ## stderr <- diag(vcov(x))^.5
+ ## StdErr <- x$position
+ ## StdErr[] <- stderr[StdErr]
+ ## cat("\nStd.Err:\n")
+ ## print(StdErr,quote=FALSE)
+ ## cat("\nPosition:\n")
+ ## print(x$position,quote=FALSE)
+}
+
+
diff --git a/R/multipletesting.R b/R/multipletesting.R
new file mode 100644
index 0000000..1e4a7d8
--- /dev/null
+++ b/R/multipletesting.R
@@ -0,0 +1,70 @@
+pzmax <- function(alpha,S) {
+ ##P(Zmax > z) Family wise error rate, Zmax = max |Z_i|
+ if (!requireNamespace("mets",quietly=TRUE)) stop("'mets' package required")
+ k <- nrow(S)
+ z <- qnorm(1-alpha/2)
+ 1-mets::pmvn(lower=rep(-z,k),upper=rep(z,k),sigma=cov2cor(S))
+}
+
+
+##' @export
+p.correct <- function(object,idx,alpha=0.05) {
+ S <- vcov(object); if (!missing(idx)) S <- S[idx,idx,drop=FALSE]
+ f <- function(a) pzmax(a,S)-alpha
+ uniroot(f,lower=0,upper=0.05)$root
+}
+
+##' Closed testing procedure
+##'
+##' Closed testing procedure
+##' @aliases closed.testing p.correct
+##' @param object estimate object
+##' @param idx Index of parameters to adjust for multiple testing
+##' @param null Null hypothesis value
+##' @param ... Additional arguments
+##' @export
+##' @examples
+##' m <- lvm()
+##' regression(m, c(y1,y2,y3,y4,y5,y6,y7)~x) <- c(0,0.25,0,0.25,0.25,0,0)
+##' regression(m, to=endogenous(m), from="u") <- 1
+##' variance(m,endogenous(m)) <- 1
+##' set.seed(2)
+##' d <- sim(m,200)
+##' l1 <- lm(y1~x,d)
+##' l2 <- lm(y2~x,d)
+##' l3 <- lm(y3~x,d)
+##' l4 <- lm(y4~x,d)
+##' l5 <- lm(y5~x,d)
+##' l6 <- lm(y6~x,d)
+##' l7 <- lm(y7~x,d)
+##'
+##' (a <- merge(l1,l2,l3,l4,l5,l6,l7,subset=2))
+##' if (requireNamespace("mets",quietly=TRUE)) {
+##' p.correct(a)
+##' }
+##' as.vector(closed.testing(a))
+##'
+closed.testing <- function(object,idx=seq_along(coef(object)),null=rep(0,length(idx)),...) {
+ B <- diag(nrow=length(idx))
+ e <- estimate(object,keep=idx)
+ combs <- pvals <- c()
+ for (i in seq_along(idx)) {
+ co <- combn(length(idx),i)
+ pp <- numeric(ncol(co))
+ for (j in seq_along(pp)) {
+ pp[j] <- compare(e,contrast=B[co[,j],,drop=FALSE],null=null[co[,j]],...)$p.value
+ }
+ combs <- c(combs,list(co))
+ pvals <- c(pvals,list(pp))
+ }
+ pmax <- c()
+ for (k in seq_along(idx)) {
+ pk <- c()
+ for (i in seq_along(idx)) {
+ cols <- apply(combs[[i]],2,function(x) k%in%x)
+ pk <- c(pk,pvals[[i]][which(cols)])
+ }
+ pmax <- c(pmax,max(pk))
+ }
+ return(structure(pmax,comb=combs,pval=pvals))
+}
diff --git a/R/nodecolor.R b/R/nodecolor.R
new file mode 100644
index 0000000..c967923
--- /dev/null
+++ b/R/nodecolor.R
@@ -0,0 +1,39 @@
+##' @export
+`nodecolor<-` <-
+function(object,var,...,value) UseMethod("nodecolor<-")
+
+##' @export
+`nodecolor<-.lvm` <-
+ function(object, var=vars(object), border, labcol, shape, lwd, ..., value) {
+ if (length(var)>0 & length(value)>0) {
+ if (inherits(var,"formula")) var <- all.vars(var)
+ object$noderender$fill[var] <- value
+ if (!missing(border))
+ object$noderender$col[var] <- border
+ if (!missing(shape))
+ object$noderender$shape[var] <- shape
+ if (!missing(labcol))
+ object$noderender$textCol[var] <- labcol
+ if (!missing(lwd))
+ object$noderender$lwd[var] <- lwd
+ }
+ return(object)
+ }
+
+##' @export
+`nodecolor<-.default` <-
+ function(object, var=vars(object), border, labcol, shape, lwd, ..., value) {
+ if (length(var)>0 & length(value)>0) {
+ if (inherits(var,"formula")) var <- all.vars(var)
+ object <- addattr(object,attr="fill",var=var,val=value)
+ if (!missing(border))
+ object <- addattr(object,attr="col",var=var,val=border)
+ if (!missing(shape))
+ object <- addattr(object,attr="shape",var=var,val=shape)
+ if (!missing(labcol))
+ object <- addattr(object,attr="textCol",var=var,val=labcol)
+ if (!missing(lwd))
+ object <- addattr(object,attr="lwd",var=var,val=lwd)
+ }
+ return(object)
+ }
diff --git a/R/nonlinear.R b/R/nonlinear.R
new file mode 100644
index 0000000..5990e3d
--- /dev/null
+++ b/R/nonlinear.R
@@ -0,0 +1,144 @@
+##' @export
+"nonlinear<-" <- function(object,...,value) UseMethod("nonlinear<-")
+
+##' @export
+"nonlinear" <- function(object,...) UseMethod("nonlinear")
+
+naturalcubicspline <- function(x, knots=stats::median(x,na.rm=TRUE), boundary=range(x,na.rm=TRUE)) {
+ ## C2 functions, piecewise cubic
+ breaks <- c(boundary[1],knots,boundary[2])
+ K <- length(breaks)
+ g <- function(x,tau) (x-tau)^3*((x-tau)>0)
+ gg <- matrix(0,nrow=length(x),ncol=K)
+ for (i in seq(K)) {
+ gg[,i] <- g(x,breaks[i])
+ }
+ B <- matrix(0,nrow=length(x),ncol=K-2)
+ for (i in seq(K-2)) {
+ B[,i] <- gg[,i] -
+ (breaks[K]-breaks[i])/(breaks[K]-breaks[K-1])*gg[,K-1] +
+ (breaks[K-1]-breaks[i])/(breaks[K]-breaks[K-1])*gg[,K]
+ }
+ cbind(x,B)
+}
+
+ncspred <- function(mu, var, knots=c(-5,0,5)) {
+ breaks <- knots
+ K <- length(breaks)
+
+ v <- as.vector(var)
+ k <- sqrt(v/(2*pi))
+ g <- function(x,tau) {
+ x0 <- (x-tau)
+ x2 <- x0^2
+ p0 <- 1-pnorm(-x0/sqrt(v)) # P(x>tau|...)
+ k*(2*v + x2)*exp(-(x0/(sqrt(2*v)))^2) +
+ x0*(x2+3*v)*p0
+ }
+ n <- NROW(mu)
+ gg <- matrix(0,nrow=n,ncol=K)
+ for (i in seq(K)) {
+ gg[,i] <- g(mu,breaks[i])
+ }
+ B <- matrix(0,nrow=n,ncol=K-2)
+ for (i in seq(K-2)) {
+ B[,i] <- gg[,i] -
+ (breaks[K]-breaks[i])/(breaks[K]-breaks[K-1])*gg[,K-1] +
+ (breaks[K-1]-breaks[i])/(breaks[K]-breaks[K-1])*gg[,K]
+ }
+ cbind(mu,B)
+}
+
+
+##' @export
+nonlinear.lvm <- function(object, to, from=NULL, type=c("quadratic"), knots=c(-5,0,5), names, ...) {
+ if (missing(to)) {
+ return(object$attributes$nonlinear)
+ }
+ if (inherits(to,"formula")) {
+ yy <- decomp.specials(getoutcome(to))
+ myvars <- all.vars(to)
+ from <- setdiff(myvars,yy)
+ to <- yy
+ }
+ if (length(to)>1) stop("Supply only one response variable")
+ if (length(from)>1) stop("Supply only one explanatory variable")
+ object <- cancel(object, c(from,to))
+ variance(object) <- to
+ f <- pred <- NULL
+
+ if (tolower(type)[1]%in%c("ncs","spline","naturalspline","cubicspline","natural cubic spline")) {
+ if (is.null(knots)) stop("Need cut-points ('knots')")
+ if (length(knots)<3) {
+ warning("Supply at least three knots (one interior and boundaries)")
+ ## Fall-back to linear
+ type <- "linear"
+ }
+ if (missing(names)) names <- paste0(from,"_",seq(length(knots)-1))
+ f <- function(p,x) {
+ B <- cbind(1,naturalcubicspline(x,knots=knots[-c(1,length(knots))],boundary=knots[c(1,length(knots))]))
+ colnames(B) <- c("(Intercept)",names)
+ as.vector(B%*%p)
+ }
+ pred <- function(mu,var,...) {
+ B <- ncspred(mu,var,knots=knots)
+ structure(B,dimnames=list(NULL,names))
+ }
+ }
+
+
+ if (tolower(type)[1]=="linear") {
+ if (missing(names)) names <- from
+ f <- function(p,x) p[1] + p[2]*x
+ pred <- function(mu,var,...) {
+ structure(cbind(mu[,1]),dimnames=list(NULL,names))
+ }
+ }
+
+ if (tolower(type)[1]=="quadratic") {
+ if (missing(names)) names <- paste0(from,"_",1:2)
+ f <- function(p,x) p[1] + p[2]*x + p[3]*(x*x)
+ pred <- function(mu,var,...) {
+ structure(cbind(mu[,1],mu[,1]^2+var[1]),dimnames=list(NULL,names))
+ }
+ }
+
+ if (tolower(type)[1]%in%c("piecewise","piecewise linear","linear")) {
+ if (is.null(knots)) stop("Need cut-points ('knots')")
+ }
+
+ if (tolower(type)[1]%in%c("exp","exponential")) {
+ if (missing(names)) names <- paste0(from,"_",1)
+ f <- function(p,x) p[1] + p[2]*exp(x)
+ pred <- function(mu,var,...) {
+ structure(cbind(exp(0.5*var[1] + mu[,1])),dimnames=list(NULL,names))
+ }
+ }
+
+ object$attributes$nonlinear[[to]] <- list(x=from, p=length(names)+1, newx=names, f=f, pred=pred, type=tolower(type[1]))
+ return(object)
+}
+
+##' @export
+nonlinear.lvmfit <- function(object, to, ...) {
+ if (missing(to)) {
+ return(Model(object)$attributes$nonlinear)
+ }
+ Model(object) <- nonlinear(Model(object),to=to,...)
+ return(object)
+}
+
+##' @export
+nonlinear.twostage.lvm <- function(object, ...) {
+ return(object$nonlinear)
+}
+
+##' @export
+nonlinear.lvmfit <- function(object, ...) {
+ return(object$nonlinear)
+}
+
+##' @export
+`nonlinear<-.lvm` <- function(object, ..., type="quadratic", value) {
+ nonlinear(object,to=value,type=type,...)
+}
diff --git a/R/normal.R b/R/normal.R
new file mode 100644
index 0000000..1a67a47
--- /dev/null
+++ b/R/normal.R
@@ -0,0 +1,178 @@
+introotpn <- function(p) {
+ ## Find integer root of x^2-x-2*p=0
+ n <- 0.5*(1+sqrt(1+8*p))
+ if (floor(n)!=n) n <- NA
+ return(n)
+}
+rho2sigma <- function(rho) {
+ if (length(rho)==1) return(diag(2)*(1-rho)+rho)
+ p <- introotpn(length(rho))
+ if (is.na(p)) stop("Unexpected length of correlation coefficients (p=n*(n-1)/2).")
+ sigma <- diag(nrow=p)
+ offdiag(sigma,type=2) <- rho
+ offdiag(sigma,type=3) <- offdiag(t(sigma),type=3)
+ return(sigma)
+}
+
+##' @export
+rmvn <- function(n,mu,sigma,rho,...) {
+ if (!missing(rho)) sigma <- rho2sigma(rho)
+ if (!missing(mu) && missing(sigma)) sigma <- diag(nrow=length(mu))
+ if (missing(sigma)) sigma <- matrix(1)
+ if (is.vector(sigma)) sigma <- diag(sigma,ncol=length(sigma))
+ if (missing(mu)) mu <- rep(0,ncol(sigma))
+ PP <- with(svd(sigma), v%*%diag(sqrt(d),ncol=length(d))%*%t(u))
+ res <- matrix(rnorm(ncol(sigma)*n),ncol=ncol(sigma))%*%PP
+ if (NROW(mu)==nrow(res) && NCOL(mu)==ncol(res)) return(res+mu)
+ return(res+cbind(rep(1,n))%*%mu)
+}
+
+##' @export
+dmvn <- function(x,mu,sigma,rho,log=FALSE,nan.zero=TRUE,norm=TRUE,...) {
+ if (!missing(rho)) sigma <- rho2sigma(rho)
+ if (!missing(mu) && missing(sigma)) sigma <- diag(nrow=length(mu))
+ if (missing(sigma)) sigma <- matrix(1)
+ if (is.vector(sigma)) sigma <- diag(sigma,ncol=length(sigma))
+ if (missing(mu)) mu <- rep(0,ncol(sigma))
+
+ if (length(sigma)==1) {
+ k <- 1
+ isigma <- structure(cbind(1/sigma),det=as.vector(sigma))
+
+ } else {
+ k <- ncol(sigma)
+ isigma <- Inverse(sigma)
+ }
+ if (!missing(mu)) {
+ if (NROW(mu)==NROW(x) && NCOL(mu)==NCOL(x)) {
+ x <- x-mu
+ } else {
+ x <- t(t(x)-mu)
+ }
+ }
+ logval <- -0.5*(base::log(2*base::pi)*k+
+ base::log(attributes(isigma)$det)+
+ rowSums((x%*%isigma)*x))
+ if (nan.zero) logval[is.nan(logval)] <- -Inf
+ if (log) return(logval)
+ return(exp(logval))
+}
+
+
+normal_method.lvm <- "nlminb0"
+
+normal_objective.lvm <- function(x,p,data,weights=NULL,data2=NULL,indiv=FALSE,...) {
+ if (!requireNamespace("mets",quietly=TRUE)) stop("'mets' package required")
+ if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) runif(1)
+ save.seed <- get(".Random.seed", envir = .GlobalEnv)
+ on.exit(assign(".Random.seed", save.seed, envir = .GlobalEnv))
+ set.seed(1)
+ ii <- lava::index(x)
+ y.idx <- ii$endo.idx
+ x.idx <- ii$exo.idx
+ y <- ii$endogenous
+ ord <- lava::ordinal(x)
+ atr <- attributes(ord)
+ ord <- intersect(y,ord)
+ attributes(ord) <- atr
+
+ status <- rep(0,length(y))
+ status[match(ord,y)] <- 2
+
+ Table <- (length(y)==length(ord)) && (length(x.idx)==0)
+ if (Table) {
+ pat <- mets::fast.pattern(data[,y,drop=FALSE],categories=max(data[,y,drop=FALSE])+1)
+ data <- pat$pattern
+ colnames(data) <- y
+ }
+
+ mu <- predict(x,data=data,p=p)
+ S <- attributes(mu)$cond.var
+ class(mu) <- "matrix"
+ thres <- matrix(0,nrow=length(y),max(1,attributes(ord)$K-1)); rownames(thres) <- y
+ for (i in seq_len(length(attributes(ord)$fix))) {
+ nn <- names(attributes(ord)$idx)[i]
+ ii <- attributes(ord)$idx[[nn]]
+ val <- (attributes(mu)$e[ii])
+ thres[nn,seq_len(length(val))] <-
+ cumsum(c(val[1],exp(val[-1])))
+ }
+
+ yl <- yu <- as.matrix(data[,y,drop=FALSE])
+ if (!inherits(yl[1,1],c("numeric","integer","logical")) ||
+ !inherits(yu[1,1],c("numeric","integer","logical")))
+ stop("Unexpected data (normal_objective)")
+
+ if (!is.null(data2)) {
+ yu[,colnames(data2)] <- data2
+ status[match(colnames(data2),y)] <- 1
+ }
+
+ l <- mets::loglikMVN(yl,yu,status,mu,S,thres)
+ if (!is.null(weights)) {
+ ##if (is.matrix(weights)) weights <- weights[,1]
+ l <- l*weights
+ }
+
+ if (Table) {
+ l <- l[pat$group+1]
+ }
+ if (indiv) return(-l)
+ return(-sum(l))
+}
+
+normal_logLik.lvm <- function(object,p,data,data2=NULL,...) {
+ res <- -normal_objective.lvm(x=object,p=p,data=data,data2=data2,...)
+ return(res)
+}
+
+normal_gradient.lvm <- function(x,p,data,weights=NULL,data2=NULL,indiv=FALSE,...) {
+ if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) runif(1)
+ save.seed <- get(".Random.seed", envir = .GlobalEnv)
+ on.exit(assign(".Random.seed", save.seed, envir = .GlobalEnv))
+ if (!requireNamespace("mets",quietly=TRUE)) stop("'mets' package required")
+ if (is.null(ordinal(x)) && is.null(data2) && is.null(weights)) {
+ D <- deriv.lvm(x,p=p)
+ M <- moments(x,p)
+ Y <- as.matrix(data[,manifest(x)])
+ mu <- M$xi%x%rep(1,nrow(Y))
+ ss <- -mets::scoreMVN(Y,mu,M$C,D$dxi,D$dS)
+ if (!indiv) return(colSums(ss))
+ return(ss)
+ }
+ if (indiv) {
+ return(numDeriv::jacobian(function(p0) normal_objective.lvm(x,p=p0,data=data,weights=weights,data2=data2,indiv=TRUE,...),p,method=lava.options()$Dmethod))
+ }
+ numDeriv::grad(function(p0) normal_objective.lvm(x,p=p0,data=data,weights=weights,data2=data2,...),p,method=lava.options()$Dmethod)
+}
+
+normal_hessian.lvm <- function(x,p,outer=FALSE,data2=NULL,...) {
+ if (!requireNamespace("mets",quietly=TRUE)) stop("'mets' package required")
+ dots <- list(...); dots$weights <- NULL
+ if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) runif(1)
+ save.seed <- get(".Random.seed", envir = .GlobalEnv)
+ on.exit(assign(".Random.seed", save.seed, envir = .GlobalEnv))
+ if (!outer) {
+ f <- function(p) {
+ set.seed(1)
+ do.call("normal_objective.lvm", c(list(x,p=p,indiv=FALSE,data2=data2),dots))
+ }
+ g <- function(p) {
+ set.seed(1)
+ do.call("normal_gradient.lvm", c(list(x,p=p,indiv=FALSE,data2=data2),dots))
+ }
+ if (is.null(ordinal(x)) && is.null(data2))
+ return(numDeriv::jacobian(g,p))
+ else {
+ return(numDeriv::hessian(f,p))
+ }
+ }
+ ## Else calculate outer product of the score (empirical variance of score)
+ S <- normal_gradient.lvm(x,p=p,indiv=TRUE,...)
+ J <- t(S)%*%S
+ attributes(J)$grad <- colSums(S)
+ return(J)
+
+}
+
+##normal_gradient.lvm <- normal_hessian.lvm <- NULL
diff --git a/R/onload.R b/R/onload.R
new file mode 100644
index 0000000..ac3693b
--- /dev/null
+++ b/R/onload.R
@@ -0,0 +1,16 @@
+'.onLoad' <- function(libname, pkgname="lava") {
+ addhook("heavytail.init.hook","init.hooks")
+ addhook("glm.estimate.hook","estimate.hooks")
+ addhook("ordinal.estimate.hook","estimate.hooks")
+ addhook("cluster.post.hook","post.hooks")
+ addhook("ordinal.sim.hook","sim.hooks")
+ addhook("color.ordinal","color.hooks")
+ addhook("ordinal.remove.hook","remove.hooks")
+}
+
+'.onAttach' <- function(libname, pkgname="lava") {
+ desc <- utils::packageDescription(pkgname)
+ packageStartupMessage(desc$Package, " version ",desc$Version)
+ lava.options(cluster.index=versioncheck("mets",c(0,2,7)),
+ tobit=versioncheck("lava.tobit",c(0,5)))
+}
diff --git a/R/operators.R b/R/operators.R
new file mode 100644
index 0000000..df0c109
--- /dev/null
+++ b/R/operators.R
@@ -0,0 +1,63 @@
+##' For matrices a block-diagonal matrix is created. For all other
+##' data types he operator is a wrapper of \code{paste}.
+##'
+##' Concatenation operator
+##' @aliases %++%
+##' @rdname op_concat
+##' @usage x \%++\% y
+##' @title Concatenation operator
+##' @param x First object
+##' @param y Second object of same class
+##' @author Klaus K. Holst
+##' @keywords utilities misc
+##' @seealso \code{blockdiag}, \code{\link{paste}}, \code{\link{cat}},
+##' @examples
+##' ## Block diagonal
+##' matrix(rnorm(25),5)%++%matrix(rnorm(25),5)
+##' ## String concatenation
+##' "Hello "%++%" World"
+##' ## Function composition
+##' f <- log %++% exp
+##' f(2)
+##' @export
+`%++%` <- function(x,y) UseMethod("%++%",y)
+
+## ##' @export
+## `%+%` <- function(x,y) UseMethod("%+%",y)
+
+##' @export
+`%++%.default` <- function(x,y) paste0(x,y)
+
+##' @export
+`%++%.character` <- function(x,y) paste0(x,y)
+
+##' @export
+`%++%.matrix` <- function(x,y) blockdiag(x,y)
+
+##' @export
+`%++%.function` <- function(x,y) function(...) x(y(...))
+
+
+notin <- Negate(get("%in%"))
+##' Matching operator (x not in y) oposed to the \code{\%in\%}-operator (x in y)
+##'
+##' Matching operator
+##' @rdname op_match
+##' @aliases %ni%
+##' @usage x \%ni\% y
+##' @param x vector
+##' @param y vector of same type as \code{x}
+##' @return A logical vector.
+##' @author Klaus K. Holst
+##' @seealso \code{\link{match}}
+##' @keywords utilities misc
+##' @examples
+##'
+##' 1:10 %ni% c(1,5,10)
+##'
+##' @export
+"%ni%" <- function(x,y) notin(x,y)
+
+## function(x,y) {
+## is.na(match(x,y))
+## }
diff --git a/R/optims.R b/R/optims.R
new file mode 100644
index 0000000..0ce52b2
--- /dev/null
+++ b/R/optims.R
@@ -0,0 +1,229 @@
+###{{{ nlminb
+
+nlminb2 <- function(start,objective,gradient,hessian,...) {
+ nlminbcontrols <- c("eval.max","iter.max","trace","abs.tol","rel.tol","x.tol","step.min")
+ dots <- list(...)
+ control <- list(...)$control
+ control <- control[names(control)%in%nlminbcontrols]
+ dots$control <- control
+ if (length(dots$trace)>0 && dots$trace>0) cat("\n")
+ mypar <- c(list(start=start,objective=objective,gradient=gradient,hessian=hessian),dots)
+ mypar["debug"] <- NULL
+ do.call("nlminb", mypar)
+}
+
+nlminb1 <- function(start,objective,gradient,hessian,...) {
+ nlminb2(start,objective,gradient=gradient,hessian=NULL,...)
+}
+nlminb0 <- function(start,objective,gradient,hessian,...) {
+ nlminb2(start,objective,gradient=NULL,hessian=NULL,...)
+}
+
+###}}} nlminb
+
+###{{{ estfun
+
+estfun <- function(start,objective,gradient,hessian,NR=FALSE,...) {
+ myobj <- function(x,...) {
+ S <- gradient(x,...)
+ crossprod(S)[1]
+ }
+ if (!missing(hessian) && !is.null(hessian)) {
+ mygrad <- function(x) {
+ H <- hessian(x)
+ S <- gradient(x)
+ 2*S%*%H
+ }
+ } else {
+ hessian <- function(x) numDeriv::jacobian(gradient,x,method=lava.options()$Dmethod)
+ mygrad <- function(x) {
+ H <- hessian(x)
+ S <- gradient(x)
+ 2*S%*%H
+ }
+ }
+ if (NR) {
+ op <- lava::NR(start,gradient=gradient,hessian=hessian,...)
+ } else {
+ op <- nlminb2(start,myobj,mygrad,hessian=NULL,...)
+ }
+ return(op)
+}
+
+estfun0 <- function(...,hessian=NULL) estfun(...,hessian=hessian)
+
+###}}}
+
+###{{{ Newton-Raphson/Scoring
+
+##' @export
+NR <- function(start,objective,gradient,hessian,debug=FALSE,control,...) {
+ control0 <- list(trace=0,
+ gamma=1,
+ lambda=0,
+ ngamma=0,
+ gamma2=0,
+ backtrack=TRUE,
+ iter.max=200,
+ tol=1e-9,
+ stabil=FALSE,
+ epsilon=1e-9)
+ if (!missing(control)) {
+ control0[names(control)] <- control
+ }
+
+
+ ## conditions to select the step length
+ if(control0$backtrack[1] == "armijo"){
+ control0$backtrack <- c(1e-4,0) # page 33
+ }
+ if(control0$backtrack[1] == "curvature"){
+ control0$backtrack <- c(0,0.9) # page 34
+ }
+ if(control0$backtrack[1] == "wolfe"){
+ control0$backtrack <- c(1e-4,0.9)
+ }
+ if(!is.logical(control0$backtrack) || length(control0$backtrack)!=1){
+ if(length(control0$backtrack) != 2){
+ stop("control$backtrack must have length two if not TRUE or FALSE \n")
+ }
+ if(any(!is.numeric(control0$backtrack)) || any(abs(control0$backtrack)>1)){
+ stop("elements in control$backtrack must be in [0,1] \n")
+ }
+ if(control0$backtrack[2]==0){
+ control0$backtrack[2] <- +Inf # no Wolfe condition
+ }
+ }
+
+ if (control0$trace>0)
+ cat("\nIter=0 Objective=",objective(as.double(start)),";\t\n \tp=", paste0(formatC(start), collapse=" "),"\n")
+
+ gradFun = !missing(gradient)
+ if (!gradFun & missing(hessian)) {
+ hessian <- function(p) {
+ ff <- objective(p)
+ res <- attributes(ff)$hessian
+ attributes(res)$grad <- as.vector(attributes(ff)$grad)
+ return(res)
+ }
+ }
+ oneiter <- function(p.orig,Dprev,return.mat=FALSE,iter=1) {
+ if (is.null(hessian)) {
+ cat(".")
+ I <- -numDeriv::jacobian(gradient,p.orig,method=lava.options()$Dmethod)
+ } else {
+ I <- -hessian(p.orig)
+ }
+ D <- attributes(I)$grad
+ if (is.null(D)) {
+ D <- gradient(p.orig)
+ }
+ if (return.mat) return(list(D=D,I=I))
+ if (control0$stabil) {
+ if (control0$lambda!=0) {
+ if (control0$lambda<0) {
+ sigma <- (t(D)%*%(D))[1]
+ } else {
+ sigma <- control0$lambda
+ }
+ sigma <- min(sigma,10)
+ I <- I+control0$gamma2*sigma*diag(nrow=nrow(I))
+ } else {
+ sigma <- ((D)%*%t(D))
+ I <- I+control0$gamma2*(sigma)
+ }
+ }
+
+ ## svdI <- svd(I); svdI$d0 <- numeric(length(svdI$d));
+ ## svdI$d0[abs(svdI$d)>control0$epsilon] <-
+ ## 1/svdI$d[abs(svdI$d)>control0$epsilon]
+ ## iI <- with(svdI, (v)%*%diag(d0,nrow=length(d0))%*%t(u))
+ iI <- Inverse(I, symmetric=TRUE, tol=control0$epsilon)
+ Delta = control0$gamma*iI%*%D
+
+ Lambda <- 1
+ if (identical(control0$backtrack, TRUE)) {
+ mD0 <- mean(Dprev^2)
+ mD <- mean(D^2)
+ p <- p.orig + Lambda*Delta
+ while (mD>=mD0) {
+ if (gradFun) {
+ D = gradient(p)
+ } else {
+ DI <- oneiter(p,return.mat=TRUE)
+ D = DI$D
+ }
+ mD = mean(D^2)
+ if (is.nan(mD)) mD=mD0
+ Lambda <- Lambda/2
+ if (Lambda<1e-4) break;
+ p <- p.orig + Lambda*Delta
+ }
+
+ } else if(identical(control0$backtrack, FALSE)) {
+ p <- p.orig + Lambda*Delta
+ } else { # objective(p.orig) - objective(p) <= mu*Lambda*gradient(p.orig)*Delta
+
+ ## curvature
+ c_D.origin_Delta <- control0$backtrack * c(rbind(D) %*% Delta)
+ objective.origin <- objective(p.orig)
+ p <- p.orig + Lambda*Delta
+ ## ll <- seq(-0.17,1,length.out=50)
+ ## pp <- numeric(length(ll))
+ ## for (ii in seq_along(ll)) pp[ii] <- objective(p.orig + ll[ii]*Delta)
+
+ mD0 <- c(objective.origin + Lambda * c_D.origin_Delta[1], abs(c_D.origin_Delta[2]))#
+ mD <- c(objective(p), abs(gradient(p) %*% Delta))
+ count <- 0
+ while (any(mD>mD0) || any(is.nan(mD))) {
+ count <- count+1
+ ##cat(count, " f=",mD[1],"\n")
+ Lambda <- Lambda/2
+ if (Lambda<1e-4) break;
+ p <- p.orig + Lambda*Delta
+ if(!is.infinite(mD0[1])){
+ mD0[1] <- objective.origin + Lambda * c_D.origin_Delta[1]#
+ mD[1] <- objective(p)
+ }
+ if(!is.infinite(mD0[2])){
+ mD[2] <- abs(gradient(p) %*% Delta)
+ }
+ }
+ }
+
+ return(list(p=p,D=D,iI=iI))
+ }
+
+ count <- count2 <- 0
+ thetacur <- start
+ gammacount <- 0
+ Dprev <- rep(Inf,length(start))
+ for (jj in seq_len(control0$iter.max)) {
+ gammacount <- gammacount+1
+ count <- count+1
+ count2 <- count2+1
+ oldpar <- thetacur
+ newpar <- oneiter(thetacur,Dprev,iter=jj)
+ Dprev <- newpar$D
+ thetacur <- newpar$p
+ if (!is.null(control0$ngamma) && control0$ngamma>0) {
+ if (control0$ngamma<=gammacount) {
+ control0$gamma <- sqrt(control0$gamma)
+ gammacount <- 0
+ }
+ }
+ if (count2==control0$trace) {
+ cat("Iter=", count,"LogLik=",objective(as.double(newpar$p)),";\n\tD=", paste0(formatC(newpar$D),
+ collapse = " "), "\n")
+ cat("\tp=", paste0(formatC(thetacur), collapse = " "),
+ "\n")
+ count2 <- 0
+ }
+ if (mean(newpar$D^2)<control0$tol) break;
+ }
+ res <- list(par=as.vector(thetacur), iterations=count, method="NR",
+ gradient=newpar$D, iH=newpar$iI)
+ return(res)
+}
+
+###}}} Newton Raphson/Scoring
diff --git a/R/ordinal.R b/R/ordinal.R
new file mode 100644
index 0000000..aa6df11
--- /dev/null
+++ b/R/ordinal.R
@@ -0,0 +1,294 @@
+ordinal.remove.hook <- function(x,var,...) {
+ ordinal(x,K=0) <- var
+ return(x)
+}
+
+color.ordinal <- function(x,subset=vars(x),...) {
+ return(list(vars=intersect(subset,ordinal(x)),col="indianred1"))
+}
+
+ordinal.sim.hook <- function(x,data,p,modelpar,...) {
+ ovar <- ordinal(x)
+
+ for (i in seq_len(length(ovar))) {
+ if (attributes(ovar)$liability[i]) {
+ idx <- attributes(ovar)$idx[[ovar[i]]]
+ if (length(idx)==0) {
+ breaks <- c(-Inf,0,Inf)
+ } else {
+ breaks <- c(-Inf,ordreg_threshold(modelpar$e[idx]),Inf)
+ }
+ z <- cut(data[,ovar[i]],breaks=breaks)
+ data[,ovar[i]] <- as.numeric(z)-1
+ }
+ K <- attributes(ovar)$K[i]
+ lab <- attributes(ovar)$labels[ovar[i]][[1]]
+ if (!is.null(lab))
+ data[,ovar[i]] <- factor(data[,ovar[i]],
+ levels=seq(K)-1,
+ labels=lab)
+
+ }
+ return(data)
+}
+
+ordinal.estimate.hook <- function(x,data,weights,data2,estimator,...) {
+ dots <- list(...)
+
+ nestimator <- c("normal")
+ nestimator2 <- c("tobit","tobitw","gaussian")
+
+ ord <- ordinal(x)
+ bin <- NULL
+ hasTobit <- lava.options()$tobit && isNamespaceLoaded("lava.tobit")
+ if (hasTobit) {
+ bin <- lava.tobit::binary(x)
+ }
+ if (is.null(estimator) && length(ord)>0) estimator <- nestimator[1]
+
+ ## Binary outcomes -> censored regression
+ if (is.null(dim(data))) return(NULL)
+ if (is.null(estimator) || estimator%in%c(nestimator2,nestimator)) {
+ for (i in setdiff(lava::endogenous(x),bin)) {
+ if (is.character(data[,i]) | is.factor(data[,i])) { # Transform binary 'factor'
+ y <- as.factor(data[,i])
+ data[,i] <- as.numeric(y)-1
+ if (hasTobit && nlevels(y)==2 && !is.null(estimator) && estimator%in%c("gaussian","tobit")) {
+ lava.tobit::binary(x) <- i
+ } else {
+ estimator <- nestimator[1]
+ ordinal(x,K=nlevels(y)) <- i
+ }
+ }
+ }
+ ord <- ordinal(x)
+ if (length(ord)>0 && !is.null(estimator) && estimator%in%nestimator2) {
+ if (hasTobit) {
+ lava.tobit::binary(x) <- ord
+ } else {
+ estimator <- nestimator[1]
+ }
+ }
+ if (hasTobit) bin <- intersect(lava.tobit::binary(x),vars(x))
+ if (length(bin)>0 && (is.null(estimator) || estimator%in%"normal")) {
+ estimator <- nestimator[1]
+ ordinal(x,K=2) <- bin
+ }
+
+ if (length(bin)>0 && estimator%in%nestimator2) {
+ estimator <- nestimator2[1]
+ if (is.null(weights)) {
+ W <- data[,bin,drop=FALSE]; W[W==0] <- -1; colnames(W) <- bin
+ weights <- lava::lava.options()$threshold*W
+ } else {
+ ## if (!all(binary(x)%in%colnames(data)))
+ ## W <- data[,binary(x),drop=FALSE]; W[W==0] <- -1; colnames(W) <- binary(x)
+ ## attributes(W)$data2 <- weights
+ ## weights <- W
+ ## weights[,binary(x)] <- W
+ }
+ for (b in bin) {
+ data[!is.na(data[,b]),b] <- 0
+ }
+ ## data[,binary(x)] <- 0
+ if (!is.null(data2)) {
+ estimator <- "tobitw"
+ }
+ }
+ }
+
+ ## Transform 'Surv' objects
+ data2 <- mynames <- NULL
+ if (is.null(estimator) || estimator%in%nestimator[1] || (!hasTobit && estimator%in%nestimator2)) {
+ for (i in setdiff(lava::endogenous(x),c(bin,ord))) {
+ if (survival::is.Surv(data[,i])) {
+ S <- data[,i]
+ y1 <- S[,1]
+ if (attributes(S)$type=="left") {
+ y2 <- y1
+ y1[S[,2]==0] <- -Inf
+ }
+ if (attributes(S)$type=="right") {
+ y2 <- y1
+ y2[S[,2]==0] <- Inf
+ }
+ if (attributes(S)$type=="interval2") {
+ y2 <- S[,2]
+ }
+ if (attributes(S)$type=="interval") {
+ y2 <- S[,2]
+ y2[S[,3]==1L] <- y1[S[,3]==1L]
+ }
+ if (!(attributes(S)$type%in%c("left","right","interval2","interval"))) stop("Surv type not supported.")
+ mynames <- c(mynames,i)
+ y2 <- cbind(y2)
+ colnames(y2) <- i
+ data2 <- cbind(data2,y2)
+ data[,i] <- y1
+ estimator <- "normal"
+ }
+ }
+ }
+
+ W <- NULL
+ if (length(estimator)>0 && estimator%in%nestimator2 && hasTobit) {
+ for (i in setdiff(lava::endogenous(x),bin)) {
+ if (survival::is.Surv(data[,i])) {
+ estimator <- nestimator2[1]
+ S <- data[,i]
+ y <- S[,1]
+ if (attributes(S)$type=="left")
+ w <- S[,2]-1
+ if (attributes(S)$type=="right")
+ w <- 1-S[,2]
+ if (attributes(S)$type=="interval2") {
+ w <- S[,3]; w[w==2] <- (-1)
+ }
+ mynames <- c(mynames,i)
+ W <- cbind(W,w)
+ data[,i] <- y
+ }
+ }
+ if (length(W)>0) {
+ colnames(W) <- mynames
+ if (!is.null(weights)) {
+ wW <- intersect(colnames(weights),colnames(W))
+ if (length(wW)>0)
+ weights[,wW] <- W[,wW]
+ Wo <- setdiff(colnames(W),wW)
+ if (length(Wo)>0)
+ weights <- cbind(weights,W[,Wo,drop=FALSE])
+ } else {
+ weights <- W;
+ }
+ }
+ }
+ return(c(list(x=x,data=data,weights=weights,data2=data2,estimator=estimator),dots))
+}
+
+
+
+##' @export
+"ordinal<-" <- function(x,...,value) UseMethod("ordinal<-")
+
+##' @export
+"ordinal<-.lvm" <- function(x,...,value) {
+ ordinal(x, value, ...)
+}
+
+##' @export
+"ordinal" <- function(x,...) UseMethod("ordinal")
+
+##' @export
+print.ordinal.lvm <- function(x,...) {
+ cat(rep("_",28),"\n",sep="")
+ for (i in x) {
+ val <- attr(x,"fix")[[i]]
+ if (length(val)==0)
+ cat(paste(i,"binary",sep=":"),"\n")
+ else print(unlist(attr(x,"fix")[[i]]),quote=FALSE)
+ cat(rep("_",28),"\n",sep="")
+ }
+}
+
+##' @export
+`ordinal.lvm` <- function(x,var=NULL,K=2, constrain, breaks=NULL, p, liability=TRUE, labels, exo=FALSE, ...) {
+ if (inherits(var,"formula")) {
+ var <- all.vars(var)
+ }
+ if (is.null(var)) {
+ ordidx <- unlist(x$attributes$ordinal)
+ KK <- unlist(x$attributes$nordinal)
+ idx <- x$attributes$ordinalparname
+ fix <- lapply(idx,function(z) x$exfix[z])
+ liability <- x$attributes$liability
+ labels <- x$attributes$labels
+ if (length(ordidx)>0) {
+ val <- names(ordidx)
+ return(structure(val,K=KK,idx=idx,fix=fix,liability=liability,labels=labels,class="ordinal.lvm"))
+ }
+ else
+ return(NULL)
+ }
+ if (K[1]==0L || is.null(K[1]) || (is.logical(K) & !K[1])) {
+ x$attributes$type[var] <- setdiff(x$attributes$type,var)
+ pp <- unlist(x$attributes$ordinalparname[var])
+ parameter(x,remove=TRUE) <- pp
+ x$attributes$ordinalparname[var] <- NULL
+ x$attributes$ordinal[var] <- NULL
+ ##x$attributes$labels[var] <- NULL
+ x$attributes$type <- x$attributes$type[setdiff(names(x$attributes$type),var)]
+ x$attributes$liability <- x$attributes$liability[setdiff(names(x$attributes$liability),var)]
+ x$attributes$nordinal <- x$attributes$nordinal[setdiff(names(x$attributes$nordinal),var)]
+ x$attributes$normal <- x$attributes$normal[setdiff(names(x$attributes$normal),var)]
+ x$constrainY[var] <- NULL
+ exo <- intersect(var,exogenous(x,TRUE))
+ if (length(exo)>0) {
+ intercept(x,var) <- NA
+ covariance(x,var) <- NA
+ exogenous(x) <- union(exogenous(x),exo)
+ }
+ return(x)
+ }
+
+ if (!missing(p)) breaks <- qnorm(cumsum(p))
+ if (!is.null(breaks)) {
+ breaks <- ordreg_ithreshold(breaks)
+ K <- length(breaks)+1
+ }
+ if (!missing(labels)) K <- length(labels)
+ if (length(var)>length(K)) K <- rep(K[1],length(var))
+ if (length(var)==1 && !missing(constrain)) constrain <- list(constrain)
+ if (length(var)>1) {
+ if (!missing(labels) && !is.list(labels)) labels <- rep(list(labels),length(var))
+ if (!missing(breaks) && !is.list(breaks)) breaks <- rep(list(breaks),length(var))
+ if (!missing(constrain) && !is.list(constrain)) constrain <- rep(list(constrain),length(var))
+ }
+
+ addvar(x) <- var
+ for (i in seq_len(length(var))) {
+ if (K[i]>2 || (K[i]==2 && !liability)) {
+ parname <- paste0(var[i],":",paste(seq(K[i]-1)-1,seq(K[i]-1),sep="|"))
+ newpar <- if (is.null(breaks)) {
+ rep(-1,K[i]-1)
+ } else if (is.list(breaks)) breaks[[i]] else breaks
+ if (length(newpar)<K[i]-1) stop("Wrong number of starting values")
+ newfix <- if (missing(constrain))
+ rep(list(NA),length(newpar)) else constrain[[i]]
+ if (length(newfix)<K[i]-1) stop("Wrong number of constraints")
+ names(newpar) <- names(newfix) <- parname
+
+ parameter(x,newfix,start=newpar) <- names(newfix)
+ ## pex <- parname%in%names(x$expar)
+ ## if (any(pex <- parname%in%names(x$expar))) {
+ ## if (!all(pex)) stop("Cannot change number of categories! Re-specify model.")
+ ## x$attributes$iordinal[var] <- list(idx)
+ ## }
+ x$attributes$ordinalparname[var[i]] <- list(names(newfix))
+ }
+ x$attributes$type[var[i]] <- ifelse(K[i]>2,"categorical","binary")
+ if (K[i]>2) intfix(x,var[i],NULL) <- 0
+ if (!liability) {
+ mytr <- function(y,p,idx,...) {
+ breaks <- c(-Inf,ordreg_threshold(p[idx]),Inf)
+ as.numeric(cut(y,breaks=breaks))-1
+ }
+ myalist <- substitute(alist(y=,p=,idx=pp),
+ list(pp=x$attributes$ordinalparname[[var[i]]]))
+ formals(mytr) <- eval(myalist)
+ transform(x,var[i],post=FALSE) <- mytr
+
+ }
+ }
+ x$attributes$liability[var] <- liability
+ x$attributes$ordinal[var] <- TRUE
+ if (!missing(labels)) {
+ if (length(var)==1) labels <- list(labels)
+ x$attributes$labels[var] <- labels
+ }
+ x$attributes$nordinal[var] <- K
+ x$attributes$normal[var] <- FALSE
+ covfix(x,var,NULL,exo=exo) <- 1
+ if (is.null(index(x))) index(x) <- reindex(x)
+ return(x)
+}
diff --git a/R/ordreg.R b/R/ordreg.R
new file mode 100644
index 0000000..9fd0136
--- /dev/null
+++ b/R/ordreg.R
@@ -0,0 +1,161 @@
+ordreg_threshold <- function(theta) {
+ v <- theta[1]
+ if (length(theta)>1) v <- cumsum(c(v,exp(theta[seq(length(theta)-1L)+1L])))
+ return(v)
+}
+
+ordreg_ithreshold <- function(v) {
+ theta <- v[1]
+ if (length(v)>1) theta <- c(theta,log(-rev(diff(rev(v)))))
+ return(theta)
+}
+
+ordreg_dthreshold <- function(theta) {
+ K <- length(theta)+1
+ Da <- matrix(0,K,K-1)
+ Da[seq(K-1),1L] <- 1L
+ for (i in seq_len(K-2)+1) Da[seq(i,K-1),i] <- exp(theta[i])
+ Da
+}
+
+##' Ordinal regression models
+##'
+##' @title Univariate cumulative link regression models
+##' @param formula formula
+##' @param data data.frame
+##' @param offset offset
+##' @param family family (default proportional odds)
+##' @param start optional starting values
+##' @param fast If TRUE standard errors etc. will not be calculated
+##' @param ... Additional arguments to lower level functions
+##' @export
+##' @author Klaus K. Holst
+##' @examples
+##' m <- lvm(y~x)
+##' ordinal(m,K=3) <- ~y
+##' d <- sim(m,100)
+##' e <- ordreg(y~x,d)
+ordreg <- function(formula,data=parent.frame(),offset,family=stats::binomial("probit"),start,fast=FALSE,...) {
+ y <- ordered(model.frame(update(formula,.~0),data)[,1])
+ lev <- levels(y)
+ X <- model.matrix(update(formula,.~.+1),data=data)[,-1,drop=FALSE]
+ up <- new.env()
+ assign("h",family$linkinv,envir=up)
+ assign("dh",family$mu.eta,envir=up)
+ assign("y",as.numeric(y),envir=up)
+ assign("X",X,envir=up)
+ assign("K",nlevels(y),envir=up)
+ assign("n",length(y),envir=up)
+ assign("p",NCOL(X),envir=up)
+ assign("threshold", function(theta,K) ordreg_threshold(theta[seq(K-1)]), envir=up)
+ assign("dthreshold",function(theta,K) ordreg_dthreshold(theta[seq(K-1)]), envir=up)
+ ff <- function(theta) -ordreg_logL(theta,up)
+ gg <- function(theta) -ordreg_score(theta,up)
+ if (missing(start)) start <- with(up,c(rep(-1,up$K-1),rep(0,p)))
+ op <- nlminb(start,ff,gg)
+ cc <- op$par;
+ if (fast) return(structure(cc,threshold=up$threshold(cc,up$K))) ##,up$K)))
+ nn <- c(paste(lev[-length(lev)], lev[-1L], sep = "|"),
+ colnames(X))
+ I <- -ordreg_hessian(cc,up)
+ names(cc) <- nn
+ dimnames(I) <- list(nn,nn)
+ res <- list(vcov=solve(I),coef=cc,call=match.call(),up=up,opt=op)
+ structure(res,class="ordreg")
+}
+
+##' @export
+print.ordreg <- function(x,...) {
+ cat("Call:\n"); print(x$call)
+ cat("\nParameter Estimates:\n")
+ print(x$coef)
+}
+
+##' @export
+summary.ordreg <- function(object,alpha=0.95,...) {
+ res <- cbind(coef(object),diag(vcov(object))^.5)
+ pp <- 1-(1-alpha)/2
+ qq <- qnorm(pp)
+ res <- cbind(res,res[,1]-res[,2]*qq,res[,1]+res[,2]*qq,2*(1-pnorm(abs(res[,1])/res[,2])))
+ colnames(res) <- c("Estimate","Std.Err",paste0(round(c(1-pp,pp)*1000)/10,"%"),"P-value")
+ res <- list(coef=res,logLik=logLik(object),AIC=AIC(object))
+ class(res) <- "summary.ordreg"
+ return(res)
+}
+
+##' @export
+print.summary.ordreg <- function(x,alpha=0.95,...) {
+ cat("AIC: ", x$AIC, "\n\n")
+ print(x$coef)
+ cat("\n")
+}
+
+##' @export
+score.ordreg <- function(x,p=coef(x),indiv=FALSE,...) {
+ ordreg_score(p,x$up)
+ if (!indiv) return(colSums(x$up$score))
+ x$up$score
+}
+
+##' @export
+logLik.ordreg <- function(object,p=coef(object),indiv=FALSE,...) {
+ ordreg_logL(p,object$up)
+ res <- log(object$up$pr)
+ if (!indiv) res <- sum(res)
+ structure(res,nall=length(object$up$pr),nobs=object$up$pr,df=length(p),class="logLik")
+}
+
+##' @export
+coef.ordreg <- function(object,...) object$coef
+
+##' @export
+vcov.ordreg <- function(object,...) object$vcov
+
+ordreg_logL <- function(theta,env,indiv=FALSE,...) {
+ if (length(theta)!=with(env,p+K-1)) stop("Wrong dimension")
+ env$theta <- theta
+ if (env$p>0) beta <- with(env,theta[seq(p)+K-1])
+ alpha <- with(env, threshold(theta,K))
+ env$alpha <- alpha
+ env$beta <- beta
+ if (env$p>0) eta <- env$X%*%beta else eta <- cbind(rep(0,env$n))
+ env$lp <- kronecker(-eta,rbind(alpha),"+")
+ F <- with(env,h(lp))
+ Pr <- cbind(F,1)-cbind(0,F)
+ pr <- Pr[with(env,cbind(seq(n),as.numeric(y)))]
+ env$pr <- pr
+ sum(log(pr))
+}
+
+ordreg_score <- function(theta,env,...) {
+ if (!identical(theta,env$theta)) ordreg_logL(theta,env)
+ Da <- with(env,dthreshold(theta,K))
+ dF <- with(env, cbind(dh(lp),0))
+ idx1 <- with(env,which(as.numeric(y)==1))
+ S1 <- cbind(Da[as.numeric(env$y),,drop=FALSE],-env$X)
+ S1 <- dF[with(env,cbind(seq(n),as.numeric(y)))]*S1
+ y2 <- env$y-1; y2[idx1] <- env$K
+ S2 <- cbind(Da[y2,,drop=FALSE],-env$X)
+ S2 <- dF[cbind(seq(env$n),y2)]*S2
+ env$score <- 1/env$pr*(S1-S2)
+ colSums(env$score)
+}
+ordreg_hessian <- function(theta,env,...) {
+ numDeriv::jacobian(function(p) ordreg_score(p,env,...),theta,...)
+}
+
+##' @export
+predict.ordreg <- function(object,p=coef(object),type=c("prob","cumulative"),...) {
+ env <- object$up
+ env$theta <- p
+ if (env$p>0) beta <- with(env,theta[seq(p)+K-1])
+ alpha <- with(env, threshold(theta,K))
+ env$alpha <- alpha
+ env$beta <- beta
+ if (env$p>0) eta <- env$X%*%beta else eta <- cbind(rep(0,env$n))
+ env$lp <- kronecker(-eta,rbind(alpha),"+")
+ F <- with(env,h(lp))
+ if (tolower(type)[1]=="cumulative") return(F)
+ Pr <- cbind(F,1)-cbind(0,F)
+ return(Pr)
+}
diff --git a/R/parameter.R b/R/parameter.R
new file mode 100644
index 0000000..9b901ce
--- /dev/null
+++ b/R/parameter.R
@@ -0,0 +1,47 @@
+##' @export
+"parameter<-" <- function(x,...,value) UseMethod("parameter<-")
+
+##' @export
+"parameter<-.lvmfit" <- function(x,...,value) {
+ parameter(Model(x),...) <- value
+ return(x)
+}
+
+
+##' @export
+"parameter<-.lvm" <- function(x,constrain,start,remove=FALSE,...,value) {
+ if (inherits(value,"formula")) value <- all.vars(value)
+ if (remove) {
+ x$expar[value] <- NULL
+ x$exfix[value] <- NULL
+ x$attributes$parameter[value] <- NULL
+ index(x) <- reindex(x)
+ return(x)
+
+ }
+ if (!missing(start)) {
+ if (length(start) != length(value)) stop("'start' and 'value' should be of the same lengths")
+ start <- as.list(start)
+ names(start) <- value
+ } else {
+ start <- as.list(rep(0,length(value))); names(start) <- value
+ }
+ if (!missing(constrain)) {
+ newfix <- constrain
+ if (!is.list(newfix)) newfix <- as.list(newfix)
+ } else {
+ newfix <- as.list(value);
+ }
+ names(newfix) <- value
+ x$expar[value] <- start
+ x$exfix[value] <- newfix
+ index(x) <- reindex(x)
+ x$attributes$parameter[value] <- TRUE
+ return(x)
+}
+
+##' @export
+parameter <- function(x,var,...) {
+ if (missing(var)) return (names(unlist(x$attributes$parameter)))
+ parameter(x,...) <- var
+}
diff --git a/R/parlabels.R b/R/parlabels.R
new file mode 100644
index 0000000..95e94af
--- /dev/null
+++ b/R/parlabels.R
@@ -0,0 +1,12 @@
+##' @export
+parlabels <- function(x,exo=FALSE) {
+ res <- c(unlist(intfix(x)[unlist(lapply(intfix(x), function(y) !is.na(y) & !is.numeric(y)))]),
+ regfix(x)$labels[!is.na(regfix(x)$labels)],
+ covfix(x)$labels[!is.na(covfix(x)$labels)])
+ if (!is.null(x$exfix))
+ res <- c(res,
+ unlist(x$exfix[!is.na(x$exfix) && !is.numeric(x$exfix)]))
+ if (exo)
+ res <- intersect(res,index(Model(x))$exogenous)
+ return(res)
+}
diff --git a/R/parpos.R b/R/parpos.R
new file mode 100644
index 0000000..08aedfe
--- /dev/null
+++ b/R/parpos.R
@@ -0,0 +1,77 @@
+
+##' Generic method for finding indeces of model parameters
+##'
+##' @title Generic method for finding indeces of model parameters
+##' @param x Model object
+##' @param \dots Additional arguments
+##' @author Klaus K. Holst
+##' @export
+`parpos` <-
+ function(x,...) UseMethod("parpos")
+
+##' @export
+parpos.default <- function(x,p,...) {
+ if (is.numeric(p)) return(p)
+ na.omit(match(coef(x),p))
+}
+
+##' @export
+parpos.multigroup <- function(x,p,mean=TRUE,...) {
+ if (missing(p)) {
+ p <- unique(unlist(lapply(x$lvm, function(z) setdiff(parlabels(z),names(constrain(z))) )))
+ }
+ if (!is.character(p)) p <- names(p)
+ p0 <- rep(NA,with(x,npar+npar.mean));
+ names(p0) <- c(x$mean,x$par)
+ for (i in seq_along(x$lvm)) {
+ cur <- parpos(x$lvm[[i]],p=p)
+ if (length(cur)>0) {
+ p0[c(x$meanpos[[i]],x$parpos[[i]])[cur]] <- names(cur)
+ M <- na.omit(match(names(cur),p))
+ if (length(M)>0)
+ p <- p[-M]
+ }
+ if (length(p)==0) break;
+ }
+ p1 <- which(!is.na(match(x$name,p)))
+ p0[p1] <- x$name[p1]
+ return(structure(which(!is.na(p0)),name=p0))
+## return(p0)
+}
+
+##' @export
+parpos.multigroupfit <- function(x,...) parpos.multigroup(x$model0,...)
+
+##' @export
+parpos.lvm <- function(x,p,mean=TRUE,...) {
+ if (!missing(p)) {
+ if (!is.character(p)) p <- names(p)
+ cc1 <- coef(Model(x),mean=mean,fix=FALSE)
+ cc2 <- coef(Model(x),mean=mean,fix=FALSE,labels=TRUE)
+ idx1 <- na.omit(match(p,cc1))
+ idx11 <- na.omit(match(p,cc2))
+ res <- (union(idx1,idx11));
+ if (length(res)!=length(p)) {
+ names(res) <- cc1[res]
+ } else {
+ names(res) <- p
+ }
+ ## res <- idx1; res[!is.na(idx11)] <- idx11[!is.na(idx11)]
+ ## names(res) <- p
+ ord <- order(res)
+ res <- sort(res)
+ attributes(res)$ord <- ord
+ return(res)
+ }
+ if (mean)
+ nn <- with(index(x),matrices2(x,seq_len(npar+npar.mean+npar.ex))) ## Position of parameters
+ else nn <- with(index(x),matrices(x,seq_len(npar),NULL,seq_len(npar.ex)+npar))
+ nn$A[index(x)$M0!=1] <- 0
+ nn$P[index(x)$P0!=1] <- 0
+ nn$v[index(x)$v0!=1] <- 0
+ nn$e[index(x)$e0!=1] <- 0
+ nn
+}
+
+##' @export
+parpos.lvmfit <- parpos.lvm
diff --git a/R/pars.R b/R/pars.R
new file mode 100644
index 0000000..6dcdc4e
--- /dev/null
+++ b/R/pars.R
@@ -0,0 +1,62 @@
+##' @export
+`pars` <-
+ function(x,...) UseMethod("pars")
+
+##' @export
+pars.default <- function(x,...) {
+ if (!is.null(x$opt$estimate))
+ return(x$opt$estimate)
+ if (!is.null(x$opt$par))
+ return(x$opt$par)
+ if (!is.null(x$coef))
+ return(x$coef)
+ return(coef(x))
+}
+
+##' @export
+pars.lvm.missing <- function(x,reorder=FALSE,...) {
+ res <- pars.default(x)
+ if (reorder) {
+ idx <- match(coef(Model(x)),names(coef(x)))
+ return(res[idx])
+ }
+ return(res)
+}
+
+
+
+###{{{ pars.multigroupfit
+## pars.multigroupfit <- function(x,...) {
+## res <- pars.default(x)
+## lapply(ee$model$lvm,coef))
+## coef()
+##}
+###}}}
+
+###{{{ pars.lvm
+
+##' @export
+pars.lvm <- function(x, A, P, v, e, ...) {
+ parres <- A[index(x)$M1==1]
+ diagcorfree <- diag(P)[diag(index(x)$P1)==1]
+ parres <- c(parres, diagcorfree)
+
+ if (ncol(A)>1)
+ for (i in seq_len(ncol(index(x)$P1)-1))
+ for (j in seq(i+1,nrow(index(x)$P1))) {
+ if (index(x)$P1[j,i]!=0) {
+ parres <- c(parres, P[j,i])
+ }
+ }
+ if (length(parres)>0)
+ names(parres) <- paste0("p",seq_len(length(parres)))
+ if (!missing(v)) {
+ parres <- c( v[which(index(x)$v1==1)], parres)
+ }
+ if (!missing(e)) {
+ parres <- c( parres, e[which(index(x)$e1==1)] )
+ }
+ return(parres)
+}
+
+###}}} pars.lvm
diff --git a/R/parsedesign.R b/R/parsedesign.R
new file mode 100644
index 0000000..4043344
--- /dev/null
+++ b/R/parsedesign.R
@@ -0,0 +1,89 @@
+sumsplit <- function(x,...) {
+ plus <- strsplit(x,"\\+")[[1]]
+ spl <- unlist(lapply(plus, function(x) {
+ val <- strsplit(x,"\\-")[[1]]
+ val[-1] <- paste0("-",val[-1])
+ setdiff(val,"")
+ }))
+ res <- c()
+ for (st in spl) {
+ st <- gsub(" ","",st)
+ st0 <- gsub("^[-0-9\\*]*","",st)
+ val <- gsub("\\*","",regmatches(st,gregexpr("^[-0-9\\*]*",st))[[1]])
+ if (val=="") val <- "1"
+ val <- switch(val,"-"=-1,val)
+ res <- c(res,val,st0)
+ }
+ return(res)
+}
+
+##' @export
+parsedesign <- function(coef,x,...,regex=FALSE,diff=TRUE) {
+ if (!is.vector(coef)) coef <- stats::coef(coef)
+ if (is.numeric(coef) && !is.null(names(coef))) coef <- names(coef)
+ dots <- lapply(substitute(list(...)),function(x) x)[-1]
+ expr <- suppressWarnings(inherits(try(x,silent=TRUE),"try-error"))
+ if (expr) {
+ ee <- c(deparse(substitute(x)), unlist(lapply(dots, deparse)))
+ } else {
+ ee <- c(deparse(x), sapply(dots, function(x) deparse(x)))
+ }
+ if (!expr && is.numeric(x)) {
+ return(do.call(contr, list(c(list(x),list(...)),n=length(coef),diff=diff)))
+ }
+ res <- c()
+ diff <- rep(diff,length.out=length(ee))
+ count <- 0
+ for (e in ee) {
+ count <- count+1
+ diff0 <- FALSE
+ Val <- rbind(rep(0,length(coef)))
+ if (grepl('\"',e)) {
+ diff0 <- diff[count] && grepl("^c\\(",e)
+ e0 <- gsub(" |\\)$|^c\\(","",e)
+ ff <- strsplit(e0,'\"')[[1L]]
+ } else {
+ ff <- sumsplit(e)
+ }
+ for (i in seq(length(ff)/2)) {
+ val0 <- gsub("[*()]","",ff[2*(i-1)+1])
+ val <- char2num(val0)
+ if (is.na(val)) {
+ val <- switch(val0,"-"=-1,1)
+ }
+ par0 <- ff[2*i]
+ par0int <- as.integer(char2num(par0))
+ if (!regex) par0 <- glob2rx(par0)
+ if (is.na(par0int)) par0int <- grep(par0,coef)
+ if (length(par0int)>1) {
+ diff0 <- diff[count]
+ for (k in seq_along(par0int)) {
+ if (par0int[k]<=length(Val)) {
+ if (diff[count]) {
+ Val[par0int[k]] <- val
+ } else {
+ Val0 <- Val; Val0[] <- 0
+ Val0[par0int[k]] <- val
+ res <- rbind(res,Val0)
+ }
+ }
+ }
+ } else {
+ if (length(par0int)>0 && par0int<=length(Val)) Val[par0int] <- val
+ }
+ }
+ if (diff0) {
+ n <- sum(Val!=0)
+ if (n>1) {
+ Val0 <- Val
+ ii <- which(Val0!=0)
+ Val <- matrix(0,nrow=n-1,ncol=length(Val))
+ for (i in seq(n-1)) {
+ Val[i,ii[c(1,i+1)]] <- Val0[ii[c(1,i+1)]]*c(1,-1)
+ }
+ }
+ }
+ if (any(Val!=0)) res <- rbind(res,Val)
+ }
+ res
+}
diff --git a/R/partialcor.R b/R/partialcor.R
new file mode 100644
index 0000000..58ca839
--- /dev/null
+++ b/R/partialcor.R
@@ -0,0 +1,58 @@
+##' Calculate partial correlations
+##'
+##' Calculate partial correlation coefficients and confidence limits via Fishers
+##' z-transform
+##'
+##'
+##' @param formula formula speciying the covariates and optionally the outcomes
+##' to calculate partial correlation for
+##' @param data data.frame
+##' @param level Level of confidence limits
+##' @param ... Additional arguments to lower level functions
+##' @return A coefficient matrix
+##' @author Klaus K. Holst
+##' @keywords models regression
+##' @examples
+##'
+##' m <- lvm(c(y1,y2,y3)~x1+x2)
+##' covariance(m) <- c(y1,y2,y3)~y1+y2+y3
+##' d <- sim(m,500)
+##' partialcor(~x1+x2,d)
+##'
+##' @export
+partialcor <- function(formula,data,level=0.95,...) {
+ y <- getoutcome(formula)
+ if (length(y)==0) {
+ preds <- all.vars(formula)
+ yy <- setdiff(names(data),preds)
+ } else {
+ yy <- decomp.specials(y)
+ preds <- attr(y,"x")
+ }
+ if (length(yy)<2)
+ return(NULL)
+ res <- c()
+ for (i in seq_len(length(yy)-1))
+ for (j in seq(i+1,length(yy))) {
+ f <- as.formula(paste("cbind(",yy[i],",",yy[j],")~", paste(preds,collapse="+")))
+ res <- rbind(res, partialcorpair(f,data,level=level))
+ rownames(res)[nrow(res)] <- paste(yy[i],yy[j],sep="~")
+ }
+ return(res)
+}
+
+
+partialcorpair <- function(formula,data,level=0.95,...) {
+ l <- lm(formula,data)
+ k <- ncol(model.matrix(l))
+ n <- nrow(model.matrix(l))
+ r <- residuals(l)
+ rho <- cor(r)[1,2]
+ zrho <- atanh(rho)
+ var.z <- 1/(n-k-3)
+ ci.z <- zrho + c(-1,1)*qnorm(1-(1-level)/2)*sqrt(var.z)
+ ci.rho <- tanh(ci.z)
+ z <- 1/sqrt(var.z)*zrho
+ p.z <- 2*(pnorm(-abs(z))) # p-value using z-transform for H_0: rho=0.
+ return(c(cor=rho,z=z,pval=p.z,lowerCI=ci.rho[1],upperCI=ci.rho[2]))
+}
diff --git a/R/path.R b/R/path.R
new file mode 100644
index 0000000..d6af333
--- /dev/null
+++ b/R/path.R
@@ -0,0 +1,245 @@
+##' Extract all possible paths from one variable to another connected component
+##' in a latent variable model. In an estimated model the effect size is
+##' decomposed into direct, indirect and total effects including approximate
+##' standard errors.
+##'
+##' @title Extract pathways in model graph
+##' @export
+##' @aliases path effects path.lvm effects.lvmfit
+##' totaleffects
+##' @seealso \code{children}, \code{parents}
+##' @return If \code{object} is of class \code{lvmfit} a list with the following
+##' elements is returned \item{idx}{ A list where each element defines a
+##' possible pathway via a integer vector indicating the index of the visited
+##' nodes. } \item{V }{ A List of covariance matrices for each path. }
+##' \item{coef }{A list of parameters estimates for each path} \item{path }{A
+##' list where each element defines a possible pathway via a character vector
+##' naming the visited nodes in order. } \item{edges }{Description of 'comp2'}
+##'
+##' If \code{object} is of class \code{lvm} only the \code{path} element will be
+##' returned.
+##'
+##' The \code{effects} method returns an object of class \code{effects}.
+##' @note For a \code{lvmfit}-object the parameters estimates and their
+##' corresponding covariance matrix are also returned. The
+##' \code{effects}-function additionally calculates the total and indirect
+##' effects with approximate standard errors
+##' @author Klaus K. Holst
+##' @keywords methods models graphs
+##' @examples
+##'
+##' m <- lvm(c(y1,y2,y3)~eta)
+##' regression(m) <- y2~x1
+##' latent(m) <- ~eta
+##' regression(m) <- eta~x1+x2
+##' d <- sim(m,500)
+##' e <- estimate(m,d)
+##'
+##' path(Model(e),y2~x1)
+##' parents(Model(e), ~y2)
+##' children(Model(e), ~x2)
+##' children(Model(e), ~x2+eta)
+##' effects(e,y2~x1)
+##' ## All simple paths (undirected)
+##' path(m,y1~x1,all=TRUE)
+##'
+##' @usage
+##' \method{path}{lvm} (object, to = NULL, from, all=FALSE, ...)
+##' \method{effects}{lvmfit} (object, to, from, silent=FALSE, ...)
+##' @param object Model object (\code{lvm})
+##' @param to Outcome variable (string). Alternatively a formula specifying
+##' response and predictor in which case the argument \code{from} is ignored.
+##' @param from Response variable (string), not necessarily directly affected by
+##' \code{to}.
+##' @param all If TRUE all simple paths (in undirected graph) is returned
+##' @param silent Logical variable which indicates whether messages are turned
+##' on/off.
+##' @param \dots Additional arguments to be passed to the low level functions
+##' @export
+path <- function(object,...) UseMethod("path")
+
+##' @export
+path.lvmfit <- function(object,to=NULL,from,...) {
+ mypath <- pathM(Model(object)$M,to,from,...)
+ cc <- coef(object,level=9,labels=FALSE) ## All parameters (fixed and variable)
+
+ #cc0 <- coef(object,level=1) ## Estimated parameters
+ cc0 <- coef(object,level=2) ## Estimated parameters
+ i1 <- na.omit(match(rownames(cc),rownames(cc0)))
+ idx.cc0 <- which(rownames(cc)%in%rownames(cc0)); ## Position of estimated parameters among all parameters
+ S <- matrix(0,nrow(cc),nrow(cc)); rownames(S) <- colnames(S) <- rownames(cc)
+ V <- object$vcov
+ npar.mean <- index(object)$npar.mean
+# if (object$control$meanstructure & npar.mean>0)
+# V <- V[-c(seq_len(npar.mean)),-c(seq_len(npar.mean))]
+ S[idx.cc0,idx.cc0] <- V[i1,i1] ## "Covariance matrix" of all parameters
+
+ idx <- list()
+ coefs <- list()
+ V <- list()
+ for (i in seq_along(mypath)) {
+ xx <- mypath[[i]]
+ ii <- c()
+ for (j in seq_len(length(xx)-1)) {
+ st <- paste0(xx[j+1], lava.options()$symbol[1], xx[j])
+ ii <- c(ii, match(st,rownames(cc)))
+ }
+ idx <- c(idx, list(ii))
+ V <- c(V, list(S[ii,ii]))
+ coefs <- c(coefs, list(cc[ii]))
+ }
+
+ edges <- list()
+ for (i in seq_along(mypath)) {
+ p0 <- mypath[[i]]
+ ee <- c()
+ for (i in seq_len(length(p0)-1)) {
+ ee <- c(ee, paste(p0[i],p0[i+1],sep="~"))
+ }
+ edges <- c(edges, list(ee))
+ }
+ res <- list(idx=idx,V=V,coef=coefs, path=mypath, edges=edges)
+ return(res)
+}
+
+##' @export
+path.lvm <- function(object,to=NULL,from,all=FALSE,...) {
+ pathM(object$M,to=to,from=from,all=all,...)
+}
+
+##' @export
+path.graphNEL <- function(object,to,from,...) {
+ if (inherits(to,"formula")) {
+ fvar <- extractvar(to)
+ if (length(fvar$x)==1 & length(fvar$y)==1)
+ return(path(object,to=fvar$y,from=fvar$x))
+ res <- list()
+ for (y in fvar$y) {
+ for (x in fvar$x) {
+ cat("x=",x, " y=",y, "\n")
+ res <- c(res, list(path(object,to=y,from=x)))
+ }
+ }
+ return(res)
+ }
+ ff <- function(g,from=1,to=NULL,res=list()) {
+ M <- graph::edgeMatrix(g)
+ i1 <- which(M[1,]==from)
+ for (i in i1) {
+ e <- M[,i]; newto <- e[2];
+ if (is.null(to) || M[2,i]==to) {
+ res <- c(res, list(M[,i]))
+ }
+ newpath <- ff(g,from=newto,to=to,list())
+ if (length(newpath)>0)
+ for (j in seq_along(newpath)) {
+ if (is.null(to) || (tail(newpath[[j]],1)==to))
+ res <- c(res, list(c(M[,i],newpath[[j]][-1])))
+ }
+ }
+ return(res)
+ }
+ idxfrom <- ifelse(is.numeric(from),from,which(from==graph::nodes(object)))
+ ##M <- as(object,"matrix")
+ ##reachable <- acc(M,graph::nodes(object)[idxfrom])
+ reachable <- graph::acc(object,graph::nodes(object)[idxfrom])[[1]]
+
+ if (is.null(to)) {
+ idxto <- reachable
+ } else {
+ idxto <- ifelse(is.numeric(to),to,which(to==graph::nodes(object)))
+ }
+
+ if (!(graph::nodes(object)[idxto] %in% names(reachable)))
+## return(structure(list(),to=to[1],from=from[1]))
+ return(NULL)
+ ## stop("No directional relationship between variables")
+
+ mypaths <- ff(object,idxfrom,idxto)
+ res <- list()
+ for (i in seq_along(mypaths)) {
+ res <- c(res, list(graph::nodes(object)[mypaths[[i]]]))
+ }
+ return(res)
+}
+
+
+pathM <- function(M,to,from,all=FALSE,...) {
+ nn <- colnames(M)
+ if (inherits(to,"formula")) {
+ fvar <- extractvar(to)
+ if (length(fvar$x)==1 & length(fvar$y)==1)
+ return(pathM(M,to=fvar$y,from=fvar$x,all=all))
+ res <- list()
+ for (y in fvar$y) {
+ for (x in fvar$x) {
+ cat("x=",x, " y=",y, "\n")
+ res <- c(res, list(pathM(M,to=y,from=x,all=all)))
+ }
+ }
+ return(res)
+ }
+ if (all) { ## Get all simple paths
+ res <- simplePaths(to,from,from,M,list())
+ return(res)
+ }
+
+
+ ff <- function(g,from=1,to=NULL,res=list()) {
+ i1 <- which(M[from,]==1)
+ for (i in i1) {
+ ## e <- M[,i]; newto <- e[2];
+ if (is.null(to) || i==to) {
+ res <- c(res, list(c(from,i)))
+ }
+ newpath <- ff(g,from=i,to=to,list())
+ if (length(newpath)>0)
+ for (j in seq_along(newpath)) {
+ if (is.null(to) || (tail(newpath[[j]],1)==to))
+ res <- c(res, list(c(c(from,i),newpath[[j]][-1])))
+ }
+ }
+ return(res)
+ }
+ idxfrom <- ifelse(is.numeric(from),from,which(from==nn))
+ reachable <- acc(M,nn[idxfrom])
+
+ if (is.null(to)) {
+ idxto <- reachable
+ } else {
+ idxto <- ifelse(is.numeric(to),to,which(to==nn))
+ }
+
+ if (!(nn[idxto] %in% reachable))
+ return(NULL)
+ ## stop("No directional relationship between variables")
+
+ mypaths <- ff(M,idxfrom,idxto)
+ res <- list()
+ for (i in seq_along(mypaths)) {
+ res <- c(res, list(nn[mypaths[[i]]]))
+ }
+ return(res)
+}
+
+
+
+## Find all simple paths (no cycles) in an undirected graph
+simplePaths <- function(target,currentpath,visited,adjmat,allpaths) {
+ lastnode <- currentpath[length(currentpath)]
+ A <- (adjmat+t(adjmat))>0
+ if (lastnode==target) {
+ allpaths <- c(allpaths,list(currentpath))
+ } else {
+ for (neighbour in rownames(adjmat)[which(A[,lastnode])]) {
+ if (!(neighbour%in%visited)) {
+ currentpath <- c(currentpath,neighbour)
+ visited <- c(visited,neighbour)
+ allpaths <- simplePaths(target,currentpath,visited,adjmat,allpaths)
+ visited <- setdiff(visited,neighbour)
+ currentpath <- currentpath[-length(currentpath)]
+ }
+ }
+ }
+ return(allpaths)
+}
diff --git a/R/pcor.R b/R/pcor.R
new file mode 100644
index 0000000..805a6b0
--- /dev/null
+++ b/R/pcor.R
@@ -0,0 +1,170 @@
+##' Polychoric correlation
+##'
+##' Maximum likelhood estimates of polychoric correlations
+##' @param x Variable 1
+##' @param y Variable 2
+##' @param X Optional covariates
+##' @param start Optional starting values
+##' @param ... Additional arguments to lower level functions
+##' @export
+pcor <- function(x,y,X,start,...) {
+ if (!requireNamespace("mets",quietly=TRUE)) stop("'mets' package required")
+
+ if (is.numeric(x) && is.numeric(y)) {
+ e <- estimate(covariance(lvm(),x~y))
+ return(estimate(e,function(p) list(rho=p[5]/(p[3]*p[4])^.5),iid=TRUE))
+ }
+
+ n1 <- 1+seq(nlevels(x)-1)
+ n2 <- n1[length(n1)]+seq(nlevels(y)-1)
+ if (missing(start)) {
+ f <- as.formula(ifelse(missing(X),"~1","~X"))
+ start <- c(0.5,
+ attr(lava::ordreg(update(f,x~.),fast=TRUE,family=stats::binomial("probit")),"threshold"),
+ attr(lava::ordreg(update(f,y~.),fast=TRUE,family=stats::binomial("probit")),"threshold"))
+ }
+
+ ii <- mets::fast.pattern(cbind(as.numeric(x),as.numeric(y)),categories=max(length(unique(x)),length(unique(y))))
+
+ nn <- table(x,y)
+ ff <- function(theta) {
+ -sum(as.vector(nn)*log(polycor0(theta[1],theta[n1],theta[n2])))
+ }
+ gg <- function(theta) {
+ pp <- polycor0(theta[1],theta[n1],theta[n2],onlyP=FALSE)
+ np <- as.vector(nn)/as.vector(pp$p)
+ -colSums(apply(pp$dp,2,function(x) np*x))
+ }
+ nn0 <- nn; nn[nn==0] <- .5
+ p0 <- as.vector(nn)/sum(nn)
+ logL0 <- sum(as.vector(nn)*log(p0))
+ suppressWarnings(t0 <- system.time(op <- nlminb(start,ff,gg)))
+ cc <- op$par
+ names(cc) <- c("rho",paste(rownames(nn),"x",sep=".")[-1], paste(colnames(nn),"y",sep=".")[-1])
+ V <- solve(numDeriv::jacobian(function(p) gg(p), cc))
+
+ res <- list(coef=cc, vcov=V, tab=nn, logLik0=logL0, logLik=-ff(cc), n1=n1, n2=n2, opt=op, idx=ii)
+ structure(res,class="pcor")
+}
+
+##' @export
+coef.pcor <- function(object,...) object$coef
+
+##' @export
+vcov.pcor <- function(object,...) object$vcov
+
+##' @export
+logLik.pcor <- function(object,p=coef(object),...) {
+ u <- polycor0(p[1],p[object$n1],p[object$n2],onlyP=TRUE)
+ np <- sum(as.vector(object$tab)*log(as.vector(u)))
+ nobs <- sum(object$tab)/2
+ structure(np,nall=nobs,nobs=nobs,df=length(p),class="logLik")
+}
+
+##' @export
+print.pcor <- function(x,...) {
+ res <- cbind(coef(x),diag(vcov(x))^0.5)
+ colnames(res) <- c("Estimate","Std.Err")
+ print(res)
+ df <- length(x$tab)-nrow(res)
+ q <- with(x,2*(logLik0-logLik))
+ cat("\nDeviance = ", q, ", df = ",df,"\n")
+}
+
+##' @export
+score.pcor <- function(x,p=coef(x),indiv=FALSE,...) {
+ u <- polycor0(p[1],p[x$n1],p[x$n2],onlyP=FALSE)
+ if (!indiv) {
+ np <- as.vector(x$tab)/as.vector(u$p)
+ return(colSums(apply(u$dp,2,function(x) np*x)))
+ }
+ U <- u$dp;
+ U <- apply(u$dp,2,function(x) x/as.vector(u$p))
+ ##ii <- unlist(apply(cbind(seq(length(x$tab)),as.vector(x$tab)),1,function(x) rep(x[1],x[2])))
+ Pos <- matrix(0,nrow=prod(dim(x$tab)),ncol=2)
+ count <- 0
+ for (j in seq(ncol(x$tab)))
+ for (i in seq(nrow(x$tab))) {
+ count <- count+1
+ Pos[count,] <- c(i,j)
+ }
+ pos <- match(data.frame(t(x$idx$pattern)),data.frame(t(Pos)))
+ ## pos <- c()
+ ## for (i in seq(nrow(x$idx$pattern))) {
+ ## pos <- c(pos,which(apply(Pos,1,function(y) identical(y,x$idx$pattern[i,]))))
+ ## }
+ return(U[pos[x$idx$group+1],])
+}
+
+
+
+polycor0 <- function(rho,a0,b0,onlyP=TRUE,...) {
+ k1 <- length(a0); k2 <- length(b0)
+ S <- diag(c(1-rho,1-rho))+rho
+ P <- matrix(0,nrow=k1,ncol=k2)
+ P1 <- pnorm(a0,sd=1)
+ P2 <- pnorm(b0,sd=1)
+ set.seed(1)
+ for (i in seq(k1))
+ for (j in seq(k2)) P[i,j] <- mets::pmvn(lower=c(-Inf,-Inf),upper=c(a0[i],b0[j]),sigma=S)
+
+ PP <- Drho <- matrix(0,nrow=k1+1,ncol=k2+1)
+ pmvn0 <- function(i,j,sigma=S) {
+ if (i==0 | j==0) return(0)
+ if (i==(k1+1) & j==(k2+1)) return(1)
+ if (i==(k1+1)) return(P2[j])
+ if (j==(k2+1)) return(P1[i])
+ P[i,j]
+ }
+
+ dpmvn0 <- function(i,j,type=1,k) {
+ if (i==0 | j==0) return(0)
+ if (i==(k1+1) & j==(k2+1)) return(0)
+ if (i==(k1+1)) {
+ if (type==3 && k==j) return(dnorm(b0[j]))
+ return(0)
+ }
+ if (j==(k2+1)) {
+ if (type==2 && k==i) return(dnorm(a0[i]))
+ return(0)
+ }
+ if (type==1) ## rho
+ return(dmvn(c(a0[i],b0[j]),sigma=S))
+ if (type==2) { ## threshold a
+ if (k!=i) return(0)
+ return(dnorm(a0[i])*pnorm((b0[j]-rho*a0[i])/sqrt(1-rho^2)))
+ } ## threshold b
+ if (k!=j) return(0)
+ dnorm(b0[j])*pnorm((a0[i]-rho*b0[j])/sqrt(1-rho^2))
+ }
+
+ for (i in seq(k1+1))
+ for (j in seq(k2+1)) {
+ PP[i,j] <- pmvn0(i,j) + pmvn0(i-1,j-1) -
+ pmvn0(i-1,j) - pmvn0(i,j-1)
+ Drho[i,j] <- dpmvn0(i,j) + dpmvn0(i-1,j-1) -
+ dpmvn0(i-1,j) - dpmvn0(i,j-1)
+ }
+ if (onlyP) return(PP)
+
+ Da <- matrix(0,length(PP),k1)
+ for (k in seq(k1))
+ for (i in seq(k1+1))
+ for (j in seq(k2+1)) {
+ pos <- i + (k1+1)*(j-1)
+ Da[pos,k] <- dpmvn0(i,j,type=2,k=k) + dpmvn0(i-1,j-1,type=2,k=k) -
+ dpmvn0(i-1,j,type=2,k=k) - dpmvn0(i,j-1,type=2,k=k)
+ }
+
+ Db <- matrix(0,length(PP),k2)
+ for (k in seq(k2))
+ for (i in seq(k1+1))
+ for (j in seq(k2+1)) {
+ pos <- i + (k1+1)*(j-1)
+ Db[pos,k] <- dpmvn0(i,j,type=3,k=k) + dpmvn0(i-1,j-1,type=3,k=k) -
+ dpmvn0(i-1,j,type=3,k=k) - dpmvn0(i,j-1,type=3,k=k)
+ }
+
+ list(p=PP,dp=cbind(as.vector(Drho),Da,Db))
+
+}
diff --git a/R/pdfconvert.R b/R/pdfconvert.R
new file mode 100644
index 0000000..b7ddb71
--- /dev/null
+++ b/R/pdfconvert.R
@@ -0,0 +1,39 @@
+##' Convert PDF file to print quality png (default 300 dpi)
+##'
+##' Access to ghostscript program 'gs' is needed
+##' @title Convert pdf to raster format
+##' @param files Vector of (pdf-)filenames to process
+##' @param dpi DPI
+##' @param resolution Resolution of raster image file
+##' @param gs Optional ghostscript command
+##' @param gsopt Optional ghostscript arguments
+##' @param resize Optional resize arguments (mogrify)
+##' @param format Raster format (e.g. png, jpg, tif, ...)
+##' @param \dots Additional arguments
+##' @seealso \code{dev.copy2pdf}, \code{printdev}
+##' @export
+##' @author Klaus K. Holst
+##' @keywords iplot
+pdfconvert <- function(files, dpi=300, resolution=1024, gs, gsopt, resize, format="png", ...) {
+ if (missing(gsopt))
+ gsopt <- "-dSAFTER -dBATCH -dNOPAUSE -sDEVICE=png16m -dGraphicsAlphaBits=4 -dTextAlphaBits=4"
+ if (missing(gs)) {
+ gs <- names(which(Sys.which(c("gs", "gswin32c", "gswin64c")) != ""))
+ }
+ cmd1 <- paste0(gs," -r",dpi," -dBackgroundColor='16#ffffff'")
+ if (missing(resize)) {
+ resize <- paste0("mogrify -resize ", resolution)
+ }
+ for (f in files) {
+ f0 <- strsplit(f,".pdf")[1]
+ f.out <- paste(f0,format,sep=".")
+ f.pdf <- paste(f0,"pdf",sep=".")
+ mycmd1 <- paste0(cmd1, " ", gsopt, " -sOutputFile=", f.out, " > /dev/null ", f.pdf)
+ mycmd2 <- paste0(resize, " ", f.out)
+ cat(f.pdf)
+ system(mycmd1)
+ cat(" -> ")
+ system(mycmd2)
+ cat(f.out, "\n")
+ }
+}
diff --git a/R/plot.R b/R/plot.R
new file mode 100644
index 0000000..de06631
--- /dev/null
+++ b/R/plot.R
@@ -0,0 +1,426 @@
+###{{{ plot.lvm
+
+##' Plot path diagram
+##'
+##' Plot the path diagram of a SEM
+##'
+##'
+##' @aliases plot.lvmfit
+##' @param x Model object
+##' @param diag Logical argument indicating whether to visualize
+##' variance parameters (i.e. diagonal of variance matrix)
+##' @param cor Logical argument indicating whether to visualize
+##' correlation parameters
+##' @param labels Logical argument indiciating whether to add labels
+##' to plot (Unnamed parameters will be labeled p1,p2,...)
+##' @param intercept Logical argument indiciating whether to add
+##' intercept labels
+##' @param addcolor Logical argument indiciating whether to add colors
+##' to plot (overrides \code{nodecolor} calls)
+##' @param plain if TRUE strip plot of colors and boxes
+##' @param cex Fontsize of node labels
+##' @param fontsize1 Fontsize of edge labels
+##' @param noplot if TRUE then return \code{graphNEL} object only
+##' @param graph Graph attributes (Rgraphviz)
+##' @param attrs Attributes (Rgraphviz)
+##' @param unexpr if TRUE remove expressions from labels
+##' @param addstyle Logical argument indicating whether additional
+##' style should automatically be added to the plot (e.g. dashed
+##' lines to double-headed arrows)
+##' @param plot.engine default 'Rgraphviz' if available, otherwise
+##' visNetwork,igraph
+##' @param init Reinitialize graph (for internal use)
+##' @param layout Graph layout (see Rgraphviz or igraph manual)
+##' @param edgecolor if TRUE plot style with colored edges
+##' @param graph.proc Function that post-process the graph object
+##' (default: subscripts are automatically added to labels of the
+##' nodes)
+##' @param ... Additional arguments to be passed to the low level
+##' functions
+##' @author Klaus K. Holst
+##' @keywords hplot regression
+##' @examples
+##'
+##' if (interactive()) {
+##' m <- lvm(c(y1,y2) ~ eta)
+##' regression(m) <- eta ~ z+x2
+##' regression(m) <- c(eta,z) ~ x1
+##' latent(m) <- ~eta
+##' labels(m) <- c(y1=expression(y[scriptscriptstyle(1)]),
+##' y2=expression(y[scriptscriptstyle(2)]),
+##' x1=expression(x[scriptscriptstyle(1)]),
+##' x2=expression(x[scriptscriptstyle(2)]),
+##' eta=expression(eta))
+##' edgelabels(m, eta ~ z+x1+x2, cex=2, lwd=3,
+##' col=c("orange","lightblue","lightblue")) <- expression(rho,phi,psi)
+##' nodecolor(m, vars(m), border="white", labcol="darkblue") <- NA
+##' nodecolor(m, ~y1+y2+z, labcol=c("white","white","black")) <- NA
+##' plot(m,cex=1.5)
+##'
+##' d <- sim(m,100)
+##' e <- estimate(m,d)
+##' plot(e)
+##'
+##' m <- lvm(c(y1,y2) ~ eta)
+##' regression(m) <- eta ~ z+x2
+##' regression(m) <- c(eta,z) ~ x1
+##' latent(m) <- ~eta
+##' plot(lava:::beautify(m,edgecol=FALSE))
+##' }
+##' @export
+##' @method plot lvm
+`plot.lvm` <-
+ function(x,diag=FALSE,cor=TRUE,labels=FALSE,intercept=FALSE,addcolor=TRUE,plain=FALSE,cex,fontsize1=10,noplot=FALSE,graph=list(rankdir="BT"),
+ attrs=list(graph=graph),
+ unexpr=FALSE,
+ addstyle=TRUE,plot.engine=lava.options()$plot.engine,init=TRUE,
+ layout=lava.options()$layout,
+ edgecolor=lava.options()$edgecolor,
+ graph.proc=lava.options()$graph.proc,
+
+ ...) {
+ if (is.null(vars(x))) {
+ message("Nothing to plot: model has no variables.")
+ return(NULL)
+ }
+ index(x) <- reindex(x)
+ ## if (length(index(x)$vars)<2) {
+ ## message("Not available for models with fewer than two variables")
+ ## return(NULL)
+ ## }
+ myhooks <- gethook("plot.post.hooks")
+ for (f in myhooks) {
+ x <- do.call(f, list(x=x,...))
+ }
+
+
+ plot.engine <- tolower(plot.engine)
+ if (plot.engine=="rgraphviz" && (!(requireNamespace("graph",quietly=TRUE)) || !(requireNamespace("Rgraphviz",quietly=TRUE)))) {
+ plot.engine <- "visnetwork"
+ }
+ if (plot.engine=="visnetwork" && (!(requireNamespace("visNetwork",quietly=TRUE)))) {
+ plot.engine <- "igraph"
+ }
+ if (plot.engine=="igraph") {
+ if (!requireNamespace("igraph",quietly=TRUE)) {
+ message("package 'Rgraphviz','igraph' or 'visNetwork' not available")
+ return(NULL)
+ }
+ L <- igraph::layout.sugiyama(g <- igraph.lvm(x,...))$layout
+ if (noplot) return(graph::updateGraph(g))
+ dots <- list(...)
+ if (is.character(layout))
+ plot(g,layout=L,...)
+ else plot(g,layout=layout,...)
+ return(invisible(g))
+ }
+ if (plot.engine=="visnetwork") {
+ g <- vis.lvm(x,labels=labels,...)
+ if (!noplot) print(g)
+ return(g)
+ }
+
+ if (init) {
+ if (!is.null(graph.proc)) {
+ x <- do.call(graph.proc, list(x,edgecol=edgecolor,...))
+ }
+ g <- finalize(x,diag=diag,cor=cor,addcolor=addcolor,intercept=intercept,plain=plain,cex=cex,fontsize1=fontsize1,unexpr=unexpr,addstyle=addstyle)
+ } else {
+ g <- Graph(x)
+ }
+ if (labels) {
+ AP <- matrices(x,paste0("p",seq_len(index(x)$npar)))
+ mylab <- AP$P; mylab[AP$A!="0"] <- AP$A[AP$A!="0"]
+ mylab[!is.na(x$par)] <- x$par[!is.na(x$par)]
+ mylab[!is.na(x$covpar)] <- x$covpar[!is.na(x$covpar)]
+ g <- edgelabels(g, lab=mylab)
+ }
+ if (lava.options()$debug) {
+ plot(g)
+ } else {
+ ## graphRenderInfo(g)$recipEdges <- "distinct"
+ .savedOpt <- options(warn=-1) ## Temporarily disable warnings as renderGraph comes with a stupid warning when labels are given as "expression"
+ dots <- list(...)
+ dots$attrs <- attrs
+ dots$x <- g
+ dots$recipEdges <- "distinct"
+ if (attributes(g)$feedback) dots$recipEdges <- c("combine")
+ if (is.null(dots$layoutType)) dots$layoutType <- layout[1]
+ if (all(index(x)$A==0))
+ dots$layoutType <- "circo"
+
+ g <- do.call(getFromNamespace("layoutGraph","Rgraphviz"), dots)
+ ## Temporary work around:
+ graph::nodeRenderInfo(g)$fill <- graph::nodeRenderInfo(dots$x)$fill
+ graph::nodeRenderInfo(g)$col <- graph::nodeRenderInfo(dots$x)$col
+ graph::edgeRenderInfo(g)$col <- graph::edgeRenderInfo(dots$x)$col
+ if (noplot)
+ return(g)
+ res <- tryCatch(Rgraphviz::renderGraph(g),error=function(e) NULL)
+ { # Redo nodes to avoid edges overlapping node borders
+ par(new=TRUE)
+ res <- tryCatch(Rgraphviz::renderGraph(g,drawEdges=NULL,new=FALSE),error=function(e) NULL)
+ }
+ options(.savedOpt)
+ }
+ ## if (!is.null(legend)) {
+ ## op <- par(xpd=TRUE)
+ ## legend(legend, c("Exogenous","Endogenous","Latent","Time to event"),
+ ## pt.cex=1.5, pch=15, lty=0, col=cols[1:4], cex=0.8)
+ ## par(op)
+ ## }
+
+
+ myhooks <- gethook("plot.hooks")
+ for (f in myhooks) {
+ do.call(f, list(x=x,...))
+ }
+
+ invisible(g)
+}
+
+###}}} plot.lvm
+
+###{{{ vis.lvm
+
+vis.lvm <- function(m,randomSeed=1,width="100%",height="700px",labels=FALSE,cor=TRUE,...) {
+ if (!requireNamespace("visNetwork",quietly=TRUE)) stop("'visNetwork' required")
+ types <- rep("endogenous",length(vars(m)))
+ types[index(m)$eta.idx] <- "latent"
+ types[index(m)$exo.idx] <- "exogenous"
+ col <- lava.options()$node.color
+ colors <- rep(col[2],length(types))
+ colors[index(m)$eta.idx] <- col[3]
+ colors[index(m)$exo.idx] <- col[1]
+ trf <- transform(m)
+ if (length(trf)>0) {
+ colors[which(index(m)$vars%in%names(trf))] <- col[4]
+ }
+ shapes <- rep("box",length(types))
+ shapes[index(m)$eta.idx] <- "circle"
+ nodes <- data.frame(id=seq_along(types),
+ label=vars(m),
+ color=colors,
+ shape=shapes,
+ shadow=TRUE,
+ size=rep(1.0,length(types)),
+ group=types)
+ edges <- cbind(edgeList(m))#,shadow=TRUE)
+
+ AP <- matrices(m,paste0("p",seq_len(index(m)$npar)))
+ if (labels) {
+ mylab <- AP$A;
+ mylab[!is.na(m$par)] <- m$par[!is.na(m$par)]
+ lab <- c()
+ for (i in seq(nrow(edges))) {
+ lab <- c(lab,t(mylab)[edges[i,1],edges[i,2]])
+ }
+ edges <- cbind(edges,label=lab)
+ }
+ if (length(edges)>0)
+ edges <- cbind(edges,dashes=FALSE,arrows="from")
+
+
+ if (cor) {
+ mylab <- AP$P
+ mylab[!is.na(m$covpar)] <- m$covpar[!is.na(m$covpar)]
+ coredges <- data.frame(from=numeric(),to=numeric(),label=character())
+ for (i in seq_len(nrow(mylab)-1)) {
+ for (j in seq(i+1,nrow(mylab))) {
+ if (mylab[i,j]!="0") {
+ coredges <- rbind(coredges,
+ data.frame(from=i,to=j,label=mylab[i,j]))
+ }
+ }
+ }
+ if (nrow(coredges)>0) {
+ if (!labels) coredges <- coredges[,1:2,drop=FALSE]
+ coredges <- cbind(coredges,dashes=TRUE,arrows="false")
+ edges <- rbind(edges,coredges)
+ }
+ }
+
+ if (length(edges)>0) edges$physics <- TRUE
+ v <- visNetwork::visNetwork(nodes,edges,width=width,height=height,...)
+ v <- visNetwork::visEdges(v, arrows=list(from=list(enabled=TRUE, scaleFactor = 0.5)),
+ scaling = list(min = 2, max = 2))
+ v <- visNetwork::visLayout(v,randomSeed=randomSeed)
+ v
+}
+
+###}}} vis.lvm
+
+###{{{ plot.lvmfit
+
+##' @export
+`plot.lvmfit` <-
+ function(x,diag=TRUE,cor=TRUE,type,noplot=FALSE,fontsize1=5,f,graph.proc=lava.options()$graph.proc,...) {
+ if (!missing(f)) {
+ return(plot.estimate(x,f=f,...))
+ }
+ .savedOpt <- options(warn=-1) ## Temporarily disable warnings as renderGraph comes with a stupid warning when labels are given as "expression"
+ if (!requireNamespace("graph",quietly=TRUE)) {
+ plot(Model(x),...)
+ return(invisible(x))
+ }
+ g <- Graph(x)
+ newgraph <- FALSE
+ if (is.null(g)) {
+ newgraph <- TRUE
+ if (!is.null(graph.proc)) {
+ Model(x) <- beautify(Model(x),edgecol=FALSE,...)
+ }
+ Graph(x) <- finalize(Model(x), diag=TRUE, cor=FALSE, fontsize1=fontsize1, ...)
+ }
+ if(noplot) return(Graph(x))
+ if (newgraph) {
+ if (missing(type))
+ type <- "est"
+ x <- edgelabels(x, type=type, diag=diag, cor=cor, fontsize1=fontsize1, ...)
+ } else {
+ if (!missing(type)) {
+ x <- edgelabels(x, type=type, diag=diag, cor=cor, fontsize1=fontsize1, ...)
+ }
+ }
+ g <- Graph(x)
+ var <- rownames(covariance(Model(x))$rel)
+ if (!cor) {
+ delta <- 1
+ for (r in seq_len(nrow(covariance(Model(x))$rel)-delta) ) {
+ for (s in seq(r+delta,ncol(covariance(Model(x))$rel)) ) {
+ if (covariance(Model(x))$rel[r,s]==1) {
+ g <- graph::removeEdge(var[r],var[s], g)
+ g <- graph::removeEdge(var[s],var[r], g)
+ }
+ }
+ }
+ }
+ if (!diag) {
+ for (r in seq_len(nrow(covariance(Model(x))$rel)) ) {
+ if (graph::isAdjacent(g,var[r],var[r]))
+ g <- graph::removeEdge(var[r],var[r],g)
+ }
+ }
+ m <- Model(x); Graph(m) <- g
+ g <- plot(m, diag=diag, cor=cor, fontsize1=fontsize1, init=FALSE, ...)
+ options(.savedOpt)
+ invisible(g)
+ }
+
+###}}} plot.lvmfit
+
+###{{{ plot.multigroup
+
+##' @export
+plot.multigroup <- function(x,diag=TRUE,labels=TRUE,...) {
+ k <- x$ngroup
+ for (i in seq_len(k))
+ plot(x$lvm[[i]],diag=diag,labels=labels, ...)
+}
+
+##' @export
+plot.multigroupfit <- function(x,...) {
+ plot(Model(x),...)
+}
+
+###}}}
+
+###{{{ igraph.lvm
+
+##' @export
+igraph.lvm <- function(x,layout=igraph::layout.kamada.kawai,...) {
+ requireNamespace("igraph",quietly=TRUE)
+ oC <- covariance(x)$rel
+ for (i in seq_len(nrow(oC)-1))
+ for (j in seq(i+1,nrow(oC))) {
+ if (oC[i,j]!=0) {
+ x <- regression(x,vars(x)[i],vars(x)[j])
+ x <- regression(x,vars(x)[j],vars(x)[i])
+ }
+ }
+ g <- igraph::graph.adjacency(x$M,mode="directed")
+ igraph::V(g)$color <- "lightblue"
+ igraph::V(g)$label <- vars(x)
+ igraph::V(g)$shape <- "rectangle"
+ for (i in match(latent(x),igraph::V(g)$name)) {
+ igraph::V(g)$shape[i] <- "circle"
+ igraph::V(g)$color[i] <- "green"
+ }
+ endo <- index(x)$endogenous
+ for (i in match(endo,igraph::V(g)$name)) {
+ igraph::V(g)$color[i] <- "orange"
+ }
+ igraph::E(g)$label <- as.list(rep("",length(igraph::E(g))))
+ oE <- edgelabels(x)
+ for (i in seq_along(igraph::E(g))) {
+ st <- as.character(oE[i])
+ if (length(st)>0)
+ igraph::E(g)$label[[i]] <- st
+ }
+ g$layout <- layout(g)
+ return(g)
+}
+
+###}}} igraph.lvm
+
+
+beautify <- function(x,col=lava.options()$node.color,border=rep("black",3),labcol=rep("darkblue",3),edgecol=TRUE,...) {
+ if (is.null(x$noderender$fill)) notcolored <- vars(x)
+ else notcolored <- vars(x)[is.na(x$noderender$fill)]
+ x0 <- intersect(notcolored,exogenous(x))
+ if (length(x0)>0)
+ nodecolor(x, x0, border=border[1], labcol=labcol[1]) <- col[1]
+ x0 <- intersect(notcolored,endogenous(x))
+ if (length(x0)>0)
+ nodecolor(x, x0, border=border[1], labcol=labcol[1]) <- col[2]
+ x0 <- intersect(notcolored,latent(x))
+ if (length(x0)>0)
+ nodecolor(x, x0, border=border[1], labcol=labcol[1]) <- col[3]
+
+ trimmed <- gsub("[[:digit:]]*$","",vars(x))
+ keep <- num <- c()
+ for (i in seq_len(length(vars(x)))) {
+ lb <- labels(x)[vars(x)[i]]
+ if (is.null(try(eval(lb),silent=TRUE))) {
+ keep <- c(keep,i)
+ num <- c(num,gsub(trimmed[i],"",vars(x)[i]))
+ }
+ }
+ if (length(keep)>0) {
+ trimmed <- trimmed[keep]
+ trim <- gsub(" ",",",trimmed)
+ lab <- paste0('"',vars(x)[keep],'"',"=",paste0("expression(",trim,"[scriptscriptstyle(",num,")])"),collapse=",")
+ labels(x) <- eval(parse(text=paste("c(",lab,")")))
+ }
+ if (!edgecol) return(x)
+ iex <- index(x)$exo.idx
+ ien <- index(x)$endo.idx
+ ila <- index(x)$eta.idx
+ for (i in iex) {
+ for (j in which(x$M[i,]==1)) {
+ elab <- edgelabels(x,to=vars(x)[j],from=rev(vars(x)[i]))
+ elab2 <- try(eval(elab),silent=TRUE)
+ if (is.null(elab2)) elab2 <- ""
+ edgelabels(x, to=vars(x)[j], from=rev(vars(x)[i]), cex=2, lwd=3,col=col[1]) <- elab2
+ }
+ }
+ for (i in ien) {
+ for (j in which(x$M[i,]==1)) {
+ elab <- edgelabels(x,to=vars(x)[j],from=rev(vars(x)[i]))
+ elab2 <- try(eval(elab),silent=TRUE)
+ if (is.null(elab2)) elab2 <- ""
+ edgelabels(x, to=vars(x)[j], from=rev(vars(x)[i]), cex=2, lwd=3,col=col[2]) <- elab2
+ }
+ }
+ for (i in ila) {
+ for (j in which(x$M[i,]==1)) {
+ elab <- edgelabels(x,to=vars(x)[j],from=rev(vars(x)[i]))
+ elab2 <- try(eval(elab),silent=TRUE)
+ if (is.null(elab2)) elab2 <- ""
+ if (is.null(try(eval(elab),silent=TRUE))) elab <- ""
+ edgelabels(x, to=vars(x)[j], from=rev(vars(x)[i]), cex=2, lwd=3,col=col[3]) <- elab2
+ }
+ }
+ x
+
+}
diff --git a/R/plot.estimate.R b/R/plot.estimate.R
new file mode 100644
index 0000000..048968a
--- /dev/null
+++ b/R/plot.estimate.R
@@ -0,0 +1,29 @@
+
+##' @export
+plot.estimate <- function(x,f,idx,intercept=FALSE,data,confint=TRUE,type="l",xlab="x",ylab="f(x)",col=1,add=FALSE,...) {
+ if (!missing(f) && !is.null(f)) {
+ data <- as.list(data)
+ env <- new.env()
+ for (y in names(data)) {
+ assign(y,data[[y]],env)
+ }
+ environment(f) <- env
+ pp <- estimate(x,f,..., vcov=vcov(x),iid=FALSE)$coefmat
+ if (!add) suppressWarnings(plot(data[[1]],pp[,1],xlab=xlab,ylab=ylab,type=type,...))
+ else lines(data[[1]],pp[,1],xlab=xlab,ylab=ylab,type=type,col=col,...)
+ if (confint) confband(data[[1]],pp[,3],pp[,4],polygon=TRUE,col=Col(col),lty=0)
+ return(invisible(pp))
+ }
+ if (!is.null(x$coefmat)) {
+ pp <- x$coefmat[,c(1,3,4),drop=FALSE]
+ } else {
+ pp <- cbind(coef(x),confint(x))
+ }
+ if (!missing(idx)) pp <- pp[idx,,drop=FALSE]
+ if (!intercept) {
+ idx <- match("(Intercept)",rownames(pp))
+ if (length(idx)>0 && !is.na(idx)) pp <- pp[-idx,,drop=FALSE]
+ }
+ forestplot(pp[rev(seq(nrow(pp))),,drop=FALSE],...)
+}
+
diff --git a/R/plotConf.R b/R/plotConf.R
new file mode 100644
index 0000000..289aeac
--- /dev/null
+++ b/R/plotConf.R
@@ -0,0 +1,382 @@
+##' Plot regression line (with interactions) and partial residuals.
+##'
+##' @title Plot regression lines
+##' @param model Model object (e.g. \code{lm})
+##' @param var1 predictor (Continuous or factor)
+##' @param var2 Factor that interacts with \code{var1}
+##' @param data data.frame to use for prediction (model.frame is used as default)
+##' @param ci.lty Line type for confidence limits
+##' @param ci Boolean indicating wether to draw pointwise 95\% confidence limits
+##' @param level Level of confidence limits (default 95\%)
+##' @param pch Point type for partial residuals
+##' @param lty Line type for estimated regression lines
+##' @param lwd Line width for regression lines
+##' @param npoints Number of points used to plot curves
+##' @param xlim Range of x axis
+##' @param col Color (for each level in \code{var2})
+##' @param colpt Color of partial residual points
+##' @param alpha Alpha level
+##' @param cex Point size
+##' @param delta For categorical \code{var1}
+##' @param centermark For categorical \code{var1}
+##' @param jitter For categorical \code{var1}
+##' @param cidiff For categorical \code{var1}
+##' @param mean For categorical \code{var1}
+##' @param legend Boolean (add legend)
+##' @param trans Transform estimates (e.g. exponential)
+##' @param partres Boolean indicating whether to plot partial residuals
+##' @param partse .
+##' @param labels Optional labels of \code{var2}
+##' @param vcov Optional variance estimates
+##' @param predictfun Optional predict-function used to calculate confidence limits and predictions
+##' @param plot If FALSE return only predictions and confidence bands
+##' @param new If FALSE add to current plot
+##' @param \dots additional arguments to lower level functions
+##' @return list with following members:
+##' \item{x}{Variable on the x-axis (\code{var1})}
+##' \item{y}{Variable on the y-axis (partial residuals)}
+##' \item{predict}{Matrix with confidence limits and predicted values}
+##' @author Klaus K. Holst
+##' @seealso \code{termplot}
+##' @aliases plotConf
+##' @export
+##' @examples
+##' n <- 100
+##' x0 <- rnorm(n)
+##' x1 <- seq(-3,3, length.out=n)
+##' x2 <- factor(rep(c(1,2),each=n/2), labels=c("A","B"))
+##' y <- 5 + 2*x0 + 0.5*x1 + -1*(x2=="B")*x1 + 0.5*(x2=="B") + rnorm(n, sd=0.25)
+##' dd <- data.frame(y=y, x1=x1, x2=x2)
+##' lm0 <- lm(y ~ x0 + x1*x2, dd)
+##' plotConf(lm0, var1="x1", var2="x2")
+##' abline(a=5,b=0.5,col="red")
+##' abline(a=5.5,b=-0.5,col="red")
+##' ### points(5+0.5*x1 -1*(x2=="B")*x1 + 0.5*(x2=="B") ~ x1, cex=2)
+##'
+##' data(iris)
+##' l <- lm(Sepal.Length ~ Sepal.Width*Species,iris)
+##' plotConf(l,var2="Species")
+##' plotConf(l,var1="Sepal.Width",var2="Species")
+##'
+##' \dontrun{
+##' ## lme4 model
+##' dd$Id <- rbinom(n, size = 3, prob = 0.3)
+##' lmer0 <- lme4::lmer(y ~ x0 + x1*x2 + (1|Id), dd)
+##' plotConf(lmer0, var1="x1", var2="x2")
+##' }
+##' @keywords hplot, regression
+plotConf <- function(model,
+ var1=NULL,
+ var2=NULL,
+ data=NULL,
+ ci.lty=0,
+ ci=TRUE, level=0.95,
+ pch=16, lty=1, lwd=2,
+ npoints=100,
+ xlim,
+ col=NULL,
+ colpt,
+ alpha=0.5,
+ cex=1,
+ delta=0.07,
+ centermark=0.03,
+ jitter=0.2,
+ cidiff=FALSE,
+ mean=TRUE,
+ legend=ifelse(is.null(var1),FALSE,"topright"),
+ trans=function(x) {x},
+ partres=inherits(model,"lm"),
+ partse=FALSE,
+ labels,
+ vcov,
+ predictfun,
+ plot=TRUE,
+ new=TRUE,
+ ...) {
+
+
+ if (inherits(model,"formula")) model <- lm(model,data=data,...)
+ if (inherits(model,"lmerMod")) {
+ intercept <- lme4::fixef(model)["(Intercept)"]
+ } else {
+ intercept <- coef(model)["(Intercept)"]
+ }
+ if (is.na(intercept)) intercept <- 0
+
+ if (is.null(data)) {
+ curdata <- get_all_vars(model,data=model.frame(model))
+ } else {
+ curdata <- get_all_vars(formula(model), data=data)
+ }
+
+ if (inherits(model,"lmerMod")) {
+ curdata0 <- model.frame(model, data = data, fixed.only = FALSE)
+ } else {
+ curdata0 <- model.frame(model,data) ## Checking for factors
+ }
+
+
+ if (is.null(var1) && is.null(var2)) {
+ var1 <- colnames(curdata)[2]
+ var10 <- colnames(curdata0)[2]
+ } else var10 <- var1
+
+ responseorig <- colnames(curdata)[1]
+ if (inherits(curdata0[,var10],c("character","factor"))) {
+ curdata <- curdata0
+ var2 <- var10; var1 <- NULL
+ }
+ dots <- list(...)
+
+
+ response <- all.vars(formula(model))[1]
+ cname <- colnames(curdata)[-1]
+ if (!is.factor(curdata[,var2]) & !is.null(var2)) {
+ curdata[,var2] <- as.factor(curdata[,var2])
+ colnames(curdata)[1] <- response
+ model <- update(model,as.formula(paste(response,"~.")),data=curdata)
+ }
+ thelevels <- levels(curdata[,var2])
+ if (missing(labels)) labels <- thelevels
+
+ k <- ifelse(is.null(var2),1,length(thelevels))
+ if (is.null(col)) {
+ col <- c("black","darkblue","darkred","goldenrod","mediumpurple",
+ "seagreen","aquamarine3","violetred1","salmon1",
+ "lightgoldenrod1","darkorange2","firebrick1","violetred1", "gold")
+ }
+
+ if (missing(xlim)) {
+ if (!is.null(var1))
+ xlim <- range(curdata[,var1])
+ else
+ xlim <- c(0,length(thelevels))+0.5
+ }
+ dots$xlim <- xlim
+
+ if (is.null(var1) & !is.null(var2)) {
+ ##npoints <- 1
+ x <- unique(curdata[,var2])
+ npoints <- 1#length(x)
+ } else {
+ x <- seq(xlim[1], xlim[2], length.out=npoints)
+ }
+ xx <- c()
+
+ newdata <- data.frame(id=seq(npoints))
+ partdata <- curdata
+ var1.idx <- var2.idx <- 0
+ ii <- 1
+ for (nn in cname) {
+ ii <- ii+1
+ v <- curdata[,nn]
+ if (!is.null(var1) && nn==var1) {
+ var1.idx <- ii
+ newdata <- cbind(newdata, rep(x, k))
+ partdata[,nn] <- 0
+ } else {
+ if (is.factor(v)) {
+ if (nn%in%var2) {
+ var2.idx <- ii
+ newdata <- cbind(newdata, factor(rep(levels(v), each=npoints),levels=thelevels))
+ partdata[,nn] <- factor(rep(levels(v)[1], nrow(partdata)),levels=levels(v))
+ } else {
+ newdata <- cbind(newdata, factor(rep(levels(v)[1], k*npoints),
+ levels=levels(v)))
+ }
+ } else {
+ if (is.logical(v))
+ newdata <- cbind(newdata,FALSE)
+ else
+ newdata <- cbind(newdata,0)
+ }
+ }
+ };
+
+ colnames(newdata) <- c("_id", cname)
+
+ partdata[,response] <- newdata[,response] <- 0
+ var1.newdata <- newdata[,var1.idx]
+ ##newdata <- model.frame(model,data=newdata)
+ ## if (is.factor(newdata[,var1.idx])) {
+ ## partdata[,var1.idx] <- min(var1.newdata)
+ ## }
+ #o#partdata <- model.frame(model,data=partdata)
+ atr <- c("terms")
+ attributes(newdata)[atr] <- attributes(curdata)[atr]
+ attributes(partdata)[atr] <- attributes(partdata)[atr]
+ if (is.factor(newdata[,var1.idx])) {
+ ##partdata[,var1.idx] <- levels(newdata[,var1.idx])[1]
+ }
+ Y <- model.frame(model)[,1]
+ if(inherits(Y,"Surv")) Y <- Y[,1]
+ XX <- model.matrix(formula(terms(model)),data=newdata)
+ if (inherits(model,"lmerMod")) {
+ bb <- lme4::fixef(model)
+ } else {
+ bb <- coef(model)
+ }
+ if (!missing(vcov)) SS <- vcov else {
+ if (inherits(model,"geeglm")) {
+ SS <- (summary(model)$cov.unscaled)
+ } else {
+ SS <- as.matrix(stats::vcov(model))
+ }
+ }
+ ## coefnames <- c("(Intercept)",var1)
+ ## if (!is.null(var2)) {
+ ## var2n <- paste0(var2,thelevels[-1])
+ ## coefnames <- c(coefnames,var2n,paste(var1,var2n,sep=":"),
+ ## paste(var2n,var1,sep=":"))
+ ## }
+ ##bidx <- which(names(bb)%in%coefnames)
+ bidx <- which(apply(XX,2,function(x) !all(x==0)))
+ notbidx <- setdiff(seq(length(bb)),bidx)
+ bb0 <- bb; bb0[notbidx] <- 0
+ myse <- apply(XX[,bidx,drop=FALSE],1,function(x) rbind(x)%*%SS[bidx,bidx,drop=FALSE]%*%cbind(x))^.5
+ ci.all <- list(fit=XX%*%bb0,se.fit=myse)
+ z <- qnorm(1-(1-level)/2)
+ ci.all$fit <- cbind(ci.all$fit,ci.all$fit-z*ci.all$se.fit,ci.all$fit+z*ci.all$se.fit)
+
+ ##residuals(model,type="response") ##
+ ## zero <- bb; zero[-1] <- 0
+ ## intercept <- (model.matrix(model,curdata[1,,])%*%zero)[1]
+
+ if (!missing(predictfun)) {
+ R <- Y-predict(model, newdata=partdata)
+ ci.all <- predict(model, newdata=newdata, se.fit=TRUE, interval = "confidence", level=level,...)
+ } else {
+ XX0 <- model.matrix(formula(terms(model)),data=partdata)
+ R <- Y-XX0%*%bb
+ }
+ if (inherits(model,"lmerMod")) {
+ uz <- as.matrix(unlist(lme4::ranef(model))%*%do.call(Matrix::rBind,lme4::getME(model,"Ztlist")))[1,]
+ R <- R-uz
+ }
+
+ pr <- trans(intercept + R)
+ intercept0 <- 0
+ if (is.na(intercept)) {
+ intercept <- 0
+ if (!is.null(var2)) {
+ intercept <- coef(model)[paste0(var2,thelevels)][as.numeric(curdata[,var2])]
+ intercept0 <- coef(model)[paste0(var2,thelevels[1])]
+ }
+ }
+
+ if (is.null(dots$ylim)) {
+ if (partres) {
+ if (cidiff)
+ dots$ylim <- range(pr)
+ else
+ dots$ylim <- range(trans(c(ci.all$fit)),pr)
+ }
+ else
+ dots$ylim <- trans(range(ci.all$fit))
+ }
+ if (is.null(dots$ylab))
+ dots$ylab <- responseorig
+
+ if (is.null(var1)) {
+ dots$axes=FALSE
+ if (is.null(dots$xlab))
+ dots$xlab <- ""
+ } else {
+ if (is.null(dots$xlab))
+ dots$xlab <- var1
+ }
+
+ if (!plot) return(list(x=x, y=pr, predict=ci.all, predict.newdata=newdata))
+
+ plot.list <- c(x=0,y=0,type="n",dots)
+ if (new) {
+ do.call(graphics::plot, plot.list)
+ if (is.null(var1)) {
+ box()
+ axis(2)
+ axis(1,at=seq(length(thelevels)),labels)
+ }
+ }
+
+ col.trans <- Col(col,alpha)
+
+ Wrap <- function(k,n) { (seq_len(k)-1)%%n +1 }
+ col.i <- Wrap(k,length(col)); col.k <- col[col.i];
+ lty.k <- lty[Wrap(k,length(lty))]
+ pch.k <- pch[Wrap(k,length(pch))]
+
+ if (!is.null(var1)) {
+ for (i in seq_len(k)) {
+ ci0 <- trans(ci.all$fit[(npoints*(i-1)+1):(i*npoints),])
+ y <- ci0[,1]; yu <- ci0[,3]; yl <- ci0[,2]
+ lines(y ~ x, col=col.k[i], lwd=lwd, lty=lty.k[i])
+
+ if (ci) {
+ lines(yl ~ x, lwd=1, col=col.k[i], lty=ci.lty)
+ lines(yu ~ x, lwd=1, col=col.k[i], lty=ci.lty)
+ xx <- c(x, rev(x))
+ yy <- c(yl, rev(yu))
+ polygon(xx,yy, col=col.trans[col.i[i]], lty=0)
+ }
+
+ }
+ }
+ ii <- as.numeric(curdata[,var2])
+
+ if (is.null(var1)) {
+ xx <- curdata[,var2]
+ x <- jitter(as.numeric(xx),jitter)
+ if (missing(colpt)) colpt <- Col(col[1],alpha)
+ if (partres>0)
+ points(pr ~ x,pch=pch[1], col=colpt[1], cex=cex, ...)
+ positions <- seq(k)
+ mycoef <- bb[paste0(var2,thelevels)][-1]
+ if (inherits(model,c("lm","glm")))
+ myconf <- confint(model)[paste0(var2,thelevels)[-1],,drop=FALSE]
+ else {
+ myconf <- matrix(mycoef,ncol=2,nrow=length(mycoef))
+ myconf <- myconf + qnorm(0.975)*cbind((diag(as.matrix(SS))[-1])^0.5)%x%cbind(-1,1)
+ }
+ for (pos in seq(k)) {
+ if (cidiff) {
+ if (pos>1) {
+ ci0 <- trans(intercept+myconf[pos-1,])
+ yl <- ci0[1]; yu <- ci0[2]; y <- trans(intercept+mycoef[pos-1])
+ } else {
+ yu <- yl <- NULL; y <- trans(intercept)
+ }
+ } else if (partse) {
+ y0 <- pr[xx==levels(xx)[pos]]
+ ci0 <- confint(lm(y0~1))
+ yl <- ci0[1]; yu <- ci0[2]; y <- trans(mean(y0))
+ } else {
+ ci0 <- rbind(trans(ci.all$fit[(npoints*(pos-1)+1):(pos*npoints),]))
+ y <- ci0[,1]; yu <- ci0[,3]; yl <- ci0[,2]
+ }
+ if (!mean) y <- NULL
+ confband(pos,yl,yu,delta=delta,center=y,centermark=centermark,col=col[1],lwd=lwd[1],lty=lty[1],cex=cex)
+ }
+ } else {
+ if (partres) {
+ xx <- curdata[,var1]
+ if (!missing(colpt)) {
+ points(pr ~ xx, col=colpt, cex=cex, pch=pch[1],...)
+ } else {
+ if (!is.null(var2))
+ points(pr ~ xx, col=col.k[ii], pch=pch.k[ii], cex=cex, ...)
+ else
+ points(pr ~ xx, col=col[1], pch=pch[1], cex=cex,...)
+ }
+ }
+ }
+
+ if (k>1 && legend!=FALSE) {
+ if (length(lty)>1)
+ legend(legend, legend=thelevels, col=col.k, pch=pch.k, bg="white", lty=lty.k,cex=cex)
+ else
+ legend(legend, legend=thelevels, col=col.k, pch=pch.k, bg="white",cex=cex)
+ }
+
+ ## palette(curpal)
+ invisible(list(x=xx, y=pr, predict=ci.all, predict.newdata=newdata))
+}
diff --git a/R/predict.R b/R/predict.R
new file mode 100644
index 0000000..c9bbfd9
--- /dev/null
+++ b/R/predict.R
@@ -0,0 +1,332 @@
+##' @export
+predict.lvmfit <- function(object,x=NULL,y=NULL,data=model.frame(object),p=coef(object),...) {
+ predict(Model(object),x=x,y=y,p=p,data=data,...)
+}
+
+
+##' @export
+predict.lvm.missing <- function(object,x=NULL,y=NULL,data=model.frame(object),p=coef(object),...) {
+ idx <- match(coef(Model(object)),names(coef(object)))
+ xx <- exogenous(object)
+ p <- p[idx]
+ if (!is.null(x)) {
+ if (inherits(x,"formula")) {
+ xy <- getoutcome(x)
+ if (length(xy)>0) {
+ if (is.null(y)) y <- decomp.specials(xy)
+ }
+ x <- attributes(xy)$x
+ }
+ x <- intersect(x,endogenous(object))
+ if (is.null(y))
+ y <- setdiff(vars(object),c(x,xx))
+ }
+ obs0 <- !is.na(data[,x,drop=FALSE])
+ data[,xx][which(is.na(data[,xx]),arr.ind=TRUE)] <- 0
+ pp <- predict.lvmfit(object,x=x,y=y,data=data,p=p,...)
+ if (all(obs0)) return(pp)
+
+ if (!requireNamespace("mets",quietly=TRUE)) stop("Requires 'mets'")
+ obs <- mets::fast.pattern(obs0)
+ res <- matrix(nrow=nrow(data),ncol=NCOL(pp))
+ for (i in seq(nrow(obs$pattern))) {
+ jj <- which(obs$pattern[i,]==1)
+ ii <- which(obs$group==i-1)
+ if (length(jj)==0) {
+ res[ii,] <- NA
+ } else {
+ res[ii,] <- predict.lvmfit(object,...,p=p,x=x[jj],y=y,data=data[ii,,drop=FALSE])[,colnames(pp),drop=FALSE]
+ }
+ }
+ attributes(res) <- attributes(pp)
+ return(res)
+}
+
+
+##' Prediction in structural equation models
+##'
+##' Prediction in structural equation models
+##' @param object Model object
+##' @param x optional list of (endogenous) variables to condition on
+##' @param y optional subset of variables to predict
+##' @param residual If true the residuals are predicted
+##' @param p Parameter vector
+##' @param data Data to use in prediction
+##' @param path Path prediction
+##' @param quick If TRUE the conditional mean and variance given covariates are returned (and all other calculations skipped)
+##' @param \dots Additional arguments to lower level function
+##' @seealso predictlvm
+##' @examples
+##' m <- lvm(list(c(y1,y2,y3)~u,u~x)); latent(m) <- ~u
+##' d <- sim(m,100)
+##' e <- estimate(m,d)
+##'
+##' ## Conditional mean (and variance as attribute) given covariates
+##' r <- predict(e)
+##' ## Best linear unbiased predictor (BLUP)
+##' r <- predict(e,vars(e))
+##' ## Conditional mean of y3 giving covariates and y1,y2
+##' r <- predict(e,y3~y1+y2)
+##' ## Conditional mean gives covariates and y1
+##' r <- predict(e,~y1+y2)
+##' ## Predicted residuals (conditional on all observed variables)
+##' r <- predict(e,vars(e),residual=TRUE)
+##'
+##' @method predict lvm
+##' @aliases predict.lvmfit
+##' @export
+predict.lvm <- function(object,x=NULL,y=NULL,residual=FALSE,p,data,path=FALSE,quick=is.null(x)&!(residual|path),...) {
+ ## data = data.frame of exogenous variables
+
+ if (!quick && !all(exogenous(object)%in%colnames(data))) stop("data.frame should contain exogenous variables")
+ m <- moments(object,p,data=data,...)
+ if (quick) { ## Only conditional moments given covariates
+ ii <- index(object)
+ P.x <- m$P; P.x[ii$exo.idx, ii$exo.idx] <- 0
+ Cy.x <- (m$IAi%*% tcrossprod(P.x,m$IAi))[ii$endo.idx,ii$endo.idx,drop=FALSE]
+ X <- ii$exogenous
+ mu.0 <- m$v; mu.0[ii$exo.idx] <- 0
+ if (length(X)>0) {
+ mu.x <- matrix(0,ncol=nrow(data),nrow=length(mu.0))
+ mu.x[ii$exo.idx,] <- t(data[,X,drop=FALSE])
+ xi.x <- t(m$IAi[ii$endo.idx,,drop=FALSE]%*%(mu.0 + mu.x))
+ } else {
+ xi.x <- m$xi%x%rep(1,nrow(data))
+ colnames(xi.x) <- ii$endogenous
+ ##xi.x <- matrix(as.vector(m$IAi[ii$endo.obsidx,]%*%mu.0),ncol=nrow(data),nrow=length(mu.0))
+ ##rownames(xi.x) <- names(mu.0)
+ }
+ return(structure(xi.x,cond.var=Cy.x,
+ p=m$p,
+ e=m$e))
+ }
+
+
+ X <- exogenous(object)
+ Y <- setdiff(manifest(object), X)
+ if (path) {
+ X <- colnames(data)
+ Y <- setdiff(Y,X)
+ idx <- which(vars(object)%in%X)
+ if (length(Y)==0) stop("New data set should only contain exogenous variables and a true subset of the endogenous variables for 'path' prediction.")
+ A <- t(m$A)
+ A[,idx] <- 0 ## i.e., A <- A%*%J
+ IAi <- solve(diag(nrow=nrow(A))-t(A))
+ mu.0 <- m$v;
+ mu.0[X] <- 0
+ mu.x <- matrix(0,ncol=nrow(data),nrow=length(mu.0))
+ mu.x[idx,] <- t(data[,vars(object)[idx],drop=FALSE])
+ pred <- t(IAi%*%(mu.0 + mu.x))
+ return(pred)
+ ## Y <- endogenous(object,top=TRUE)
+ ## X <- setdiff(manifest(object),Y)
+ }
+
+
+ IAi <- m$IAi
+ P <- m$P
+ X.idx <- match(X,manifest(object))
+ eta.idx <- match(latent(object),vars(object))
+ obs.idx <- match(manifest(object),vars(object))
+ X.idx.all <- match(X, vars(object))
+ Y.idx.all <- match(Y, vars(object))
+
+ ## Calculation of conditional variance given X=x
+ P.x <- m$P; P.x[X.idx.all, X.idx.all] <- 0
+ C.x <- (IAi%*% P.x %*%t(IAi))
+ Cy.x <- C.x[Y.idx.all,Y.idx.all,drop=FALSE]
+ ## Calculation of conditional mean given X=x
+ G <- m$J%*%IAi
+ mu.0 <- m$v; mu.0[X.idx.all] <- 0
+ if (length(X)>0) {
+ xs <- data[,X,drop=FALSE]
+ mu.x <- apply(xs, 1, FUN=function(i) {res <- rep(0,length(mu.0)); res[X.idx.all] <- i; res})
+ xi.x <- (IAi%*%(mu.0 + mu.x))
+ } else {
+ xi.x <- matrix(as.vector(IAi%*%mu.0),ncol=nrow(data),nrow=length(mu.0))
+ rownames(xi.x) <- names(mu.0)
+ }
+
+ attr(xi.x,"cond.var") <- Cy.x
+ if (path) return(t(xi.x))
+ Ey.x <- xi.x[Y.idx.all,,drop=FALSE]
+ Eeta.x <- xi.x[eta.idx,,drop=FALSE]
+ Cy.epsilon <- P.x%*%t(IAi) ## Covariance y,residual
+ Czeta.y <- Cy.epsilon[eta.idx,index(object)$endo.idx]
+ A <- m$A
+ IA <- diag(nrow=nrow(A))-t(A)
+
+ y0 <- intersect(Y,colnames(data))
+ ys <- data[,y0,drop=FALSE]
+ y0.idx <- match(y0,Y)
+ ry <- t(ys)-Ey.x[y0.idx,,drop=FALSE]
+
+ if (!is.null(x)) {
+ if (inherits(x,"formula")) {
+ xy <- getoutcome(x)
+ if (length(xy)>0) {
+ if (is.null(y)) y <- decomp.specials(xy)
+ }
+ x <- attributes(xy)$x
+ }
+ if (length(x)==0) {
+ if (!is.null(y)) {
+ xi.x <- xi.x[y,,drop=FALSE]
+ attr(xi.x,"cond.var") <- Cy.x[y,y,drop=FALSE]
+ }
+ return(t(xi.x))
+ }
+ x <- intersect(x,endogenous(object))
+ if (is.null(y))
+ y <- setdiff(vars(object),c(x,exogenous(object)))
+ if (length(x)>0) {
+ E.x <- xi.x[y,,drop=FALSE] + C.x[y,x]%*%solve(C.x[x,x])%*%ry[x,,drop=FALSE]
+ } else {
+ E.x <- xi.x[y,,drop=FALSE]
+ }
+ if (residual) {
+ Vhat <- matrix(0, nrow(data), length(vars(object))); colnames(Vhat) <- vars(object)
+ Vhat[,obs.idx] <- as.matrix(data[,manifest(object),drop=FALSE])
+ Vhat[,y] <- t(E.x)
+ return(t((IA%*%t(Vhat)-m$v)))
+ }
+ res <- t(E.x); colnames(res) <- y
+ if (length(x)>0) {
+ attr(res,"cond.var") <-
+ C.x[y,y,drop=FALSE]-C.x[y,x,drop=FALSE]%*%solve(C.x[x,x,drop=FALSE])%*%C.x[x,y,drop=FALSE]
+ } else {
+ attr(res,"cond.var") <- C.x[y,y,drop=FALSE]
+ }
+ return(res)
+ }
+
+ ys <- data[,Y,drop=FALSE]
+ ry <- t(ys)-Ey.x
+
+ if (length(eta.idx)>0) {
+ Ceta.x <- C.x[eta.idx,eta.idx]
+ Lambda <- A[Y.idx.all,eta.idx,drop=FALSE] ##, ncol=length(eta.idx))
+ Cetay.x <- Ceta.x%*%t(Lambda)
+ KK <- Cetay.x %*% solve(Cy.x)
+ Eeta.y <- Eeta.x + KK %*% ry
+
+ Ceta.y <- Ceta.x - KK%*% t(Cetay.x)
+ } else {
+ Eeta.y <- NA
+ Ceta.y <- NA
+ }
+
+ Vhat <- matrix(0, nrow(data), length(vars(object))); colnames(Vhat) <- vars(object)
+ Vhat[,obs.idx] <- as.matrix(data[,manifest(object)])
+ if (length(eta.idx)>0)
+ Vhat[,latent(object)] <- t(Eeta.y)
+ I <- diag(nrow=nrow(A));
+ epsilonhat <- (t( IA%*%t(Vhat) - m$v ))[,c(endogenous(object),latent(object)),drop=FALSE]
+ if (residual) {
+ return(epsilonhat)
+ }
+
+ mydata <- matrix(0,ncol=ncol(A),nrow=nrow(data)); colnames(mydata) <- vars(object)
+ mydata[,manifest(object)] <- as.matrix(data[,manifest(object)])
+ for (i in latent(object))
+ mydata[,i] <- m$v[i]
+
+ Yhat <- t(mydata%*%t(A)) + (m$v)
+ res <- cbind(t(Ey.x)) ## Conditional mean
+
+ attr(res, "cond.var") <- Cy.x
+ attr(res, "blup") <- t(Eeta.y)
+ attr(res, "var.blup") <- Ceta.y
+ attr(res, "Ey.x") <- Ey.x
+ attr(res, "eta.x") <- Eeta.x
+ attr(res, "epsilon.y") <- epsilonhat
+ attr(res, "p") <- m$p
+ attr(res, "e") <- m$e
+ class(res) <- c("lvm.predict","matrix")
+ return(res)
+}
+
+##' @export
+print.lvm.predict <- function(x,...) print(x[,])
+
+##' Predict function for latent variable models
+##'
+##' Predictions of conditinoal mean and variance and calculation of
+##' jacobian with respect to parameter vector.
+##' @export
+##' @param object Model object
+##' @param formula Formula specifying which variables to predict and which to condition on
+##' @param p Parameter vector
+##' @param data Data.frame
+##' @param ... Additional arguments to lower level functions
+##' @seealso predict.lvm
+##' @examples
+##' m <- lvm(c(x1,x2,x3)~u1,u1~z,
+##' c(y1,y2,y3)~u2,u2~u1+z)
+##' latent(m) <- ~u1+u2
+##' d <- simulate(m,10,"u2,u2"=2,"u1,u1"=0.5,seed=123)
+##' e <- estimate(m,d)
+##'
+##' ## Conditional mean given covariates
+##' predictlvm(e,c(x1,x2)~1)$mean
+##' ## Conditional variance of u1,y1 given x1,x2
+##' predictlvm(e,c(u1,y1)~x1+x2)$var
+predictlvm <- function(object,formula,p=coef(object),data=model.frame(object),...) {
+ model <- Model(object)
+ if (!missing(formula)) {
+ yx <- getoutcome(formula)
+ y <- decomp.specials(yx)
+ x <- attr(yx,"x")
+ x <- setdiff(x,index(model)$exogenous)
+ } else {
+ y <- index(model)$latent
+ x <- index(model)$endogenous
+ }
+ endo <- with(index(model),setdiff(vars,exogenous))
+ idxY <- match(y,endo)
+ idxX <- match(x,endo)
+ ny <- length(y)
+ if (ny==0) return(NULL)
+ m <- modelVar(model,p,conditional=TRUE,data=data,latent=TRUE)
+ D <- deriv.lvm(model,p,conditional=TRUE,data=data,latent=TRUE)
+ N <- nrow(data)
+ ii0 <- seq(N)
+ iiY <- sort(unlist(lapply(idxY,function(x) ii0+N*(x-1))))
+ k <- ncol(m$xi)
+ J <- matrix(seq(k^2),k)
+ if (length(idxX)==0) { ## Return conditional mean and variance given covariates
+ M <- m$xi[,idxY,drop=FALSE]
+ dM <- D$dxi[iiY,,drop=FALSE]
+ V <- m$C[idxY,idxY,drop=FALSE]
+ dV <- D$dS[as.vector(J[idxY,idxY]),,drop=FALSE]
+ } else {
+ iiX <- sort(unlist(lapply(idxX,function(x) ii0+N*(x-1))))
+ X <- as.matrix(data[,x,drop=FALSE])
+ rX <- X-m$xi[,idxX,drop=FALSE]
+ dX <- D$dxi[iiX,,drop=FALSE]
+ ic <- solve(m$C[idxX,idxX,drop=FALSE])
+ c2 <- m$C[idxY,idxX,drop=FALSE]
+ B <- c2%*%ic
+ ## Conditional variance
+ V <- m$C[idxY,idxY,drop=FALSE]-B%*%t(c2)
+ dV <- D$dS[as.vector(J[idxY,idxY]),,drop=FALSE] -
+ (
+ (B%x%diag(nrow=ny))%*%D$dS[as.vector(J[idxY,idxX]),,drop=FALSE] +
+ -(B%x%B)%*%D$dS[as.vector(J[idxX,idxX]),,drop=FALSE] +
+ (diag(nrow=ny)%x%B)%*%D$dS[as.vector(J[idxX,idxY]),,drop=FALSE]
+ )
+ ## Conditional mean
+ M <- m$xi[,idxY,drop=FALSE]+rX%*%t(B)
+ dB <- (ic%x%diag(nrow=ny))%*%D$dS[as.vector(J[idxY,idxX]),,drop=FALSE]+
+ -(ic%x%B)%*%D$dS[as.vector(J[idxX,idxX]),,drop=FALSE]
+ ## Find derivative of transposed matrix
+ n0 <- as.vector(matrix(seq(prod(dim(B))),ncol=nrow(B),byrow=TRUE))
+ dB. <- dB[n0,,drop=FALSE]
+ dM <- D$dxi[iiY,,drop=FALSE] +
+ ((diag(nrow=ny)%x%rX)%*%dB.) - kronprod(B,dX)
+ }
+ colnames(M) <- y
+ dimnames(V) <- list(y,y)
+ return(list(mean=M,mean.jacobian=dM,var=V,var.jacobian=dV))
+}
+
diff --git a/R/print.R b/R/print.R
new file mode 100644
index 0000000..dc6c9ab
--- /dev/null
+++ b/R/print.R
@@ -0,0 +1,211 @@
+###{{{ print.lvm
+
+##' @export
+`print.lvm` <-
+function(x, ..., print.transform=TRUE,print.exogenous=TRUE) {
+ res <- NULL
+ myhooks <- gethook("print.hooks")
+ for (f in myhooks) {
+ res <- do.call(f, list(x=x,...))
+ }
+ if (is.null(res)) {
+ k <- length(vars(x))
+ L <- rep(FALSE,k); names(L) <- vars(x); L[latent(x)] <- TRUE
+ cat("Latent Variable Model\n") ##;" \n\twith: ", k, " variables.\n", sep="");
+ if (k==0) {
+ cat("\nEmpty\n")
+ return()
+ }
+ ff <- formula(x,char=TRUE,all=TRUE)
+ R <- Rx <- Rt <- c()
+ exo <- exogenous(x)
+ for (f in ff) {
+ oneline <- as.character(f);
+ y <- strsplit(f,"~")[[1]][1]
+ y <- trim(y)
+ {
+ col1 <- as.character(oneline)
+ D <- attributes(distribution(x)[[y]])$family
+ Tr <- x$attributes$transform[[y]]
+ col2 <- tryCatch(x$attributes$type[[y]],error=function(...) NULL)
+ if (is.null(col2) || is.na(col2)) col2 <- "gaussian"
+ if (!is.null(Tr)){
+ col1 <- paste0(y,' ~ ',paste0(Tr$x,collapse="+"),sep="")
+ Rt <- rbind(Rt, c(col1,""))
+ }
+ if (!is.null(D$family)) {
+ col2 <- paste0(D$family)
+ }
+ if (!is.null(D$link)) col2 <- paste0(col2,"(",D$link,")")
+ if (!is.null(D$par)) col2 <- paste0(col2,"(",paste(D$par,collapse=","),")")
+ if (is.list(distribution(x)[[y]]) && is.vector(distribution(x)[[y]][[1]])) col2 <- "fixed"
+ if (L[y]) col2 <- paste0(col2,", latent")
+ if (y%in%exo) {
+ Rx <- rbind(Rx,c(col1,col2))
+ } else {
+ if (is.null(Tr)) {
+ R <- rbind(R,c(col1,col2))
+ }
+ }
+ }
+ }
+ if (length(R)>0) {
+ rownames(R) <- paste(" ",R[,1]," "); colnames(R) <- rep("",ncol(R))
+ print(R[,2,drop=FALSE],quote=FALSE,...)
+ }
+ if (print.exogenous && length(Rx)>0) {
+ cat("\nExogenous variables:")
+ rownames(Rx) <- paste(" ",gsub("~ 1","",Rx[,1])," "); colnames(Rx) <- rep("",ncol(Rx))
+ print(Rx[,2,drop=FALSE],quote=FALSE,...)
+ }
+ if (print.transform && length(Rt)>0) {
+ cat("\nTransformations:")
+ rownames(Rt) <- paste(" ",gsub("~ 1","",Rt[,1])," "); colnames(Rt) <- rep("",ncol(Rt))
+ print(Rt[,2,drop=FALSE],quote=FALSE,...)
+ }
+
+ }
+ cat("\n")
+ invisible(x)
+}
+
+###}}} print.lvm
+
+###{{{ print.lvmfit
+
+##' @export
+`print.lvmfit` <-
+function(x,level=2,labels=FALSE,...) {
+ print(CoefMat(x,labels=labels,level=level,...),quote=FALSE,right=TRUE)
+ minSV <- attr(vcov(x),"minSV")
+ if (!is.null(minSV) && minSV<1e-12) {
+ warning("Small singular value: ", format(minSV))
+ }
+ pseudo <- attr(vcov(x),"pseudo")
+ if (!is.null(pseudo) && pseudo) warning("Singular covariance matrix. Pseudo-inverse used.")
+ invisible(x)
+}
+
+###}}} print.lvmfit
+
+###{{{ print.lvmfit.randomslope
+
+##' @export
+print.lvmfit.randomslope <- function(x,labels=FALSE,level=2,...) {
+ print(CoefMat(x,labels=labels,level=level,...),quote=FALSE,right=TRUE)
+ invisible(x)
+}
+
+###}}}
+
+###{{{ print.multigroupfit
+
+##' @export
+print.multigroupfit <- function(x,groups=NULL,...) {
+ if (is.null(groups)) {
+ if (x$model$missing) {
+ modelclass <- attributes(x$model0)$modelclass
+ nmis <- attributes(x$model0)$nmis
+ orggroup <- unique(modelclass)
+ groupn <- unlist(lapply(orggroup,function(i) sum(modelclass==i)))
+ cumsumgroup <- cumsum(c(0,groupn))
+ groups <- unlist(lapply(orggroup,function(i)
+ which.min(nmis[which(modelclass==i)])+cumsumgroup[i])) ## groups with max. number of variables
+ for (i in seq_len(length(groups))) {
+ if (nmis[groups[i]]>0) warning("No complete cases in group ",i,". Showing results of group with max number of variables. All coefficients can be extracted with 'coef'. All missing pattern groups belonging to this sub-model can be extracted by calling: coef(..., groups=c(",paste(which(modelclass==i),collapse=","),"))")
+ }
+ if (!is.null(x$model$mnameses))
+ x$model$names <- x$model$mnames
+ } else {
+ groups <- seq_len(length(x$model$lvm))
+ }
+ }
+ res <- coef(x,level=2,groups=groups,...)
+ counter <- 0
+ dots <- list(...)
+ dots$groups <- groups
+ level <- if (is.null(dots$level)) {
+ dots$level <- 2
+## dots$level <- ifelse("lvmfit.randomslope"%in%class(x),2,9)
+ }
+ myargs <- c(list(x=x), dots)
+ myargs$groups <- groups
+ CC <- do.call("CoefMat.multigroupfit",myargs)
+ for (cc in res) {
+ counter <- counter+1
+ cat(rep("_",52),"\n",sep="")
+ cat("Group ", counter, sep="")
+ myname <- x$model$names[counter]
+ if (!is.null(myname) && !is.na(myname))
+ cat(": ",myname,sep="")
+ if (!x$model$missing) cat(" (n=",nrow(Model(x)$data[[groups[counter]]]), ")", sep="")
+ cat("\n")
+ print(CC[[counter]],quote=FALSE,right=TRUE)
+ }
+ cat("\n")
+ invisible(x)
+}
+
+###}}} print.multigroupfit
+
+###{{{ print.multigroup
+
+##' @export
+print.multigroup <- function(x,...) {
+ cat("\n")
+ cat("Number of groups:", x$ngroup, "\n")
+ cat("Number of free parameters (not counting mean-parameters):", x$npar,"\n")
+## cat("Parameter-vector:", unlist(x$parlist), "\n\n")
+ cat("Number of free mean parameters:", length(grep("m",x$mean)),"\n")
+## cat("Mean-vector:", x$mean, "\n\n")
+ invisible(x)
+}
+
+###}}} print.multigroup
+
+###{{{ printmany
+
+printmany <- function(A,B,nspace=1,name1=NULL,name2=NULL,digits=3,rownames=NULL,emptystr=" ",bothrows=!is.table(A),right=TRUE,print=TRUE,...) {
+ cA <- colnames(A); cB <- colnames(B)
+ A <- format(A, digits=digits, right=right, ...)
+ B <- format(B, digits=digits, right=right, ...)
+ nA <- nrow(A); nB <- nrow(B)
+ if (nrow(A)<nrow(B)) {
+ rA <- rownames(A)
+ A <- rbind(A, matrix("", nrow=nB-nA, ncol=ncol(A)))
+ }
+ if (nrow(B)<nrow(A)) {
+ rB <- rownames(B)
+ B <- rbind(B, rep("", nrow=nA-nB, ncol=ncol(B)))
+ }
+ if (!is.null(rownames) & length(rownames)==nrow(A))
+ rownames(A) <- rownames(B) <- rownames
+ res <- cbind(A, matrix("", nrow=nrow(A), ncol=nspace));
+ dnn <- dimnames(A)
+ dnn[[2]] <- c(dnn[[2]],rep(emptystr,nspace))
+ dimnames(res) <- dnn
+ ##dimnames(res)[[2]] <- c(dimnames(res)[[2]],rep(emptystr,nspace))
+ if (!is.null(name1)) {
+ oldname <- colnames(res)
+ res <- cbind(rep("",nrow(res)), rownames(res), res);
+ cres <- name1
+ if (!is.null(rownames(res))) cres <- c(cres,"")
+ colnames(res) <- c(cres,oldname)
+ rownames(res) <- rep("",nrow(res))
+ }
+ if (!is.null(name2)) {
+ oldname <- colnames(res)
+ res <- cbind(res,rep("",nrow(res))); colnames(res) <- c(oldname,name2)
+ }
+ if (!identical(rownames(A),rownames(B)) & bothrows)
+ res <- cbind(res, rownames(B))
+ res <- cbind(res, B)
+ if (is.null(name2)) {
+ dnn[[2]] <- c(dnn[[2]],dimnames(B)[[2]])
+ dimnames(res) <- dnn
+ }
+ if (print) print(res, quote=FALSE, right=right, ...)
+ invisible(res)
+}
+
+###}}} printmany
diff --git a/R/procformula.R b/R/procformula.R
new file mode 100644
index 0000000..7c89b28
--- /dev/null
+++ b/R/procformula.R
@@ -0,0 +1,175 @@
+##' @export
+procformula <- function(object=NULL,value,exo=lava.options()$exogenous,...) {
+
+ ## Split into reponse and covariates by ~ disregarding expressions in parantheses
+ ## '(?!...)' Negative lookahead assertion
+ regex <- "~(?![^\\(].*\\))"
+ yx <- lapply(strsplit(as.character(value),regex,perl=TRUE),function(x) gsub(" ","",x))[-1]
+ yx <- lapply(yx,function(x) gsub("\n","",x))
+ iscovar <- FALSE
+ if (length(yx)==1) {
+ lhs <- NULL; xidx <- 1
+ } else {
+ lhs <- yx[1]; xidx <- 2
+ if (yx[[xidx]][1]=="") {
+ yx[[xidx]] <- yx[[xidx]][-1]
+ iscovar <- TRUE
+ }
+ }
+ ##Check for link function
+ invlink <- NULL
+ if (xidx==2) {
+ if (length(grep("[a-zA-Z0-9_]*\\(.*\\)$",yx[[xidx]]))>0) { ## rhs of the form F(x+y)
+ invlink <- strsplit(yx[[xidx]],"\\(.*\\)")[[1]][1]
+ if (invlink%in%c("f","v","I","") ||
+ grepl("\\+",invlink))
+ { ## Reserved for setting linear constraints
+ invlink <- NULL
+ } else {
+ yx[[xidx]] <- gsub(paste0(invlink,"\\(|\\)$"),"",yx[[xidx]])
+ }
+ }
+ }
+
+ ## Handling constraints with negative coefficients
+ ## while not tampering with formulas like y~f(x,-2)
+ st <- yx[[xidx]]
+ st <- gsub("\\-","\\+\\-",gsub("\\+\\-","\\-",st)) ## Convert - to +- (to allow for splitting on '+')
+ ##gsub("[^,]\\-","\\+\\-",st) ## Convert back any - not starting with ','
+ st <- gsub(",\\+",",",st) ## Remove + inside 'f' and 'v' constraints
+ st <- gsub("^\\+","",st) ## Remove leading plus
+ yx[[xidx]] <- st
+
+ ## Match '+' but not when preceeded by ( ... )
+ X <- strsplit(yx[[xidx]],"\\+(?![^\\(]*\\))", perl=TRUE)[[1]]
+
+ ##regex <- "(?!(\\(*))[\\(\\)]"
+ regex <- "[\\(\\)]"
+ ## Keep squares brackets and |(...) statements
+ ## Extract variables from expressions like
+ ## f(x,b) -> x,b and 2*x -> 2,cx
+ ## but avoid to tamper with transformation expressions:
+ ## a~(x*b)
+ res <- lapply(X,decomp.specials,regex,pattern2="\\*",pattern.ignore="~",reverse=TRUE,perl=TRUE)
+ ##OLD:
+ ##res <- lapply(X,decomp.specials,pattern2="[*]",reverse=TRUE)
+ xx <- unlist(lapply(res, function(x) x[1]))
+
+ xxf <- lapply(as.list(xx),function(x) decomp.specials(x,NULL,pattern2="\\[|~",perl=TRUE))
+ xs <- unlist(lapply(xxf,function(x) x[1]))
+
+ ## Alter intercepts?
+ intpos <- which(vapply(xs,function(x) grepl("^[\\+\\-]*[\\.|0-9]+$",x), 0)==1)
+ ## Match '(int)'
+ intpos0 <- which(vapply(X,function(x) grepl("^\\([\\+\\-]*[\\.|0-9]+\\)$",x),0)==1)
+
+ yy <- ys <- NULL
+ if (length(lhs)>0) {
+ yy <- decomp.specials(lhs)
+ yyf <- lapply(yy,function(y) decomp.specials(y,NULL,pattern2="[",fixed=TRUE,perl=FALSE))
+ ys <- unlist(lapply(yyf,function(x) x[1]))
+ }
+
+ notexo <- c()
+ if (!is.null(object)) {
+ if (length(lhs)>0) {
+ object <- addvar(object,ys,reindex=FALSE,...)
+ notexo <- ys
+ ## Add link-transformation
+ if (!is.null(invlink)) {
+ if (invlink=="") {
+ object <- transform(object,ys,NULL,post=FALSE)
+ covariance(object,ys) <- NA
+ } else {
+ ff <- function(x) {}; body(ff) <- parse(text=paste0(invlink,"(x)"))
+ object <- transform(object,ys,ff,post=FALSE)
+ covariance(object,ys) <- 0
+ }
+ }
+ }
+
+ if (length(intpos>0)) {
+ xs[intpos[1]] <- gsub("\\+","",xs[intpos[1]])
+ if (xs[intpos[1]]==1 && (!length(intpos0)>0) ) {
+ xs[intpos[1]] <- NA
+ }
+ intercept(object,ys) <- char2num(xs[intpos[1]])
+ xs <- xs[-intpos]
+ res[intpos] <- NULL
+ }
+
+ object <- addvar(object,xs,reindex=FALSE ,...)
+ exolist <- c()
+
+ for (i in seq_len(length(xs))) {
+
+ ## Extract transformation statements: var~(expr)
+ xf0 <- strsplit(xx[[i]],"~")[[1]]
+ if (length(xf0)>1) {
+ myexpr <- xf0[2]
+ ftr <- toformula(y="",x=paste0("-1+I(",myexpr,")"))
+ xtr <- all.vars(ftr)
+ xf0 <- xf0[1]
+ transform(object, y=xf0, x=xtr) <- function(x) {
+ structure(model.matrix(ftr,as.data.frame(x)),dimnames=list(NULL,xf0))
+ }
+ }
+
+ xf <- unlist(strsplit(xf0,"[\\[\\]]",perl=TRUE))
+ if (length(xf)>1) {
+ xpar <- strsplit(xf[2],":")[[1]]
+ if (length(xpar)>1) {
+ val <- ifelse(xpar[2]=="NA",NA,xpar[2])
+ valn <- char2num(val)
+ covariance(object,xs[i]) <- ifelse(is.na(valn),val,valn)
+ }
+ val <- ifelse(xpar[1]=="NA",NA,xpar[1])
+ valn <- char2num(val)
+ if (is.na(val) || val!=".") {
+ intercept(object,xs[i]) <- ifelse(is.na(valn),val,valn)
+ notexo <- c(notexo,xs[i])
+ }
+ } else { exolist <- c(exolist,xs[i]) }
+ }
+
+ for (i in seq_len(length(ys))) {
+ y <- ys[i]
+ yf <- unlist(strsplit(yy[i],"[\\[\\]]",perl=TRUE))
+ if (length(yf)>1) {
+ ypar <- strsplit(yf[2],":")[[1]]
+ if (length(ypar)>1) {
+ val <- ifelse(ypar[2]=="NA",NA,ypar[2])
+ valn <- char2num(val)
+ covariance(object,y) <- ifelse(is.na(valn),val,valn)
+ }
+ val <- ifelse(ypar[1]=="NA",NA,ypar[1])
+ valn <- char2num(val)
+ if (is.na(val) || val!=".") {
+ intercept(object,y) <- ifelse(is.na(valn),val,valn)
+ }
+ }
+ }
+
+ curvar <- index(object)$var
+ if (exo) {
+ oldexo <- exogenous(object)
+ newexo <- setdiff(exolist,c(notexo,curvar,ys))
+ exogenous(object) <- union(newexo,setdiff(oldexo,notexo))
+ }
+ }
+
+ return(list(object=object,
+ yx=yx,
+ X=X,
+ ys=ys,
+ xx=xx,
+ xs=xs,
+ yy=yy,
+ ys=ys,
+ res=res,
+ notexo=notexo,
+ intpos=intpos,
+ invlink=invlink,
+ lhs=lhs,
+ iscovar=iscovar))
+}
diff --git a/R/profile.R b/R/profile.R
new file mode 100644
index 0000000..ecec608
--- /dev/null
+++ b/R/profile.R
@@ -0,0 +1,66 @@
+##' @export
+profile.lvmfit <- function(fitted,idx,tau,...) {
+ mm <- parfix(Model(fitted),idx,tau)
+ index(mm) <- reindex(mm,zeroones=TRUE,deriv=TRUE)
+ fixed <- attributes(mm)$fixed
+ plogl <- function(tau0) {
+ for (i in fixed$v) {
+ mm$mean[[i]] <- tau0
+ }
+ for (i in seq_len(nrow(fixed$A))) {
+ index(mm)$A[fixed$A[i,1],fixed$A[i,2]] <-
+ mm$fix[fixed$A[i,1],fixed$A[i,2]] <- tau0
+ }
+ for (i in seq_len(nrow(fixed$P))) {
+ index(mm)$P[fixed$P[i,1],fixed$P[i,2]] <-
+ mm$covfix[fixed$P[i,1],fixed$P[i,2]] <- tau0
+ }
+ for (i in length(fixed$e)) {
+ index(mm)$exfix[i] <- tau0
+ }
+ dots <- list(...)
+ dots$silent <- FALSE
+ if (!is.null(dots$control))
+ control <- dots$control
+ else
+ control <- list()
+ control$start <- coef(fitted)
+ dots$control <- control
+ dots$index <- FALSE
+ dots$fix <- FALSE
+ dots$silent <- TRUE
+ dots$quick <- TRUE
+ dots$data <- model.frame(fitted)
+ dots$x <- mm
+ ee <- do.call("estimate",dots)
+ return(logLik(mm,p=ee,data=dots$data))
+ }
+ val <- sapply(tau,plogl)
+ attributes(val) <- NULL
+ val
+}
+
+profci.lvmfit <- function(x,parm,level=0.95,interval=NULL,curve=FALSE,n=20,lower=TRUE,upper=TRUE,...) {
+ ll <- logLik(x)-qchisq(level,1)/2
+ pp <- function(tau) (profile.lvmfit(x,parm,tau) - ll)
+ tau0 <- coef(x)[parm]
+ tau0.sd <- x$vcov[parm,parm]^0.5
+ if (is.null(interval)) {
+ interval <- tau0 + 3*c(-1,1)*tau0.sd
+ if (parm%in%(variances(x)+index(x)$npar.mean))
+ interval[1] <- max(1e-5,interval[1])
+ }
+ if (curve) {
+ xx <- seq(interval[1],interval[2],length.out=n)
+ val <- sapply(xx,pp)
+ res <- cbind(par=xx,val=val)
+ return(res)
+ }
+ low <- up <- NA
+ if (lower)
+ low <- uniroot(pp,interval=c(interval[1],tau0))$root
+ if (upper)
+ up <- uniroot(pp,interval=c(tau0,interval[2]))$root
+ ## res <- rbind(lower$root,upper$root); rownames(res) <- coef()
+ return(c(low,up))
+}
diff --git a/R/randomslope.R b/R/randomslope.R
new file mode 100644
index 0000000..bfe18fe
--- /dev/null
+++ b/R/randomslope.R
@@ -0,0 +1,80 @@
+##' @export
+"randomslope<-" <- function(x,...,value) UseMethod("randomslope<-")
+
+##' @export
+"randomslope<-.lvm" <- function(x, ..., value) {
+ randomslope(x, covar=value, ...)
+}
+
+##' @export
+`randomslope` <-
+function(x,...) UseMethod("randomslope")
+
+##' @export
+`randomslope.lvm` <-
+function(x,covar,random=NULL,response=NULL,param,postfix,clear=FALSE,zero=TRUE,...) {
+ if (missing(covar)) {
+ rsidx <- unlist(x$attributes$randomslope)
+ if (length(rsidx)>0)
+ return(names(rsidx)[rsidx])
+ else
+ return(NULL)
+ }
+ if (inherits(covar,"formula")) {
+ covar <- all.vars(covar)
+ }
+ if (clear) {
+ ## x <- addattr(x,attr="shape",var=var,val="rectangle")
+ x$attributes$randomslope[covar] <- FALSE
+ } else {
+ if (!is.null(random) & !is.null(response)) {
+ if (inherits(random,"formula")) {
+ random <- all.vars(random)
+ }
+ if (inherits(response,"formula")) {
+ response <- all.vars(response)
+ }
+ if (length(covar)!=length(response)) stop("Vectors should be of the same length!")
+ if (!(random%in%latent(x))) {
+ addvar(x) <- random
+ latent(x) <- random
+ }
+ if (missing(param) || !is.null(param)) {
+ if (!missing(postfix))
+ newlatent <- paste0(random,postfix)
+ else
+ newlatent <- paste(random,covar,sep=".")
+ covariance(x,random) <- 1
+ for (i in seq_along(covar)) {
+ if (missing(param)) {
+ x <- regression(x,to=newlatent[i],from=random)
+ } else {
+ if (inherits(param,"formula")) {
+ param <- all.vars(param)
+ }
+ if (length(param)!=length(newlatent))
+ param <- rep(param,length(newlatent))
+ regfix(x,to=newlatent[i], from=random) <- param[i]
+ }
+ regfix(x,to=response[i],from=newlatent[i]) <- covar[i]
+ latent(x) <- newlatent[i]
+ covariance(x,newlatent[i]) <- 0
+ }
+ } else {
+ for (i in seq_along(covar)) {
+ regfix(x,to=response[i],from=random) <- covar[i]
+ }
+ }
+ } else {
+ x$attributes$randomslope[covar] <- TRUE
+ }
+ }
+ index(x) <- reindex(x)
+ return(x)
+}
+
+##' @export
+`randomslope.lvmfit` <-
+ function(x,...) {
+ randomslope(Model(x),...)
+ }
diff --git a/R/regression.R b/R/regression.R
new file mode 100644
index 0000000..5504d45
--- /dev/null
+++ b/R/regression.R
@@ -0,0 +1,268 @@
+
+##' Add regression association to latent variable model
+##'
+##' Define regression association between variables in a \code{lvm}-object and
+##' define linear constraints between model equations.
+##'
+##'
+##' The \code{regression} function is used to specify linear associations
+##' between variables of a latent variable model, and offers formula syntax
+##' resembling the model specification of e.g. \code{lm}.
+##'
+##' For instance, to add the following linear regression model, to the
+##' \code{lvm}-object, \code{m}:
+##' \deqn{ E(Y|X_1,X_2) = \beta_1 X_1 + \beta_2 X_2}
+##' We can write
+##'
+##' \code{regression(m) <- y ~ x1 + x2}
+##'
+##' Multivariate models can be specified by successive calls with
+##' \code{regression}, but multivariate formulas are also supported, e.g.
+##'
+##' \code{regression(m) <- c(y1,y2) ~ x1 + x2}
+##'
+##' defines
+##' \deqn{ E(Y_i|X_1,X_2) = \beta_{1i} X_1 + \beta_{2i} X_2 }
+##'
+##' The special function, \code{f}, can be used in the model specification to
+##' specify linear constraints. E.g. to fix \eqn{\beta_1=\beta_2}
+##' , we could write
+##'
+##' \code{regression(m) <- y ~ f(x1,beta) + f(x2,beta)}
+##'
+##' The second argument of \code{f} can also be a number (e.g. defining an
+##' offset) or be set to \code{NA} in order to clear any previously defined
+##' linear constraints.
+##'
+##' Alternatively, a more straight forward notation can be used:
+##'
+##' \code{regression(m) <- y ~ beta*x1 + beta*x2}
+##'
+##' All the parameter values of the linear constraints can be given as the right
+##' handside expression of the assigment function \code{regression<-} (or
+##' \code{regfix<-}) if the first (and possibly second) argument is defined as
+##' well. E.g:
+##'
+##' \code{regression(m,y1~x1+x2) <- list("a1","b1")}
+##'
+##' defines \eqn{E(Y_1|X_1,X_2) = a1 X_1 + b1 X_2}. The rhs argument can be a
+##' mixture of character and numeric values (and NA's to remove constraints).
+##'
+##' The function \code{regression} (called without additional arguments) can be
+##' used to inspect the linear constraints of a \code{lvm}-object.
+##'
+##' For backward compatibility the "$"-symbol can be used to fix parameters at
+##' a given value. E.g. to add a linear relationship between \code{y} and
+##' \code{x} with slope 2 to the model \code{m}, we can write
+##' \code{regression(m,"y") <- "x$2"}. Similarily we can use the "@@"-symbol to
+##' name parameters. E.g. in a multiple regression we can force the parameters
+##' to be equal: \code{regression(m,"y") <- c("x1@@b","x2@@b")}. Fixed parameters
+##' can be reset by fixing (with \$) them to \code{NA}.
+##'
+##' @aliases regression regression<- regression<-.lvm regression.lvm regfix
+##' regfix regfix<- regfix.lvm regfix<-.lvm
+##' @param object \code{lvm}-object.
+##' @param value A formula specifying the linear constraints or if
+##' \code{to=NULL} a \code{list} of parameter values.
+##' @param to Character vector of outcome(s) or formula object.
+##' @param from Character vector of predictor(s).
+##' @param fn Real function defining the functional form of predictors (for
+##' simulation only).
+##' @param silent Logical variable which indicates whether messages are turned
+##' on/off.
+##' @param additive If FALSE and predictor is categorical a non-additive effect is assumed
+##' @param y Alias for 'to'
+##' @param x Alias for 'from'
+##' @param quick Faster implementation without parameter constraints
+##' @param \dots Additional arguments to be passed to the low level functions
+##' @usage
+##' \method{regression}{lvm}(object = lvm(), to, from, fn = NA,
+##' silent = lava.options()$silent, additive=TRUE, y, x, value, ...)
+##' \method{regression}{lvm}(object, to=NULL, quick=FALSE, ...) <- value
+##' @return A \code{lvm}-object
+##' @note Variables will be added to the model if not already present.
+##' @author Klaus K. Holst
+##' @seealso \code{\link{intercept<-}}, \code{\link{covariance<-}},
+##' \code{\link{constrain<-}}, \code{\link{parameter<-}},
+##' \code{\link{latent<-}}, \code{\link{cancel<-}}, \code{\link{kill<-}}
+##' @keywords models regression
+##' @examples
+##'
+##' m <- lvm() ## Initialize empty lvm-object
+##' ### E(y1|z,v) = beta1*z + beta2*v
+##' regression(m) <- y1 ~ z + v
+##' ### E(y2|x,z,v) = beta*x + beta*z + 2*v + beta3*u
+##' regression(m) <- y2 ~ f(x,beta) + f(z,beta) + f(v,2) + u
+##' ### Clear restriction on association between y and
+##' ### fix slope coefficient of u to beta
+##' regression(m, y2 ~ v+u) <- list(NA,"beta")
+##'
+##' regression(m) ## Examine current linear parameter constraints
+##'
+##' ## ## A multivariate model, E(yi|x1,x2) = beta[1i]*x1 + beta[2i]*x2:
+##' m2 <- lvm(c(y1,y2) ~ x1+x2)
+##'
+##' @export
+"regression<-" <- function(object,...,value) UseMethod("regression<-")
+
+##' @export
+regression.formula <- function(object,...) regression(lvm(),object,...)
+
+##' @export
+"regression<-.lvm" <- function(object, to=NULL, quick=FALSE, ..., value) {
+ dots <- list(...)
+ if (length(dots$additive)>0 && !dots$additive && !inherits(value,"formula")) {
+ regression(object,beta=value,...) <- to
+ return(object)
+ }
+ if (!is.null(to) || !is.null(dots$y)) {
+ regfix(object, to=to, ...) <- value
+ return(object)
+ } else {
+ if (is.list(value)) {
+ for (v in value) {
+ regression(object,...) <- v
+ }
+ return(object)
+ }
+
+ if (inherits(value,"formula")) {
+ fff <- procformula(object,value,...)
+ object <- fff$object
+ lhs <- fff$lhs
+ xs <- fff$xs
+ ys <- fff$ys
+ res <- fff$res
+ X <- fff$X
+
+
+ if (fff$iscovar) {
+ ## return(covariance(object,var1=decomp.specials(lhs[[1]]),var2=X))
+ covariance(object) <- toformula(decomp.specials(lhs[[1]]),X)
+ return(object)
+ }
+ if (!is.null(lhs) && nchar(lhs[[1]])>2 && substr(lhs[[1]],1,2)=="v(") {
+ v <- update(value,paste(decomp.specials(lhs),"~."))
+ covariance(object,...) <- v
+ return(object)
+ }
+
+ if (length(lhs)==0) {
+ index(object) <- reindex(object)
+ return(object)
+ }
+
+ for (i in seq_len(length(ys))) {
+ y <- ys[i]
+ for (j in seq_len(length(xs))) {
+ if (length(res[[j]])>1) {
+ regfix(object, to=y[1], from=xs[j],...) <- res[[j]][2]
+ } else {
+ object <- regression(object,to=y[1],from=xs[j],...)
+ }
+ }
+ }
+ object$parpos <- NULL
+ return(object)
+ }
+
+ if (!is.list(value) | length(value)>2) stop("Value should contain names of outcome (to) and predictors (from)")
+ if (all(c("to","from")%in%names(value))) {
+
+ xval <- value$x; yval <- value$y
+ } else {
+ yval <- value[[1]]; xval <- value[[2]]
+ }
+ regression(object, to=yval, from=xval,...)
+ }
+}
+
+##' @export
+`regression` <-
+ function(object,to,from,...) UseMethod("regression")
+
+##' @export
+`regression.lvm` <-
+ function(object=lvm(),to,from,fn=NA,silent=lava.options()$silent,
+ additive=TRUE, y,x,value,...) {
+ if (!missing(y)) {
+ if (inherits(y,"formula")) y <- all.vars(y)
+ to <- y
+ }
+ if (!missing(x)) {
+ if (inherits(x,"formula")) x <- all.vars(x)
+ from <- x
+ }
+ if (!additive) {
+ if (!inherits(to,"formula")) to <- toformula(to,from)
+ x <- attributes(getoutcome(to))$x
+ K <- object$attributes$nordinal[x]
+ if (is.null(K) || is.na(K)) {
+ K <- list(...)$K
+ if (is.null(K)) stop("Supply number of categories, K (or use method 'categorical' before calling 'regression').")
+ object <- categorical(object,x,...)
+ }
+ dots <- list(...);
+ dots$K <- K
+ dots$x <- object
+ dots$formula <- to
+ dots$regr.only <- TRUE
+ object <- do.call("categorical",dots)
+ return(object)
+ }
+
+ if (missing(to)) {
+ return(regfix(object))
+ }
+ if (inherits(to,"formula")) {
+ if (!missing(value)) {
+ regression(object,to,silent=silent,...) <- value
+ } else {
+ regression(object,silent=silent,...) <- to
+ }
+ object$parpos <- NULL
+ return(object)
+ }
+ if (is.list(to)) {
+ for (t in to)
+ regression(object,silent=silent,...) <- t
+ object$parpos <- NULL
+ return(object)
+ }
+
+ sx <- strsplit(from,"@")
+ xx <- sapply(sx, FUN=function(i) i[1])
+ ps <- sapply(sx, FUN=function(i) i[2])
+ sx <- strsplit(xx,"$",fixed=TRUE)
+ xs <- sapply(sx, FUN=function(i) i[1])
+ fix <- char2num(sapply(sx, FUN=function(i) i[2]))
+ allv <- index(object)$vars
+
+ object <- addvar(object, c(to,xs), silent=silent,reindex=FALSE)
+
+ for (i in to)
+ for (j in xs) {
+ object$M[j,i] <- 1
+ if (!is.na(fn))
+ functional(object,j,i) <- fn
+ }
+
+ if (lava.options()$exogenous) {
+ newexo <- setdiff(xs,c(to,allv))
+ exo <- exogenous(object)
+ if (length(newexo)>0)
+ exo <- unique(c(exo,newexo))
+ exogenous(object) <- setdiff(exo,to)
+ }
+
+ if (lava.options()$debug) {
+ print(object$fix)
+ }
+ object$fix[xs,to] <- fix
+ object$par[xs,to] <- ps
+ object$parpos <- NULL
+
+ index(object) <- reindex(object)
+ return(object)
+ }
+
diff --git a/R/residuals.R b/R/residuals.R
new file mode 100644
index 0000000..0910659
--- /dev/null
+++ b/R/residuals.R
@@ -0,0 +1,42 @@
+Isqrt <- function(X) {
+ eX <- eigen(X);
+ with(eX, vectors %*% diag(1/sqrt(values),nrow=length(values)) %*% t(vectors))
+}
+
+
+##' @export
+residuals.multigroupfit <- function(object,data=model.frame(object),p=coef(object), k, ...) {
+ pp <- modelPar(object,p,...)
+ if (!missing(k)) return(residuals(object$model$lvm[[k]],data=data[[k]],p=pp$p[[k]],...))
+ res <- c()
+ for (i in seq(length(pp$p))) {
+ res <- c(res, list(residuals(object$model$lvm[[i]],data=data[[i]],p=pp$p[[i]],...)))
+ }
+ return(res)
+}
+
+
+##' @export
+residuals.lvmfit <- function(object,data=model.frame(object),p=coef(object),...) {
+ residuals(Model(object), data=data, p=p, ...)
+}
+
+##' @export
+residuals.lvm <- function(object,data=model.frame(object),std=FALSE,p=coef(object),...) {
+ Y <- setdiff(manifest(object), X <- exogenous(object))
+ Pr <- predict(object,p=p,data=data)
+ PrY <- Pr[,Y,drop=FALSE]
+ ## y <- endogenous(object)[match(endogenous(object),manifest(object))]
+ r <- as.matrix(data[,Y,drop=FALSE]-(PrY))
+ res <- r
+
+ if (std) {
+ S <- attributes(Pr)$cond.var;
+ if (length(Y)>1) {
+ res <- r%*%Isqrt(S)
+ } else res <- 1/sqrt(S[1,1])*r
+ }
+ colnames(res) <- colnames(r)
+ res
+}
+
diff --git a/R/revdiag.R b/R/revdiag.R
new file mode 100644
index 0000000..bcb59f4
--- /dev/null
+++ b/R/revdiag.R
@@ -0,0 +1,72 @@
+##' Create/extract 'reverse'-diagonal matrix or off-diagonal elements
+##' @title Create/extract 'reverse'-diagonal matrix or off-diagonal elements
+##' @aliases revdiag revdiag<- offdiag offdiag<-
+##' @usage
+##' revdiag(x,...)
+##' offdiag(x,type=0,...)
+##'
+##' revdiag(x,...) <- value
+##' offdiag(x,type=0,...) <- value
+##' @param x vector
+##' @param value For the assignment function the values to put in the diagonal
+##' @param type 0: upper and lower triangular, 1: upper triangular, 2: lower triangular, 3: upper triangular + diagonal, 4: lower triangular + diagonal
+##' @param \dots additional arguments to lower level functions
+##' @author Klaus K. Holst
+##' @export
+revdiag <- function(x,...) {
+ if (NCOL(x)==1) {
+ res <- matrix(0,length(x),length(x))
+ revdiag(res) <- x
+ return(res)
+ }
+ n <- max(ncol(x),nrow(x))
+ x[cbind(rev(seq(n)),seq(n))]
+ }
+
+##' @export
+"revdiag<-" <- function(x,...,value) {
+ n <- max(ncol(x),nrow(x))
+ x[cbind(rev(seq(n)),seq(n))] <- value
+ x
+}
+
+
+##' @export
+offdiag <- function(x,type=0,...) {
+ ##if (NCOL(x)==1) return(NULL)
+ if (type%in%c(1,3)) {
+ ii <- which(upper.tri(x,diag=(type==3)))
+ } else if (type%in%c(2,4)) {
+ ii <- which(lower.tri(x,diag=(type==4)))
+ } else {
+ ii <- c(which(lower.tri(x,diag=FALSE)),which(upper.tri(x,diag=FALSE)))
+ }
+ res <- x[ii]
+ class(res) <- c("offdiag",class(res))
+ attributes(res) <-
+ c(attributes(res),list(type=type,dimension=dim(x),index=ii,nam=dimnames(x)))
+ return(res)
+ }
+
+##' @export
+"offdiag<-" <- function(x,type=0,...,value) {
+ if (type%in%c(1,3)) {
+ ii <- which(upper.tri(x,diag=(type==3)))
+ } else if (type%in%c(2,4)) {
+ ii <- which(lower.tri(x,diag=(type==4)))
+ } else {
+ ii <- c(which(lower.tri(x,diag=FALSE)),which(upper.tri(x,diag=FALSE)))
+ }
+ x[ii] <- value
+ return(x)
+}
+
+##' @export
+print.offdiag <- function(x,...) {
+ type <- attr(x,"type")
+ nn <- attr(x,"dimension")
+ M <- matrix(NA,nn[1],nn[2])
+ M[attr(x,"index")] <- x
+ dimnames(M) <- attr(x,"nam")
+ print(M,na.print="",...)
+}
diff --git a/R/scheffe.R b/R/scheffe.R
new file mode 100644
index 0000000..85b43f4
--- /dev/null
+++ b/R/scheffe.R
@@ -0,0 +1,33 @@
+##' Function to compute the Scheffe corrected confidence
+##' interval for the regression line
+##'
+##' @title Calculate simultaneous confidence limits by Scheffe's method
+##' @param model Linear model
+##' @param newdata new data frame
+##' @param conf.level confidence level (0.95)
+##' @export
+##' @examples
+##' x <- rnorm(100)
+##' d <- data.frame(y=rnorm(length(x),x),x=x)
+##' l <- lm(y~x,d)
+##' plot(y~x,d)
+##' abline(l)
+##' d0 <- data.frame(x=seq(-5,5,length.out=100))
+##' d1 <- cbind(d0,predict(l,newdata=d0,interval="confidence"))
+##' d2 <- cbind(d0,scheffe(l,d0))
+##' lines(lwr~x,d1,lty=2,col="red")
+##' lines(upr~x,d1,lty=2,col="red")
+##' lines(lwr~x,d2,lty=2,col="blue")
+##' lines(upr~x,d2,lty=2,col="blue")
+scheffe <- function(model,newdata=model.frame(model),conf.level=0.95) {
+ df <- model$df.residual
+ p <- model$rank
+ alpha <- 1-conf.level
+ ## Scheffe value uses 1-tailed F critical value
+ scheffe.crit <- sqrt(p*qf(1-alpha,p,df))
+ ci <- predict(model,newdata,interval="confidence",level=conf.level)
+ delta <- scheffe.crit/qt(1-alpha/2,df)
+ ci[,2] <- ci[,1] -(ci[,1]-ci[,2])*delta
+ ci[,3] <- ci[,1] +(ci[,3]-ci[,1])*delta
+ return(ci)
+}
diff --git a/R/score.R b/R/score.R
new file mode 100644
index 0000000..fdd61de
--- /dev/null
+++ b/R/score.R
@@ -0,0 +1,162 @@
+##' @export
+`score` <-
+function(x,...) UseMethod("score")
+
+###{{{ score.lvm
+
+##' @export
+score.lvm <- function(x, data, p, model="gaussian", S, n, mu=NULL, weights=NULL, data2=NULL, debug=FALSE, reindex=FALSE, mean=TRUE, constrain=TRUE, indiv=TRUE,...) {
+
+ cl <- match.call()
+ lname <- paste0(model,"_score.lvm")
+ if (!exists(lname)) {
+ lname <- paste0(model,"_gradient.lvm")
+ mygrad <- get(lname)
+ scoreFun <- function(...) -mygrad(...)
+ if (is.null(mygrad)) {
+ stop("Missing gradient")
+ }
+ } else {
+ scoreFun <- get(lname)
+ }
+
+ if (missing(data) || is.null(data)) {
+ cl[[1]] <- scoreFun
+ score <- eval.parent(cl)
+ return(rbind(score))
+ }
+
+ if (is.null(index(x)$dA) | reindex)
+ x <- updatelvm(x,zeroones=TRUE,deriv=TRUE)
+
+ xfix <- colnames(data)[(colnames(data)%in%parlabels(x,exo=TRUE))]
+ xconstrain <- intersect(unlist(lapply(constrain(x),function(z) attributes(z)$args)),index(x)$manifest)
+
+ Debug(xfix,debug)
+ if (missing(n)) {
+ n <- nrow(data)
+ }
+
+ if (length(xfix)>0 | length(xconstrain)>0) { ##### Random slopes!
+ x0 <- x
+ if (length(xfix)>0) {
+ Debug("random slopes...",debug)
+ nrow <- length(vars(x))
+ xpos <- lapply(xfix,function(y) which(regfix(x)$labels==y))
+ colpos <- lapply(xpos, function(y) ceiling(y/nrow))
+ rowpos <- lapply(xpos, function(y) (y-1)%%nrow+1)
+ myfix <- list(var=xfix, col=colpos, row=rowpos)
+ for (i in seq_along(myfix$var))
+ for (j in seq_along(myfix$col[[i]])) {
+ regfix(x0, from=vars(x0)[myfix$row[[i]][j]],to=vars(x0)[myfix$col[[i]][j]]) <-
+ data[1,myfix$var[[i]]]
+ }
+ index(x0) <- reindex(x0,zeroones=TRUE,deriv=TRUE)
+ }
+ pp <- modelPar(x0,p)
+ ##p0 <- with(pp, c(meanpar,p,p2))
+ k <- length(index(x0)$manifest)
+
+ myfun <- function(ii) {
+ if (length(xfix)>0)
+ for (i in seq_along(myfix$var)) {
+ index(x0)$A[cbind(myfix$row[[i]],myfix$col[[i]])] <- data[ii,myfix$var[[i]]]
+ }
+ return(scoreFun(x0,data=data[ii,], p=with(pp,c(meanpar,p,p2)),weights=weights[ii,,drop=FALSE],data2=data2[ii,,drop=FALSE],model=model,debug=debug,indiv=indiv,...))
+ }
+ score <- t(sapply(seq_len(nrow(data)),myfun))
+ if (!indiv) {
+ score <- colSums(rbind(score))
+ }
+ if (length(score)<length(p)) score <- c(score,rep(0,length(p)-length(score)))
+ return(score)
+ }
+ cl$constrain <- FALSE
+ cl[[1]] <- scoreFun
+ score <- eval.parent(cl)
+ if (is.null(dim(score))) score <- rbind(score)
+ if (NCOL(score)<length(p)) score <- cbind(rbind(score),rep(0,length(p)-NCOL(score)))
+
+# score <- eval(cl,parent.frame())
+ return(score)
+}
+
+###}}} score.lvm
+
+###{{{ score.lvm.missing
+
+##' @export
+score.lvm.missing <- function(x,
+ p=pars(x), estimator=x$estimator,
+ weights=Weights(x$estimate),
+ indiv=FALSE,
+ list=FALSE,
+ ...) {
+ dots <- list(...)
+ dots$combine <- FALSE
+ S <- do.call("score",c(list(x=x$estimate$model0,p=p, model=estimator, weights=weights, indiv=indiv),dots))
+ if (indiv & !list) {
+ S0 <- matrix(ncol=length(p),nrow=length(x$order))
+ rownames(S0) <- seq_len(nrow(S0))
+ myorder <- x$orderlist
+ if (length(x$allmis)>0)
+ myorder[[x$allmis]] <- NULL
+ for (i in seq_along(S))
+ S0[myorder[[i]],] <- S[[i]]
+ if (length(x$allmis)>0) {
+ S0 <- S0[-x$orderlist[[x$allmis]],]
+ }
+ S0[is.na(S0)] <- 0
+ colnames(S0) <- names(coef(x))
+ return(S0)
+ }
+ return(S)
+}
+
+###}}} score.lvm.missing
+
+###{{{ score.multigroupfit
+
+##' @export
+score.multigroupfit <- function(x,p=pars(x), weights=Weights(x), estimator=x$estimator, ...) {
+ score(x$model0, p=p, weights=weights, model=estimator,...)
+}
+
+###}}} score.multigroupfit
+
+###{{{ score.multigroup
+
+##' @export
+score.multigroup <- function(x,data=x$data,weights=NULL,data2=NULL,p,indiv=combine,combine=FALSE,...) {
+ rm <- procrandomslope(x)
+ pp <- with(rm, modelPar(model,p)$p)
+ parord <- modelPar(rm$model,seq_len(with(rm$model,npar+npar.mean)))$p
+ S <- list()
+ for (i in seq_len(x$ngroup)) {
+ S0 <- rbind(score(x$lvm[[i]],p=pp[[i]],data=data[[i]],weights=weights[[i]],data2=data2[[i]],indiv=indiv,...))
+ S1 <- matrix(ncol=length(p),nrow=nrow(S0))
+ S1[,parord[[i]]] <- S0
+ S <- c(S, list(S1))
+ }
+ if (combine) {
+ S <- Reduce("rbind",S); S[is.na(S)] <- 0
+ if (!indiv) S <- colSums(S)
+ return(S)
+ }
+ if (indiv) return(S)
+ res <- matrix(0,nrow=1,ncol=length(p))
+ for (i in seq_len(x$ngroup))
+ res[,parord[[i]]] <- res[,parord[[i]]] + S[[i]][,parord[[i]]]
+ return(as.vector(res))
+}
+
+###}}} score.multigroup
+
+###{{{ score.lvmfit
+
+##' @export
+score.lvmfit <- function(x, data=model.frame(x), p=pars(x), model=x$estimator, weights=Weights(x), data2=x$data$data2, ...) {
+ score(x$model0,data=data,p=p,model=model,weights=weights,data2=data2,...)
+}
+
+###}}} score.lvmfit
diff --git a/R/score.survreg.R b/R/score.survreg.R
new file mode 100644
index 0000000..5293b0e
--- /dev/null
+++ b/R/score.survreg.R
@@ -0,0 +1,47 @@
+##' @export
+pars.survreg <- function(x,...) {
+ c(coef(x),scale=x$scale)
+}
+
+
+##' @export
+score.survreg <- function(x,p,scale=TRUE,logscale=FALSE,indiv.logLik=FALSE,...) {
+ npar <- NROW(x$var)
+ m <- model.frame(x)
+ X <- model.matrix(terms(x), m)
+ hasscale <- npar>length(x$coefficients)
+ if (!missing(p)) {
+ if (hasscale) sigma <- tail(p,1)
+ p <- p[seq(length(p)-1)]
+ x$linear.predictors <- as.vector(X%*%p)
+ x$coefficients <- p
+ x$scale <- sigma
+ }
+ derivatives <- residuals(x, type = "matrix")
+ w <- model.weights(m)
+ if (is.null(w)) w <- 1
+ dldLP <- w*derivatives[,"dg"] ## Derivative wrt linear-predictor p=Xbeta
+ S <- apply(X,2,function(x) x*dldLP)
+ if (!is.null(x$naive.var)) {
+ V <- x$naive.var
+ } else {
+ V <- x$var
+ }
+ if (hasscale && scale) {
+ ds <- cbind("logsigma"=derivatives[,"ds"])
+ if (!logscale) {
+ ds <- ds/x$scale
+ names(ds) <- "sigma"
+ }
+ S <- cbind(S,ds)
+ }
+ if (hasscale && !scale) {
+ V <- V[-npar,-npar,drop=FALSE]
+ }
+ attributes(S)$logLik <-
+ if (indiv.logLik) derivatives[,"g"]
+ else sum(derivatives[,"g"])
+ attributes(S)$bread <- V
+ return(S)
+}
+
diff --git a/R/sim.default.R b/R/sim.default.R
new file mode 100644
index 0000000..b8c5880
--- /dev/null
+++ b/R/sim.default.R
@@ -0,0 +1,738 @@
+##' Wrapper function for mclapply
+##'
+##' @export
+##' @param x function or 'sim' object
+##' @param R Number of replications or data.frame with parameters
+##' @param f Optional function (i.e., if x is a matrix)
+##' @param colnames Optional column names
+##' @param messages Messages
+##' @param mc.cores Number of cores to use
+##' @param cl (optional) cluster to use for parallelization
+##' @param blocksize Split computations in blocks
+##' @param type type=0 is an alias for messages=1,mc.cores=1,blocksize=R
+##' @param seed (optional) Seed (needed with cl=TRUE)
+##' @param args (optional) list of named arguments passed to (mc)mapply
+##' @param iter If TRUE the iteration number is passed as first argument to (mc)mapply
+##' @param ... Additional arguments to (mc)mapply
+##' @aliases sim.default summary.sim
+##' @examples
+##' m <- lvm(y~x+e)
+##' distribution(m,~y) <- 0
+##' distribution(m,~x) <- uniform.lvm(a=-1.1,b=1.1)
+##' transform(m,e~x) <- function(x) (1*x^4)*rnorm(length(x),sd=1)
+##'
+##' onerun <- function(iter=NULL,...,n=2e3,b0=1,idx=2) {
+##' d <- sim(m,n,p=c("y~x"=b0))
+##' l <- lm(y~x,d)
+##' res <- c(coef(summary(l))[idx,1:2],
+##' confint(l)[idx,],
+##' estimate(l,only.coef=TRUE)[idx,2:4])
+##' names(res) <- c("Estimate","Model.se","Model.lo","Model.hi",
+##' "Sandwich.se","Sandwich.lo","Sandwich.hi")
+##' res
+##' }
+##' val <- sim(onerun,R=10,b0=1,messages=0,mc.cores=1)
+##' val
+##'
+##' val <- sim(val,R=40,b0=1,mc.cores=1) ## append results
+##' summary(val,estimate=c(1,1),confint=c(3,4,6,7),true=c(1,1))
+##'
+##' summary(val,estimate=c(1,1),se=c(2,5),names=c("Model","Sandwich"))
+##' summary(val,estimate=c(1,1),se=c(2,5),true=c(1,1),names=c("Model","Sandwich"),confint=TRUE)
+##'
+##' if (interactive()) {
+##' plot(val,estimate=1,c(2,5),true=1,names=c("Model","Sandwich"),polygon=FALSE)
+##' plot(val,estimate=c(1,1),se=c(2,5),main=NULL,
+##' true=c(1,1),names=c("Model","Sandwich"),
+##' line.lwd=1,density.col=c("gray20","gray60"),
+##' rug=FALSE)
+##' plot(val,estimate=c(1,1),se=c(2,5),true=c(1,1),
+##' names=c("Model","Sandwich"))
+##' }
+##'
+##' f <- function(a=1,b=1) {
+##' rep(a*b,5)
+##' }
+##' R <- Expand(a=1:3,b=1:3)
+##' sim(f,R,type=0)
+##' sim(function(a,b) f(a,b), 3, args=c(a=5,b=5),type=0)
+##' sim(function(iter=1,a=5,b=5) iter*f(a,b), type=0, iter=TRUE, R=5)
+sim.default <- function(x=NULL,R=100,f=NULL,colnames=NULL,
+ messages=lava.options()$messages,
+ mc.cores,blocksize=2L*mc.cores,
+ cl,type=1L,seed=NULL,args=list(),iter=FALSE,...) {
+ stm <- proc.time()
+ oldtm <- rep(0,5)
+ if (missing(mc.cores) || .Platform$OS.type=="windows") {
+ if (.Platform$OS.type=="windows") { ## Disable parallel processing on windows
+ mc.cores <- 1L
+ } else {
+ mc.cores <- getOption("mc.cores",parallel::detectCores())
+ }
+ }
+ if (type==0L) {
+ mc.cores <- 1L
+ if (inherits(R,c("matrix","data.frame")) || length(R)>1) {
+ blocksize <- NROW(R)
+ } else {
+ blocksize <- R
+ }
+ messages <- 0
+ }
+ if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE))
+ runif(1)
+ if (is.null(seed))
+ RNGstate <- get(".Random.seed", envir = .GlobalEnv)
+ else {
+ R.seed <- get(".Random.seed", envir = .GlobalEnv)
+ set.seed(seed)
+ RNGstate <- structure(seed, kind = as.list(RNGkind()))
+ on.exit(assign(".Random.seed", R.seed, envir = .GlobalEnv))
+ }
+ if (mc.cores>1L || !missing(cl)) requireNamespace("parallel",quietly=TRUE)
+ newcl <- FALSE
+ if (!missing(cl) && is.logical(cl)) {
+ if (.Platform$OS.type=="windows" || TRUE) { ## Don't fork processes on windows
+ cl <- NULL
+ mc.cores <- 1
+ } else {
+ if (cl) {
+ cl <- parallel::makeForkCluster(mc.cores)
+ if (!is.null(seed)) parallel::clusterSetRNGStream(cl,seed)
+ newcl <- TRUE
+ }
+ }
+ }
+ olddata <- NULL
+ dots <- list(...)
+ mycall <- match.call(expand.dots=FALSE)
+ if (inherits(x,c("data.frame","matrix"))) olddata <- x
+ if (inherits(x,"sim")) {
+ oldtm <- attr(x,"time")
+ oldcall <- attr(x,"call")
+ x <- attr(x,"f")
+ if (!is.null(f)) x <- f
+ ex <- oldcall[["..."]]
+ for (nn in setdiff(names(ex),names(dots))) {
+ dots[[nn]] <- ex[[nn]]
+ val <- list(ex[[nn]]); names(val) <- nn
+ mycall[["..."]] <- c(mycall[["..."]],list(val))
+ }
+
+ } else {
+ if (!is.null(f)) x <- f
+ if (!is.function(x)) stop("Expected a function or 'sim' object.")
+ }
+ if (is.null(x)) stop("Must give new function argument 'f'.")
+ res <- val <- NULL
+ on.exit({
+ if (messages>0) close(pb)
+ if (newcl) parallel::stopCluster(cl)
+ if (is.null(colnames) && !is.null(val)) {
+ if (is.matrix(val[[1]])) {
+ colnames <- base::colnames(val[[1]])
+ } else {
+ colnames <- names(val[[1]])
+ }
+ }
+ base::colnames(res) <- colnames
+ if (!is.null(olddata)) res <- rbind(olddata,res)
+ attr(res,"call") <- mycall
+ attr(res,"f") <- x
+ class(res) <- c("sim","matrix")
+ if (idx.done<R) {
+ res <- res[seq(idx.done),,drop=FALSE]
+ }
+ attr(res,"time") <- proc.time()-stm+oldtm
+
+ return(res)
+ })
+ parval_provided <- FALSE
+ if (inherits(R,c("matrix","data.frame")) || length(R)>1) {
+ parval_provided <- TRUE
+ parval <- as.data.frame(R)
+ if (is.vector(R)) names(parval) <- NULL
+ else if (inherits(R,c("matrix","data.frame"))) names(parval) <- colnames(R)
+ R <- NROW(parval)
+ } else {
+ parval <- as.data.frame(1:R)
+ names(parval) <- NULL
+ }
+ nfolds <- max(1,round(R/blocksize))
+ idx <- split(1:R,sort((1:R)%%nfolds))
+ idx.done <- 0
+ count <- 0
+ if (messages>0) pb <- txtProgressBar(style=lava.options()$progressbarstyle,width=40)
+ time <- c()
+ robx <- function(iter__,...) tryCatch(x(...),error=function(e) NA)
+ if (iter) formals(robx)[[1]] <- NULL
+ for (ii in idx) {
+ count <- count+1
+ if (!missing(cl) && !is.null(cl)) {
+ pp <- c(as.list(parval[ii,,drop=FALSE]),dots,list(cl=cl,fun=robx,SIMPLIFY=FALSE),args)
+ } else {
+ pp <- c(as.list(parval[ii,,drop=FALSE]),dots,list(mc.cores=mc.cores,FUN=robx,SIMPLIFY=FALSE),args)
+ }
+ ##if (!iter & !parval_provided) pp[[1]] <- NULL
+ if (mc.cores>1) {
+ if (!missing(cl) && !is.null(cl)) {
+ val <- do.call(parallel::clusterMap,pp)
+ } else {
+ val <- do.call(parallel::mcmapply,pp)
+ }
+ } else {
+ pp$mc.cores <- NULL
+ val <- do.call(mapply,pp)
+ }
+ if (messages>0)
+ setTxtProgressBar(pb, count/length(idx))
+ if (is.null(res)) {
+ ##res <- array(NA,dim=c(R,dim(val[[1]])),dimnames=c(list(NULL),dimnames(val[[1]]),NULL))
+ res <- matrix(NA,ncol=length(val[[1]]),nrow=R)
+ }
+ res[ii,] <- Reduce(rbind,val)
+ ##rr <- abind::abind(val,along=length(dim(res)))
+ ##res[ii,] <- abind(val,along=length(dim(res)))
+ idx.done <- max(ii)
+ }
+}
+
+##' @export
+"[.sim" <- function (x, i, j, drop = FALSE) {
+ atr <- attributes(x)
+ if (!is.null(dim(x))) {
+ class(x) <- "matrix"
+ } else {
+ class(x) <- class(x)[-1]
+ }
+ x <- NextMethod("[",drop=drop)
+ atr.keep <- c("call","time")
+ if (missing(j)) atr.keep <- c(atr.keep,"f")
+ attributes(x)[atr.keep] <- atr[atr.keep]
+ if (!drop) class(x) <- c("sim",class(x))
+ x
+}
+
+
+Time <- function(sec,print=FALSE,...) {
+ h <- sec%/%3600
+ m0 <- (sec%%3600)
+ m <- m0%/%60
+ s <- m0%%60
+ res <- c(h=h,m=m,s=s)
+ if (print) {
+ if (h>0) cat(h,"h ",sep="")
+ if (m>0) cat(m,"m ",sep="")
+ cat(s,"s",sep="")
+ return(invisible(res))
+ }
+ return(res)
+}
+
+Print <- function(x,n=5,digits=max(3,getOption("digits")-3),...) {
+ mat <- !is.null(dim(x))
+ if (!mat) {
+ x <- cbind(x)
+ colnames(x) <- ""
+ }
+ if (is.null(rownames(x))) {
+ rownames(x) <- seq(nrow(x))
+ }
+ sep <- rbind("---"=rep('',ncol(x)))
+ if (n<1) {
+ print(x,quote=FALSE,digits=digits,...)
+ } else {
+ ## hd <- base::as.matrix(base::format(utils::head(x,n),digits=digits,...))
+ ## tl <- base::as.matrix(base::format(utils::tail(x,n),digits=digits,...))
+ ## print(rbind(hd,sep,tl),quote=FALSE,...)
+ if (NROW(x)<=(2*n)) {
+ hd <- base::format(utils::head(x,2*n),digits=digits,...)
+ print(hd, quote=FALSE,...)
+ } else {
+ hd <- base::format(utils::head(x,n),digits=digits,...)
+ tl <- base::format(utils::tail(x,n),digits=digits,...)
+ print(rbind(base::as.matrix(hd),sep,base::as.matrix(tl)),
+ quote=FALSE,...)
+ }
+ }
+ invisible(x)
+}
+
+##' @export
+print.sim <- function(x,...) {
+ attr(x,"f") <- attr(x,"call") <- NULL
+ if (!is.null(dim(x))) {
+ class(x) <- "matrix"
+ }
+ Print(x,...)
+ return(invisible(x))
+}
+
+
+##' Plot sim object
+##'
+##' @examples
+##' n <- 1000
+##' val <- cbind(est1=rnorm(n,sd=1),est2=rnorm(n,sd=0.2),est3=rnorm(n,1,sd=0.5),
+##' sd1=runif(n,0.8,1.2),sd2=runif(n,0.1,0.3),sd3=runif(n,0.25,0.75))
+##'
+##' plot.sim(val,estimate=c(1,2),true=c(0,0),se=c(4,5),equal=TRUE)
+##' plot.sim(val,estimate=c(1,3),true=c(0,1),se=c(4,6),density.xlim=c(-3,3),ylim=c(-3,3))
+##' plot.sim(val,estimate=c(1,2),true=c(0,0),se=c(4,5),equal=TRUE,plot.type="single")
+##' plot.sim(val,estimate=c(1),se=c(4,5,6),plot.type="single")
+##' plot.sim(val,estimate=c(1,2,3),equal=TRUE)
+##' plot.sim(val,estimate=c(1,2,3),equal=TRUE,byrow=TRUE)
+##' plot.sim(val,estimate=c(1,2,3),plot.type="single")
+##' plot.sim(val,estimate=1,se=c(3,4,5),plot.type="single")
+##'
+##' density.sim(val,estimate=c(1,2,3),polygon.density=c(0,10,10),polygon.angle=c(0,45,-45))
+##' @param x sim object
+##' @param ... Graphical arguments to plot.sim
+##' @param plot.type Single or multiple plots
+##' @aliases density.sim plot.sim
+##' @export
+##' @export density.sim
+density.sim <- function(x,...,plot.type="single") {
+ plot.sim(x,...,scatter.plot=FALSE,plot.type=plot.type)
+}
+
+##' @export
+##' @export plot.sim
+plot.sim <- function(x,estimate,se=NULL,true=NULL,
+ names=NULL,
+ auto.layout=TRUE,
+ byrow=FALSE,
+ type="p",
+ ask=grDevices::dev.interactive(),
+ line.col=1, line.lwd=1.8,
+ col=c("gray60","orange","darkblue","seagreen","darkred"),
+ pch=16,cex=0.5,lty=1,
+ true.lty=2,true.col="gray70",true.lwd=1.2,
+ legend,
+ legendpos="topleft",
+ cex.legend=0.8,
+ plot.type=c("multiple","single"),
+ polygon=TRUE,
+ polygon.density=0,
+ polygon.angle=-45,
+ cex.axis=0.8,
+ alpha=0.5,
+ rug=TRUE,
+ rug.alpha=0.5,
+ main,
+ cex.main=1,
+ equal=FALSE,
+ delta=1.15,
+ ylim=NULL,
+ ylab="Estimate",
+ density.ylab="Density",
+ density.ylim=NULL,
+ density.xlim=NULL,
+ density.plot=TRUE,
+ scatter.plot=TRUE,
+ running.mean=scatter.plot,
+ density.alpha=0.2,
+ border=density.col,
+ density.lty,
+ density.col=col,
+ density.lwd=0.4,
+ xlab="",...) {
+
+ if (missing(estimate)) {
+ estimate <- seq(ncol(x))
+ }
+ if (is.null(estimate)) {
+ av <- apply(x[,drop=FALSE],2,function(z) cumsum(z)/seq(length(z)))
+ graphics::matplot(x,type="p",pch=pch, cex=cex, col=col,...)
+ graphics::matlines(av,type="l",col=col,lty=lty,...)
+ if (!is.null(true)) abline(h=true,lty=true.lty,...)
+ if (missing(legend)) legend <- colnames(x)
+ if (!is.null(legend))
+ graphics::legend(legendpos,legend=legend,bg="white",col=col,lty=lty,pch=pch,...)
+ return(invisible(NULL))
+ }
+ if (is.character(estimate)) {
+ estimate <- match(estimate,colnames(x))
+ }
+
+ K <- length(estimate)
+ est <- tru <- c()
+ if (length(se)>0) {
+ if (K==1 && !is.list(se))
+ se <- list(se)
+ else se <- as.list(se)
+ } else {
+ est <- estimate; tru <- true
+ }
+ for (i in seq_along(estimate)) {
+ est <- c(est,list(rep(estimate[i],length(se[[i]]))))
+ if (!is.null(true)) tru <- c(tru,list(rep(true[i],length(se[[i]]))))
+ }
+
+ if (length(se)>0) {
+ for (i in seq_along(se)) {
+ if (is.character(se[[i]])) se[[i]] <- match(se[[i]],colnames(x))
+ }
+
+ }
+ ss <- summary.sim(x,estimate=unlist(est),se=unlist(se),true=unlist(tru),names=names)
+
+ oldpar <- NULL
+ on.exit({
+ par(oldpar)
+ return(invisible(ss))
+ })
+
+ single <- tolower(plot.type[1])=="single"
+
+ if (auto.layout) {
+ nc <- (scatter.plot || running.mean) + density.plot
+ nr <- min(6,K)
+ if (single) nr <- 1
+ oma.multi = c(2, 0, 2, 0)
+ mar.multi = c(1.5, 4.1, 1, 1)
+ oldpar <- par(mar=mar.multi, oma=oma.multi,
+ cex.axis=cex.axis,las=1,
+ ask=FALSE)
+ if (byrow) {
+ par(mfrow=c(nr,nc))
+ } else {
+ par(mfcol=c(nc,nr))
+ }
+ }
+
+ dys <- c()
+ maxdy <- 0
+ if (density.plot)
+ for (i in seq(K)) {
+ ii <- estimate[i]
+ y <- as.vector(x[,ii])
+ dy <- stats::density(y)
+ dys <- c(dys,list(dy))
+ maxdy <- max(maxdy,dy$y)
+ }
+
+ if (equal || single) {
+ if (is.null(ylim)) {
+ rg <- range(x[,estimate])
+ rg <- rg+c(-1,1)*abs(diff(rg)*(delta-1))
+ ylim <- rep(list(rg),K)
+ }
+ if (density.plot) {
+ if (is.null(density.ylim)) density.ylim <- rep(list(c(0,maxdy*delta)),K)
+ if (is.null(density.xlim)) density.xlim <- ylim
+ }
+ }
+
+ if (!is.null(ylim)) {
+ if (!is.list(ylim)) ylim <- list(ylim)
+ ylim <- rep(ylim,length.out=K)
+ }
+ ylab <- rep(ylab,length.out=K)
+ if (!is.null(density.ylim)) {
+ if (!is.list(density.ylim)) density.ylim <- list(density.ylim)
+ density.ylim <- rep(density.ylim,length.out=K)
+ }
+ if (!is.null(density.xlim)) {
+ if (!is.list(density.xlim)) density.xlim <- list(density.xlim)
+ density.xlim <- rep(density.xlim,length.out=K)
+ }
+ if (missing(main)) {
+ main <- NULL
+ if (!missing(names)) main <- names
+ else if (K>1 && !single) main <- colnames(ss)
+ }
+ if (!is.null(main)) main <- rep(main,length.out=K)
+ if (missing(density.lty)) {
+ density.lty <- rep(1,K)
+ if (single || !polygon) {
+ density.lty <- 1:20
+ }
+ }
+
+ my.scatter.sim <- function(i,add=FALSE,colors,...) {
+ ii <- estimate[i]
+ if (!missing(colors)) {
+ col <- line.col <- true.col <- colors[1]
+ }
+ y <- as.vector(x[,ii])
+ args <- list(y,ylab=ylab[i],col=Col(col[1],alpha),cex=cex,pch=pch,type=type)
+ if (!is.null(ylim)) args <- c(args,list(ylim=ylim[[i]]))
+ if (scatter.plot) {
+ if (!add) {
+ do.call(graphics::plot,args)
+ } else {
+ do.call(graphics::points,args)
+ }
+ }
+ if (running.mean) {
+ lines(cumsum(y)/seq_along(y),col=line.col[1],lwd=line.lwd,lty=lty)
+ if (!is.null(true))
+ abline(h=true[i],lty=true.lty,col=true.col[1],lwd=true.lwd)
+ }
+ }
+
+ my.density.sim <- function(i,add=FALSE,colors,
+ alphas=density.alpha,
+ auto.legend=TRUE,
+ densities=NULL,
+ angles=polygon.angle,
+ ...) {
+ ii <- estimate[i]
+ y <- as.vector(x[,ii])
+ if (!missing(colors)) {
+ density.col <- border <- colors
+ col <- true.col <- colors
+ }
+ if (density.plot) {
+ dy <- stats::density(y)
+ if (is.null(density.ylim)) {
+ density.ylim0 <- c(0,max(dy$y)*delta)
+ } else {
+ density.ylim0 <- density.ylim[[i]]
+ }
+ if (is.null(density.xlim)) {
+ density.xlim0 <- range(dy$x)
+ } else {
+ density.xlim0 <- density.xlim[[i]]
+ }
+ if (!add) graphics::plot(0,0,type="n",main="",ylab=density.ylab,xlab=xlab,ylim=density.ylim0,xlim=density.xlim0)
+ if (polygon) {
+ with(dy, graphics::polygon(c(x,rev(x)),c(y,rep(0,length(y))),col=Col(density.col[1],alpha=alphas[1]),border=NA,density=densities[1],angle=angles[1]))
+ if (!is.null(border)) with(dy, lines(x,y,col=border[1],lty=density.lty[1],lwd=density.lwd[1]))
+ } else {
+ graphics::lines(dy,main="",lty=density.lty[1],col=density.col[1],lwd=density.lwd[1])
+ }
+ if (rug) graphics::rug(y,col=Col(col[1],rug.alpha[1]))
+ if (!is.null(main) && !(running.mean || scatter.plot)) {
+ title(main[i],cex.main=cex.main)
+ }
+ if (!is.null(true)) {
+ abline(v=true[i],lty=true.lty,col=true.col,lwd=true.lwd)
+ }
+ if (!is.null(se)) {
+ se.pos <- match(se[[i]],unlist(se))
+ ns <- length(se.pos)+1
+ se.alpha <- rep(alphas,length.out=ns)[-1]
+ se.border <- rep(border,length.out=ns)[-1]
+ se.col <- rep(density.col,length.out=ns)[-1]
+ se.lty <- rep(density.lty,length.out=ns)[-1]
+ se.lwd <- rep(density.lwd,length.out=ns)[-1]
+ xx <- dy$x
+ for (j in seq_along(se.pos)) {
+ if (polygon) {
+ yy <- dnorm(xx,mean=ss["Mean",se.pos[j]],sd=ss["SE",se.pos[j]])
+ if (se.alpha[j]>0) graphics::polygon(c(xx,rev(xx)),c(yy,rep(0,length(yy))),col=Col(se.col[j],alpha=se.alpha[j]),border=NA,density=densities[j],angle=angles[j])
+ if (!is.null(border)) lines(xx,yy,col=se.border[j],lty=se.lty[j],lwd=se.lwd[j])
+ } else {
+ graphics::curve(dnorm(x,mean=ss["Mean",se.pos[j]],sd=ss["SE",se.pos[j]]),lwd=se.lwd[j],lty=se.lty[j],col=se.col[j],add=TRUE)
+ }
+ }
+ if (auto.legend) legend <- c("Kernel",colnames(ss)[se.pos])
+ if (!is.null(legend)) {
+ if (polygon) {
+ dcol <- c(density.col[1],se.col)
+ graphics::legend(legendpos,legend,
+ fill=Col(dcol,density.alpha),border=dcol,cex=cex.legend)
+ } else {
+ graphics::legend(legendpos,legend,
+ col=c(density.col[1],se.col),
+ lty=c(density.lty[1],se.lty),
+ lwd=c(density.lwd[1],se.lwd),cex=cex.legend)
+ }
+ }
+ }
+
+ }
+ }
+
+ if (single) {
+ N <- K
+ nk <- unlist(lapply(se,length))
+ if (!is.null(se)) N <- sum(unlist(nk))+K
+ col <- rep(col,length.out=K)
+ for (i in seq(K)) {
+ my.scatter.sim(i,add=(i>1),colors=col[i])
+ }
+ if (!is.null(main) && !byrow) {
+ title(main[1],cex.main=cex.main)
+ }
+ if (missing(legend)) legend <- colnames(x)[estimate]
+ legendold <- legend
+ legend <- NULL
+ density.alpha <- rep(density.alpha,length.out=K)
+ polygon.density <- rep(polygon.density,length.out=K)
+ polygon.angle <- rep(polygon.angle,length.out=K)
+ for (i in seq_len(K)) {
+ alphas <- density.alpha[i]
+ densities <- polygon.density[i]
+ if (!is.null(densities) && densities<1) densities <- NULL
+ if (length(se)>0) alphas <- c(alphas,rep(0,nk[i]))
+ my.density.sim(i,add=(i>1),colors=col[i],alphas=alphas,
+ densities=densities,
+ angles=polygon.angle[i],
+ auto.legend=FALSE)
+ }
+ if (!is.null(legendold)) {
+ legend <- rep(legendold,length.out=K)
+ graphics::legend(legendpos,legend,
+ fill=Col(col,density.alpha),border=col,cex=cex.legend)
+ }
+
+ } else {
+ for (i in seq(K)) {
+ my.scatter.sim(i)
+ if (!is.null(main) && !byrow && scatter.plot) {
+ title(main[i],cex.main=cex.main)
+ }
+ my.density.sim(i,auto.legend=missing(legend))
+ if (i==1 && ask) par(ask=ask)
+ }
+ }
+
+}
+
+##' @export
+print.summary.sim <- function(x,group=list(c("^mean$","^sd$","^se$","^se/sd$"),
+ c("^min$","^[0-9.]+%$","^max$"),
+ c("^na$","^missing$"),
+ c("^true$","^bias$","^rmse$")),
+ lower.case=TRUE,
+ na.print="",
+ digits = max(3, getOption("digits") - 2),
+ quote=FALSE,
+ time=TRUE,
+ ...) {
+ cat(attr(x,"n")," replications",sep="")
+ if (time && !is.null(attr(x,"time"))) {
+ cat("\t\t\t\t\tTime: ")
+ Time(attr(x,"time")["elapsed"],print=TRUE)
+ }
+ cat("\n\n")
+
+ nn <- rownames(x)
+ if (lower.case) nn <- tolower(nn)
+ gg <- lapply(group,
+ function(x) unlist(lapply(x,function(v) grep(v,nn))))
+ gg <- c(gg,list(setdiff(seq_along(nn),unlist(gg))))
+
+ x0 <- c()
+ ng <- length(gg)
+ for (i in seq(ng)) {
+ x0 <- rbind(x0, x[gg[[i]],,drop=FALSE],
+ { if(i<ng && length(gg[[i+1]])>0) NA})
+ }
+
+ print(structure(x0,class="matrix")[,,drop=FALSE],digits=digits,quote=quote,na.print=na.print,...)
+ cat("\n")
+ invisible(x)
+}
+
+
+##' @export
+##' @export summary.sim
+summary.sim <- function(object,estimate=NULL,se=NULL,
+ confint=NULL,true=NULL,
+ fun,names=NULL,unique.names=TRUE,
+ level=0.95,quantiles=c(.025,0.5,.975),...) {
+ mfun <- function(x,...) {
+ res <- c(mean(x,na.rm=TRUE),
+ sd(x,na.rm=TRUE),
+ quantile(x,c(0,quantiles,1),na.rm=TRUE),
+ mean(is.na(x)))
+ names(res) <- c("Mean","SD","Min",paste0(quantiles*100,"%"),"Max","Missing")
+ res
+ }
+ tm <- attr(object,"time")
+ if (!is.null(estimate) && is.character(estimate)) {
+ estimate <- match(estimate,colnames(object))
+ }
+ if (!missing(fun)) {
+ if (!is.null(estimate)) object <- object[,estimate,drop=FALSE]
+ res <- lapply(seq(ncol(object)),
+ function(i,...) fun(object[,i,drop=TRUE],i,...),...)
+ res <- matrix(unlist(res),nrow=length(res[[1]]),byrow=FALSE)
+ if (is.null(dim(res))) {
+ res <- rbind(res)
+ }
+ if (is.null(rownames(res))) {
+ rownames(res) <- names(fun(0,1,...))
+ }
+ if (is.null(colnames(res))) {
+ colnames(res) <- colnames(object)
+ }
+ return(structure(res,
+ n=NROW(object),
+ time=tm,
+ class=c("summary.sim","matrix")))
+ }
+
+ if (!is.null(estimate)) {
+ est <- apply(object[,estimate,drop=FALSE],2,mfun)
+ } else {
+ est <- apply(object,2,mfun)
+ }
+
+ if (!is.null(true)) {
+ if (length(true)!=length(estimate)) {
+ ##stop("'true' should be of same length as 'estimate'.")
+ true <- rep(true,length.out=length(estimate))
+ }
+ est <- rbind(est,
+ rbind(True=true),rbind(Bias=est["Mean",]-true),
+ rbind(RMSE=((est["Mean",]-true)^2+(est["SD",])^2)^.5)
+ )
+ }
+ if (!is.null(se)) {
+ if (is.character(se)) {
+ se <- match(se,colnames(object))
+ }
+ if (length(se)!=length(estimate)) stop("'se' should be of same length as 'estimate'.")
+ est <- rbind(est, SE=apply(object[,se,drop=FALSE],2,
+ function(x) c(mean(x,na.rm=TRUE))))
+ est <- rbind(est,"SE/SD"=est["SE",]/est["SD",])
+
+ }
+ if (!is.null(confint)) {
+ if (is.character(confint)) {
+ confint <- match(confint,colnames(object))
+ }
+ if (length(confint)==1 && confint) {
+ if (is.null(se)) stop("Supply confidence limits or SE")
+ confint <- c()
+ pos <- ncol(object)
+ for (i in seq_along(estimate)) {
+ z <- 1-(1-level)/2
+ CI <- cbind(object[,estimate[i]]-qnorm(z)*object[,se[i]],
+ object[,estimate[i]]+qnorm(z)*object[,se[i]])
+ colnames(CI) <- NULL
+ object <- cbind(object,CI)
+ confint <- c(confint,pos+1:2)
+ pos <- pos+2
+ }
+ }
+ if (length(confint)!=2*length(estimate)) stop("'confint' should be of length 2*length(estimate).")
+ Coverage <- c()
+ for (i in seq_along(estimate)) {
+ Coverage <- c(Coverage,
+ mean((object[,confint[2*(i-1)+1]]<true[i]) & (object[,confint[2*i]]>true[i]),na.rm=TRUE))
+ }
+ est <- rbind(est,Coverage=Coverage)
+ }
+ if (!is.null(names)) {
+ if (length(names)<ncol(est)) {
+ uest <- unique(estimate)
+ names <- names[match(estimate,uest)]
+ }
+ colnames(est) <- names
+
+ }
+ if (unique.names && !is.null(colnames(est))) {
+ colnames(est) <- make.unique(colnames(est))
+ }
+
+ return(structure(est,
+ n=NROW(object),
+ time=tm,
+ class=c("summary.sim","matrix")))
+}
diff --git a/R/sim.lvm.R b/R/sim.lvm.R
new file mode 100644
index 0000000..1351065
--- /dev/null
+++ b/R/sim.lvm.R
@@ -0,0 +1,756 @@
+##' Simulate model
+##'
+##' Simulate data from a general SEM model including non-linear effects and
+##' general link and distribution of variables.
+##'
+##' @aliases sim sim.lvmfit sim.lvm
+##' simulate.lvmfit simulate.lvm
+##' transform<- transform<-.lvm transform.lvm
+##' functional functional<- functional.lvm functional<-.lvm
+##' distribution distribution distribution<- distribution.lvm distribution<-.lvm
+##' heavytail heavytail<-
+##' weibull.lvm
+##' binomial.lvm
+##' poisson.lvm
+##' uniform.lvm
+##' beta.lvm
+##' normal.lvm
+##' lognormal.lvm
+##' gaussian.lvm
+##' GM2.lvm
+##' GM3.lvm
+##' probit.lvm
+##' logit.lvm
+##' pareto.lvm
+##' student.lvm
+##' chisq.lvm
+##' coxGompertz.lvm
+##' coxWeibull.lvm
+##' coxExponential.lvm
+##' aalenExponential.lvm
+##' Gamma.lvm gamma.lvm
+##' loggamma.lvm
+##' categorical categorical<-
+##' threshold.lvm
+##' ones.lvm
+##' sequence.lvm
+##' @usage
+##' \method{sim}{lvm}(x, n = NULL, p = NULL, normal = FALSE, cond = FALSE,
+##' sigma = 1, rho = 0.5, X = NULL, unlink=FALSE, latent=TRUE,
+##' use.labels = TRUE, seed=NULL, ...)
+##' @param x Model object
+##' @param n Number of simulated values/individuals
+##' @param p Parameter value (optional)
+##' @param normal Logical indicating whether to simulate data from a
+##' multivariate normal distribution conditional on exogenous variables hence
+##' ignoring functional/distribution definition
+##' @param cond for internal use
+##' @param sigma Default residual variance (1)
+##' @param rho Default covariance parameter (0.5)
+##' @param X Optional matrix of covariates
+##' @param unlink Return Inverse link transformed data
+##' @param latent Include latent variables (default TRUE)
+##' @param use.labels convert categorical variables to factors before applying transformation
+##' @param seed Random seed
+##' @param \dots Additional arguments to be passed to the low level functions
+##' @author Klaus K. Holst
+##' @keywords models datagen regression
+##' @export
+##' @examples
+##' ##################################################
+##' ## Logistic regression
+##' ##################################################
+##' m <- lvm(y~x+z)
+##' regression(m) <- x~z
+##' distribution(m,~y+z) <- binomial.lvm("logit")
+##' d <- sim(m,1e3)
+##' head(d)
+
+##' e <- estimate(m,d,estimator="glm")
+##' e
+##' ## Simulate a few observation from estimated model
+##' sim(e,n=5)
+
+##' ##################################################
+##' ## Poisson
+##' ##################################################
+##' distribution(m,~y) <- poisson.lvm()
+##' d <- sim(m,1e4,p=c(y=-1,"y~x"=2,z=1))
+##' head(d)
+##' estimate(m,d,estimator="glm")
+##' mean(d$z); lava:::expit(1)
+
+##' summary(lm(y~x,sim(lvm(y[1:2]~4*x),1e3)))
+
+##' ##################################################
+##' ### Gamma distribution
+##' ##################################################
+##' m <- lvm(y~x)
+##' distribution(m,~y+x) <- list(Gamma.lvm(shape=2),binomial.lvm())
+##' intercept(m,~y) <- 0.5
+##' d <- sim(m,1e4)
+##' summary(g <- glm(y~x,family=Gamma(),data=d))
+##' \dontrun{MASS::gamma.shape(g)}
+
+##' args(lava::Gamma.lvm)
+##' distribution(m,~y) <- Gamma.lvm(shape=2,log=TRUE)
+##' sim(m,10,p=c(y=0.5))[,"y"]
+
+##' ##################################################
+##' ### Beta
+##' ##################################################
+##' m <- lvm()
+##' distribution(m,~y) <- beta.lvm(alpha=2,beta=1)
+##' var(sim(m,100,"y,y"=2))
+##' distribution(m,~y) <- beta.lvm(alpha=2,beta=1,scale=FALSE)
+##' var(sim(m,100))
+
+##' ##################################################
+##' ### Transform
+##' ##################################################
+##' m <- lvm()
+##' transform(m,xz~x+z) <- function(x) x[1]*(x[2]>0)
+##' regression(m) <- y~x+z+xz
+##' d <- sim(m,1e3)
+##' summary(lm(y~x+z + x*I(z>0),d))
+
+##' ##################################################
+##' ### Non-random variables
+##' ##################################################
+##' m <- lvm()
+##' distribution(m,~x+z+v+w) <- list(sequence.lvm(0,5),## Seq. 0 to 5 by 1/n
+##' ones.lvm(), ## Vector of ones
+##' ones.lvm(0.5), ## 0.8n 0, 0.2n 1
+##' ones.lvm(interval=list(c(0.3,0.5),c(0.8,1))))
+##' sim(m,10)
+
+##' ##################################################
+##' ### Cox model
+##' ### piecewise constant hazard
+##' ################################################
+##' m <- lvm(t~x)
+##' rates <- c(1,0.5); cuts <- c(0,5)
+##' ## Constant rate: 1 in [0,5), 0.5 in [5,Inf)
+##' distribution(m,~t) <- coxExponential.lvm(rate=rates,timecut=cuts)
+
+##' \dontrun{
+##' d <- sim(m,2e4,p=c("t~x"=0.1)); d$status <- TRUE
+##' plot(timereg::aalen(survival::Surv(t,status)~x,data=d,
+##' resample.iid=0,robust=0),spec=1)
+##' L <- approxfun(c(cuts,max(d$t)),f=1,
+##' cumsum(c(0,rates*diff(c(cuts,max(d$t))))),
+##' method="linear")
+##' curve(L,0,100,add=TRUE,col="blue")
+##' }
+
+##' ##################################################
+##' ### Cox model
+##' ### piecewise constant hazard, gamma frailty
+##' ##################################################
+##' m <- lvm(y~x+z)
+##' rates <- c(0.3,0.5); cuts <- c(0,5)
+##' distribution(m,~y+z) <- list(coxExponential.lvm(rate=rates,timecut=cuts),
+##' loggamma.lvm(rate=1,shape=1))
+##' \dontrun{
+##' d <- sim(m,2e4,p=c("y~x"=0,"y~z"=0)); d$status <- TRUE
+##' plot(timereg::aalen(survival::Surv(y,status)~x,data=d,
+##' resample.iid=0,robust=0),spec=1)
+##' L <- approxfun(c(cuts,max(d$y)),f=1,
+##' cumsum(c(0,rates*diff(c(cuts,max(d$y))))),
+##' method="linear")
+##' curve(L,0,100,add=TRUE,col="blue")
+##' }
+##' ## Equivalent via transform (here with Aalens additive hazard model)
+##' m <- lvm(y~x)
+##' distribution(m,~y) <- aalenExponential.lvm(rate=rates,timecut=cuts)
+##' distribution(m,~z) <- Gamma.lvm(rate=1,shape=1)
+##' transform(m,t~y+z) <- prod
+##' sim(m,10)
+##' ## Shared frailty
+##' m <- lvm(c(t1,t2)~x+z)
+##' rates <- c(1,0.5); cuts <- c(0,5)
+##' distribution(m,~y) <- aalenExponential.lvm(rate=rates,timecut=cuts)
+##' distribution(m,~z) <- loggamma.lvm(rate=1,shape=1)
+##' \dontrun{
+##' mets::fast.reshape(sim(m,100),varying="t")
+##' }
+
+##' ##################################################
+##' ### General multivariate distributions
+##' ##################################################
+##' \dontrun{
+##' m <- lvm()
+##' distribution(m,~y1+y2,oratio=4) <- VGAM::rbiplackcop
+##' ksmooth2(sim(m,1e4),rgl=FALSE,theta=-20,phi=25)
+
+##' m <- lvm()
+##' distribution(m,~z1+z2,"or1") <- VGAM::rbiplackcop
+##' distribution(m,~y1+y2,"or2") <- VGAM::rbiplackcop
+##' sim(m,10,p=c(or1=0.1,or2=4))
+##' }
+
+##' m <- lvm()
+##' distribution(m,~y1+y2+y3,TRUE) <- function(n,...) rmvn(n,sigma=diag(3)+1)
+##' var(sim(m,100))
+
+##' ## Syntax also useful for univariate generators, e.g.
+##' m <- lvm(y~x+z)
+##' distribution(m,~y,TRUE) <- function(n) rnorm(n,mean=1000)
+##' sim(m,5)
+##' distribution(m,~y,"m1",0) <- rnorm
+##' sim(m,5)
+##' sim(m,5,p=c(m1=100))
+
+##' ##################################################
+##' ### Regression design in other parameters
+##' ##################################################
+##' ## Variance heterogeneity
+##' m <- lvm(y~x)
+##' distribution(m,~y) <- function(n,mean,x) rnorm(n,mean,exp(x)^.5)
+##' if (interactive()) plot(y~x,sim(m,1e3))
+##' ## Alternaively, calculate the standard error directly
+##' addvar(m) <- ~sd ## If 'sd' should be part of the resulting data.frame
+##' constrain(m,sd~x) <- function(x) exp(x)^.5
+##' distribution(m,~y) <- function(n,mean,sd) rnorm(n,mean,sd)
+##' if (interactive()) plot(y~x,sim(m,1e3))
+
+##' ## Regression on variance parameter
+##' m <- lvm()
+##' regression(m) <- y~x
+##' regression(m) <- v~x
+##' ##distribution(m,~v) <- 0 # No stochastic term
+##' ## Alternative:
+##' ## regression(m) <- v[NA:0]~x
+##' distribution(m,~y) <- function(n,mean,v) rnorm(n,mean,exp(v)^.5)
+##' if (interactive()) plot(y~x,sim(m,1e3))
+
+##' ## Regression on shape parameter in Weibull model
+##' m <- lvm()
+##' regression(m) <- y ~ z+v
+##' regression(m) <- s ~ exp(0.6*x-0.5*z)
+##' distribution(m,~x+z) <- binomial.lvm()
+##' distribution(m,~cens) <- coxWeibull.lvm(scale=1)
+##' distribution(m,~y) <- coxWeibull.lvm(scale=0.1,shape=~s)
+##' eventTime(m) <- time ~ min(y=1,cens=0)
+
+##' if (interactive()) {
+##' d <- sim(m,1e3)
+##' require(survival)
+##' (cc <- coxph(Surv(time,status)~v+strata(x,z),data=d))
+##' plot(survfit(cc) ,col=1:4,mark.time=FALSE)
+##' }
+
+##' ##################################################
+##' ### Categorical predictor
+##' ##################################################
+##' m <- lvm()
+##' ## categorical(m,K=3) <- "v"
+##' categorical(m,labels=c("A","B","C")) <- "v"
+
+##' regression(m,additive=FALSE) <- y~v
+##' \dontrun{
+##' plot(y~v,sim(m,1000,p=c("y~v:2"=3)))
+##' }
+
+##' m <- lvm()
+##' categorical(m,labels=c("A","B","C"),p=c(0.5,0.3)) <- "v"
+##' regression(m,additive=FALSE,beta=c(0,2,-1)) <- y~v
+##' ## equivalent to:
+##' ## regression(m,y~v,additive=FALSE) <- c(0,2,-1)
+##' regression(m,additive=FALSE,beta=c(0,4,-1)) <- z~v
+##' table(sim(m,1e4)$v)
+##' glm(y~v, data=sim(m,1e4))
+##' glm(y~v, data=sim(m,1e4,p=c("y~v:1"=3)))
+##'
+##' transform(m,v2~v) <- function(x) x=='A'
+##' sim(m,10)
+##'
+##' ##################################################
+##' ### Pre-calculate object
+##' ##################################################
+##' m <- lvm(y~x)
+##' m2 <- sim(m,'y~x'=2)
+##' sim(m,10,'y~x'=2)
+##' sim(m2,10) ## Faster
+##'
+"sim" <- function(x,...) UseMethod("sim")
+
+##' @export
+sim.lvmfit <- function(x,n=nrow(model.frame(x)),p=pars(x),xfix=TRUE,...) {
+ m <- Model(x)
+ if ((nrow(model.frame(x))==n) & xfix) {
+ X <- exogenous(x)
+ mydata <- model.frame(x)
+ for (pred in X) {
+ distribution(m, pred) <- list(mydata[,pred])
+ }
+ }
+ sim(m,n=n,p=p,...)
+}
+
+##' @export
+sim.lvm <- function(x,n=NULL,p=NULL,normal=FALSE,cond=FALSE,sigma=1,rho=.5,
+ X=NULL,unlink=FALSE,latent=TRUE,use.labels=TRUE,seed=NULL,...) {
+
+ if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE))
+ runif(1)
+ if (is.null(seed))
+ RNGstate <- get(".Random.seed", envir = .GlobalEnv)
+ else {
+ R.seed <- get(".Random.seed", envir = .GlobalEnv)
+ set.seed(seed)
+ RNGstate <- structure(seed, kind = as.list(RNGkind()))
+ on.exit(assign(".Random.seed", R.seed, envir = .GlobalEnv))
+ }
+
+
+ v.env <- c("A","M","P","PP","PPdiag","xx","vv","mdist","mdistnam","mii",
+ "nn","mu","xf","xfix","X",
+ "vartrans","multitrans","multitrans.idx",
+ "X.idx","ii.mvn","xconstrain.idx","xconstrain",
+ "xconstrain.par","covparnames","exo_constrainY")
+
+ setup <- is.null(n) ## Save environment (variables v.env) and return sim object
+ loadconfig <- !is.null(x$sim.env) && !setup && (length(list(...))==0 && length(p)==0)
+ if (loadconfig) {
+ for (v in setdiff(v.env,"X")) assign(v, x$sim.env[[v]])
+ if (is.null(X)) X <- x$sim.env[['X']]
+ } else {
+ if (!is.null(X)) {
+ n <- nrow(X)
+ }
+ if (!is.null(n) && n<1) return(NULL)
+ p <- c(p,unlist(list(...)))
+ xx <- exogenous(x)
+ if (!is.null(p)) {
+ i1 <- na.omit(c(match(names(p),xx),
+ match(names(p),paste0(xx,lava.options()$symbol[2],xx))))
+ if (length(i1)>0) covariance(x) <- xx[i1]
+ }
+ ## index(x) <- reindex(x)
+ vv <- vars(x)
+ nn <- setdiff(vv,parameter(x))
+ mu <- unlist(lapply(x$mean, function(l) ifelse(is.na(l)|is.character(l),0,l)))
+ xf <- intersect(unique(parlabels(x)),xx)
+ xfix <- c(randomslope(x),xf); if (length(xfix)>0) normal <- FALSE
+
+ ## Match parameter names
+ if ((!is.null(names(p)) && all(!is.na(names(p)))) || length(p)!=(index(x)$npar+index(x)$npar.mean+index(x)$npar.ex) | is.null(names(p))) {
+ nullp <- is.null(p)
+ p0 <- p
+ ep <- NULL
+ ei <- which(index(x)$e1==1)
+ if (length(ei)>0)
+ ep <- unlist(x$expar)[ei]
+ p <- c(rep(1, index(x)$npar+index(x)$npar.mean),ep)
+ p[seq_len(index(x)$npar.mean)] <- 0
+ p[index(x)$npar.mean + variances(x)] <- sigma
+ p[index(x)$npar.mean + offdiags(x)] <- rho
+ if (!nullp) {
+ c1 <- coef(x,mean=TRUE,fix=FALSE)
+ c2 <- coef(x,mean=TRUE,fix=FALSE,labels=TRUE)
+ idx1 <- na.omit(match(names(p0),c1))
+ idx11 <- na.omit(match(names(p0),c2))
+ idx2 <- na.omit(which(names(p0)%in%c1))
+ idx22 <- na.omit(which(names(p0)%in%c2))
+ if (length(idx1)>0 && !is.na(idx1))
+ p[idx1] <- p0[idx2]
+ if (length(idx11)>0 && !is.na(idx11))
+ p[idx11] <- p0[idx22]
+ }
+ }
+
+ M <- modelVar(x,p,data=NULL)
+ A <- M$A; P <- M$P
+ if (!is.null(M$v)) mu <- M$v
+
+ ## Square root of residual variance matrix
+ PP <- with(svd(P), v%*%diag(sqrt(d),nrow=length(d))%*%t(u))
+ ## Multivariate distributions
+ mdist <- distribution(x,multivariate=TRUE)$var
+ mdistnam <- names(mdist)
+ mii <- match(mdistnam,vars(x))
+ if (length(distribution(x))>0 ) {
+ ii <- match(names(distribution(x)),vv)
+ ii.mvn <- setdiff(seq(ncol(P)),c(ii,mii))
+ } else {
+ ii.mvn <- seq(ncol(P))
+ }
+ PPdiag <- sum(abs(offdiag(PP[ii.mvn,ii.mvn,drop=FALSE])^2))<1e-20
+ }
+
+ if (!setup) {
+ E <- matrix(0,ncol=ncol(P),nrow=n)
+ if (length(ii.mvn)>0) {
+ ## Error term for conditional normal distributed variables
+ if (PPdiag) {
+ for (i in ii.mvn) E[,i] <- rnorm(n,sd=PP[i,i])
+ } else {
+ E[,ii.mvn] <- matrix(rnorm(length(ii.mvn)*n),ncol=length(ii.mvn))%*%PP[ii.mvn,ii.mvn,drop=FALSE]
+ }
+ }
+
+ if (length(mdistnam)>0) {
+ fun <- distribution(x,multivariate=TRUE)$fun
+ for (i in seq_along(fun)) {
+ mv <- names(which(unlist(mdist)==i))
+ ii <- match(mv,vv)
+ E[,ii] <- distribution(x,multivariate=TRUE)$fun[[i]](n,p=p,object=x) # ,...)
+ }
+ }
+
+ ## Simulate exogenous variables (covariates)
+ res <- matrix(0,ncol=length(nn),nrow=n)
+ colnames(res) <- nn
+ }
+
+ if (!loadconfig) {
+ vartrans <- names(x$attributes$transform)
+ multitrans <- multitrans.idx <- NULL
+ if (length(x$attributes$multitransform)>0) {
+ multitrans <- unlist(lapply(x$attributes$multitransform,function(z) z$y))
+ for (i in (seq_along(x$attributes$multitransform))) {
+ multitrans.idx <- c(multitrans.idx,rep(i,length(x$attributes$multitransform[[i]]$y)))
+ }
+ }
+ xx <- unique(c(exogenous(x, latent=FALSE, index=TRUE),xfix))
+ xx <- setdiff(xx,vartrans)
+
+ X.idx <- match(xx,vv)
+ }
+
+ if (!setup) {
+ res[,X.idx] <- t(mu[X.idx]+t(E[,X.idx]))
+ if (is.null(X)) {
+ if (!is.null(xx) && length(xx)>0)
+ for (i in seq_along(xx)) {
+ mu.x <- mu[X.idx[i]]
+ dist.x <- distribution(x,xx[i])[[1]]
+ if (is.list(dist.x) && is.function(dist.x[[1]])) dist.x <- dist.x[[1]]
+ if (is.list(dist.x)) {
+ dist.x <- dist.x[[1]]
+ if (length(dist.x)==1) dist.x <- rep(dist.x,n)
+ }
+ if (is.function(dist.x)) {
+ res[,X.idx[i]] <- dist.x(n=n,mu=mu.x,var=P[X.idx[i],X.idx[i]])
+ } else {
+ if (is.null(dist.x) || is.na(dist.x)) {
+ } else {
+ if (length(dist.x)!=n) stop("'",vv[X.idx[i]], "' fixed at length ", length(dist.x)," != ",n,".")
+ res[,X.idx[i]] <- dist.x ## Deterministic
+ }
+ }
+ }
+ } else {
+ res[,X.idx] <- X[,xx]
+ }
+ }
+
+ simuled <- c(xx)
+ resunlink <- NULL
+ if (unlink) {
+ resunlink <- res
+ }
+
+ if ( normal | ( is.null(distribution(x)) & is.null(functional(x)) & is.null(constrain(x))) ) {
+ if(cond) { ## Simulate from conditional distribution of Y given X
+ mypar <- pars(x,A,P,mu)
+ Ey.x <- predict(x, mypar, data.frame(res))
+ Vy.x <- attributes(Ey.x)$cond.var
+ PP <- with(svd(Vy.x), v%*%diag(sqrt(d),nrow=length(d))%*%t(u))
+ yy <- Ey.x + matrix(n*ncol(Vy.x),ncol=ncol(Vy.x))%*%PP
+ res <- cbind(yy, res[,xx]); colnames(res) <- c(colnames(Vy.x),xx)
+ return(res)
+ }
+ ## Simulate from sim. distribution (Y,X) (mv-normal)
+ I <- diag(nrow=length(nn))
+ IAi <- Inverse(I-t(A))
+ colnames(E) <- vv
+ dd <- t(apply(heavytail.sim.hook(x,E),1,function(x) x+mu))
+ res <- dd%*%t(IAi)
+ colnames(res) <- vv
+ } else {
+
+ if (!loadconfig) {
+ xc <- index(x)$vars
+ xconstrain.idx <- unlist(lapply(lapply(constrain(x),function(z) attributes(z)$args),function(z) length(intersect(z,xc))>0))
+ xconstrain <- intersect(unlist(lapply(constrain(x),function(z) attributes(z)$args)),xc)
+ xconstrain.par <- names(xconstrain.idx)[xconstrain.idx]
+ covparnames <- unique(as.vector(covariance(x)$labels))
+ exo_constrainY <- intersect(exogenous(x),names(x$constrainY))
+ }
+
+ if (setup) {
+ sim.env <- c()
+ sim.env[v.env] <- list(NULL)
+ for (v in v.env) if (!is.null(get(v))) sim.env[[v]] <- get(v)
+ x$sim.env <- sim.env
+ return(x)
+ }
+
+ if (length(xconstrain)>0)
+ for (i in which(xconstrain.idx)) {
+ ff <- constrain(x)[[i]]
+ myargs <- attributes(ff)$args
+ D <- matrix(0,n,length(myargs))
+ for (j in seq_len(ncol(D))) {
+ if (myargs[j]%in%xconstrain)
+ D[,j] <- res[,myargs[j]]
+ else
+ D[,j] <- M$parval[[myargs[j]]]
+ }
+ val <- try(apply(D,1,ff),silent=TRUE)
+ if (inherits(val,"try-error") || NROW(val)<n) val <- ff(D)
+ res <- cbind(res, val); colnames(res)[ncol(res)] <- names(xconstrain.idx)[i]
+ }
+
+ if (any(xconstrain.par%in%covparnames)) {
+ mu0 <- rep(0,ncol(P))
+ P0 <- P
+ E <- t(sapply(seq_len(n),function(idx) {
+ for (i in intersect(xconstrain.par,covparnames)) {
+ P0[covariance(x)$labels==i] <- res[idx,i]
+ }
+ PP <- with(svd(P0), v%*%diag(sqrt(d),nrow=length(d))%*%t(u))
+ return(mu0+rbind(rnorm(ncol(P0)))%*%PP)
+ }))
+ }
+
+ colnames(E) <- vv
+ E <- heavytail.sim.hook(x,E)
+
+ ## Non-linear regression components
+ xconstrain <- c()
+ for (i in seq_len(length(constrain(x)))) {
+ z <- constrain(x)[[i]]
+ xx <- intersect(attributes(z)$args,manifest(x))
+ if (length(xx)>0) {
+ warg <- setdiff(attributes(z)$args,xx)
+ wargidx <- which(attributes(z)$args%in%warg)
+ exoidx <- which(attributes(z)$args%in%xx)
+ parname <- names(constrain(x))[i]
+ y <- names(which(unlist(lapply(intercept(x),function(x) x==parname))))
+ el <- list(i,y,parname,xx,exoidx,warg,wargidx,z)
+ names(el) <- c("idx","endo","parname","exo","exoidx","warg","wargidx","func")
+ xconstrain <- c(xconstrain,list(el))
+ }
+ }
+
+ yconstrain <- unlist(lapply(xconstrain,function(x) x$endo))
+ for (i in exo_constrainY) {
+ cc <- x$constrainY[[i]]
+ args <- cc$args
+ args <- if (is.null(args) || length(args)==0) res[,i] else res[,args]
+ res[,i] <- cc$fun(args,p) # ,...)
+ }
+
+ res <- data.frame(res)
+ if (length(vartrans)>0) {
+ parvals <- parpos(x)$parval
+ parvalsnam <- setdiff(names(parvals),xx)
+ if (length(parvalsnam)>0) {
+ Parvals <- p[unlist(parvals)];
+ res <- cbind(res,
+ cbind(rep(1,nrow(res)))%x%rbind(Parvals))
+ colnames(res)[seq(length(Parvals))+ncol(res)-length(Parvals)] <-
+ names(parvals)
+ }
+ }
+
+ leftovers <- c()
+ itercount <- 0
+ while (length(simuled)<length(nn)) {
+ leftoversPrev <- leftovers
+ leftovers <- setdiff(nn,simuled)
+ if (!is.null(leftoversPrev) && length(leftoversPrev)==length(leftovers)) {
+ if (itercount>0)
+ stop("Infinite loop (feedback).")
+ itercount <- itercount+1
+ }
+ for (i in leftovers) {
+ if (i%in%vartrans) {
+ xtrans <- x$attributes$transform[[i]]$x
+ if (all(xtrans%in%c(simuled,names(parvals)))) {
+ xtr <- res[,xtrans,drop=FALSE]
+ if (use.labels) {
+ lb <- x$attributes$labels
+ lb.idx <- na.omit(match(names(lb),xtrans))
+ ## For categorical variables turn them into factors so we can
+ ## use the actual labels in function calls/transform
+ if (length(lb.idx)>0) {
+ xtr <- as.data.frame(xtr)
+ for (lb0 in lb.idx) {
+ lab <- lb[[names(xtr)[lb0]]]
+ xtr[,lb0] <- factor(xtr[,lb0],levels=seq_along(lab)-1,labels=lab)
+ }
+ }
+ }
+ suppressWarnings(yy <- with(x$attributes$transform[[i]], fun(xtr))) ##fun(res[,xtrans])))
+ if (NROW(yy) != NROW(res)) { ## apply row-wise
+ res[,i] <- with(x$attributes$transform[[i]], ##apply(res[,xtrans,drop=FALSE],1,fun))
+ apply(xtr,1,fun))
+ } else {
+ colnames(yy) <- NULL
+ res[,i] <- yy
+ }
+ simuled <- c(simuled,i)
+ }
+ } else if (i%in%multitrans) {
+ idx0 <- match(i,multitrans)
+ idx <- multitrans.idx[idx0]
+ mtval <- x$attributes$multitransform[[idx]]
+ if (all(mtval$x%in%simuled)) {
+ res[,mtval$y] <- mtval$fun(res[,mtval$x])
+ simuled <- c(simuled,mtval$y)
+ break;
+ }
+ } else {
+ ipos <- which(yconstrain%in%i)
+ if (length(ipos)==0 || all(xconstrain[[ipos]]$exo%in%simuled)) {
+ pos <- match(i,vv)
+ relations <- colnames(A)[A[,pos]!=0]
+ simvars <- x$attributes$simvar[[i]]
+ dist.i <- distribution(x,i)[[1]] ## User-specified distribution function
+ dist.xx <- NULL
+ if (is.function(dist.i)) {
+ dist.args0 <- names(formals(dist.i))
+ dist.args <- setdiff(dist.args0,c("n","mean","mu","var","..."))
+ dist.xx <- intersect(names(res),dist.args) ## Variables influencing distribution
+ }
+ if (all(c(relations,simvars,dist.xx)%in%simuled)) { ## Only depending on already simulated variables
+ if (x$mean[[pos]]%in%xconstrain.par && length(ipos)==0) {
+ mu.i <- res[,x$mean[[pos]] ]
+ } else {
+ mu.i <- mu[pos]
+ }
+ if (length(ipos)>0) {
+ pp <- unlist(M$parval[xconstrain[[ipos]]$warg])
+ myidx <- with(xconstrain[[ipos]],order(c(wargidx,exoidx)))
+ ## myidx <- with(xconstrain[[ipos]],
+ ## match(attr(func,"args"), c(warg,exo)))
+ X <- with(xconstrain[[ipos]],
+ if (length(pp)>0)
+ cbind(rbind(pp)%x%cbind(rep(1,nrow(res))),
+ res[,exo,drop=FALSE])
+ else res[,exo,drop=FALSE])
+ yy <- try(with(xconstrain[[ipos]],
+ func(X[,myidx])),silent=TRUE)
+ if (NROW(yy) != NROW(res)) { ## apply row-wise
+ mu.i <- #mu.i +
+ with(xconstrain[[ipos]],
+ apply(res[,exo,drop=FALSE],1,
+ function(x) func(
+ unlist(c(pp,x))[myidx])))
+ } else {
+ mu.i <- ##mu.i+
+ yy
+ }
+ }
+ for (From in relations) {
+ f <- functional(x,i,From)[[1]]
+ if (!is.function(f))
+ f <- function(x,...) x
+ reglab <- regfix(x)$labels[From,pos]
+ if (reglab%in%c(xfix,xconstrain.par)) {
+ if (is.function(f)) {
+ if (length(formals(f))>1) {
+ mu.i <- mu.i + res[,reglab]*f(res[,From],p)
+ } else {
+ mu.i <- mu.i + res[,reglab]*f(res[,From])
+ }
+ } else mu.i <- mu.i + res[,reglab]*res[,From]
+ }
+ else {
+ if (is.function(f)) {
+ if (length(formals(f))>1) {
+ mu.i <- mu.i + A[From,pos]*f(res[,From],p)
+ } else {
+ mu.i <- mu.i + A[From,pos]*f(res[,From])
+ }
+ } else mu.i <- mu.i + A[From,pos]*res[,From]
+ }
+ }
+ if (!is.function(dist.i)) {
+ res[,pos] <- mu.i + E[,pos]
+ if (unlink)
+ resunlink[,pos] <- res[,pos]
+ }
+ else {
+ if (length(simvars)>0) { ## Depends on mu and also on other variables (e.g. time-depending effect)
+ if (length(mu.i)==1) mu.i <- rep(mu.i,n)
+ mu.i <- cbind("m0"=mu.i,res[,simvars,drop=FALSE])
+ }
+ new.args <- list(n=n)
+ mu.arg <- intersect(c("mean","mu"),dist.args0)
+ if (length(mu.arg)>0) {
+ new.args <- c(new.args,list(mu.i))
+ names(new.args)[length(new.args)] <- mu.arg[1]
+ }
+ var.arg <- intersect(c("var"),dist.args0)
+ if (length(var.arg)>0) {
+ new.args <- c(new.args,list(P[pos,pos]))
+ names(new.args)[length(new.args)] <- var.arg[1]
+ }
+ for (jj in dist.xx) {
+ new.args <- c(new.args,list(res[,jj,drop=TRUE]))
+ names(new.args)[length(new.args)] <- jj
+ }
+ res[,pos] <- do.call(dist.i,new.args)
+ if (unlink)
+ resunlink[,pos] <- mu.i
+ }
+
+ if (length(x$constrainY)>0 && i%in%names(x$constrainY)) {
+ cc <- x$constrainY[[i]]
+ args <- cc$args
+ args <- if (is.null(args) || length(args)==0)
+ res[,pos]
+ else {
+ ii <- intersect(names(M$parval),args)
+ args0 <- args
+ args <- res[,intersect(args,colnames(res)),drop=FALSE]
+ if (length(ii)>0) {
+ pp <- rbind(unlist(M$parval[ii]))%x%cbind(rep(1,n))
+ colnames(pp) <- ii
+ args <- cbind(res,pp)[,args0,drop=FALSE]
+ }
+ }
+ res[,pos] <- cc$fun(args,p) # ,...)
+ }
+ simuled <- c(simuled,i)
+ }
+ }
+ }
+ }
+ }
+ res <- res[,nn,drop=FALSE]
+ }
+
+ res <- as.data.frame(res)
+ myhooks <- gethook("sim.hooks")
+ for (f in myhooks) {
+ res <- do.call(f, list(x=x,data=res,p=p,modelpar=M))
+ }
+ if (unlink) res <- resunlink
+
+ res <- as.data.frame(res)
+ self <- x$attributes$selftransform
+ for (v in names(self)) {
+ res[,v] <- self[[v]](res[,v])
+ }
+ if (!latent && length(latent(x))>0) return(subset(res[,-which(colnames(res)%in%latent(x))]))
+ return(res)
+}
+
+
+
+##' @export
+simulate.lvm <- function(object,nsim,seed=NULL,...) {
+ sim(object,nsim,seed=seed,...)
+}
+
+##' @export
+simulate.lvmfit <- function(object,nsim,seed=NULL,...) {
+ sim(object,nsim,seed=seed,...)
+}
+
diff --git a/R/spaghetti.R b/R/spaghetti.R
new file mode 100644
index 0000000..d985bc4
--- /dev/null
+++ b/R/spaghetti.R
@@ -0,0 +1,220 @@
+##' Spaghetti plot for longitudinal data
+##'
+##' @title Spaghetti plot
+##' @param formula Formula (response ~ time)
+##' @param data data.frame
+##' @param id Id variable
+##' @param group group variable
+##' @param type Type (line 'l', stair 's', ...)
+##' @param lty Line type
+##' @param pch Colour
+##' @param col Colour
+##' @param alpha transparency (0-1)
+##' @param lwd Line width
+##' @param level Confidence level
+##' @param trend.formula Formula for trendline
+##' @param tau Quantile to estimate (trend)
+##' @param trend.lty Trend line type
+##' @param trend.join Trend polygon
+##' @param trend.delta Length of limit bars
+##' @param trend Add trend line
+##' @param trend.col Colour of trend line
+##' @param trend.alpha Transparency
+##' @param trend.lwd Trend line width
+##' @param trend.jitter Jitter amount
+##' @param legend Legend
+##' @param by make separate plot for each level in 'by' (formula, name of column, or vector)
+##' @param xlab Label of X-axis
+##' @param ylab Label of Y-axis
+##' @param add Add to existing device
+##' @param ... Additional arguments to lower level arguments
+##' @author Klaus K. Holst
+##' @export
+##' @examples
+##' if (interactive() & requireNamespace("mets")) {
+##' K <- 5
+##' y <- "y"%++%seq(K)
+##' m <- lvm()
+##' regression(m,y=y,x=~u) <- 1
+##' regression(m,y=y,x=~s) <- seq(K)-1
+##' regression(m,y=y,x=~x) <- "b"
+##' N <- 50
+##' d <- sim(m,N); d$z <- rbinom(N,1,0.5)
+##' dd <- mets::fast.reshape(d); dd$num <- dd$num+3
+##' spaghetti(y~num,dd,id="id",lty=1,col=Col(1,.4),
+##' trend.formula=~factor(num),trend=TRUE,trend.col="darkblue")
+##' dd$num <- dd$num+rnorm(nrow(dd),sd=0.5) ## Unbalance
+##' spaghetti(y~num,dd,id="id",lty=1,col=Col(1,.4),
+##' trend=TRUE,trend.col="darkblue")
+##' spaghetti(y~num,dd,id="id",lty=1,col=Col(1,.4),
+##' trend.formula=~num+I(num^2),trend=TRUE,trend.col="darkblue")
+##' }
+spaghetti <- function(formula,data,id="id",group=NULL,
+ type="o",lty=1,pch=NA,col=1:10,alpha=0.3,lwd=1,
+ level=0.95,
+ trend.formula=formula,tau=NULL,
+ trend.lty=1,trend.join=TRUE,trend.delta=0.2,
+ trend=!is.null(tau),trend.col=col,
+ trend.alpha=0.2,trend.lwd=3,
+ trend.jitter=0,
+ legend=NULL, by=NULL,
+ xlab="Time",ylab="",add=FALSE,...) {
+ ##spaghetti <- function(formula,data,id,type="l",lty=1,col=Col(1),trend=FALSE,trend.col="darkblue",trend.alpha=0.2,trend.lwd=3,xlab="Time",ylab="",...) {
+ if (!lava.options()$cluster.index) stop("mets not available? Check 'lava.options()cluster.index'.")
+ if (!is.null(by)) {
+ if (is.character(by) && length(by==1)) {
+ by <- data[,by]
+ } else if (inherits(by,"formula")) {
+ ##by <- model.matrix(update(by,~-1+.), model.frame(~.,data,na.action=na.pass))
+ by <- model.frame(by,data,na.action=na.pass)
+ }
+ cl <- match.call(expand.dots=TRUE)
+ cl$by <- NULL
+ datasets <- split(data,by)
+ res <- c()
+ for (d in datasets) {
+ cl$data <- d
+ res <- c(res, eval(cl,parent.frame()))
+ }
+ return(invisible(res))
+ }
+ if (!is.null(group)) {
+ if (is.character(group) && length(group==1)) {
+ M <- data[,group]
+ } else if (inherits(group,"formula")) {
+ ##M <- model.matrix(update(group,~-1+.),data)
+ M <- model.frame(group,data,na.action=na.pass)
+ } else {
+ M <- group
+ }
+ if (!add) plot(formula,data=data,xlab=xlab,ylab=ylab,...,type="n")
+ dd <- split(data,M)
+ K <- length(dd)
+ if (length(type)<K) type <- rep(type,K)
+ if (length(col)<K) col <- rep(col,K)
+ if (length(pch)<K) pch <- rep(pch,K)
+ if (length(lty)<K) lty <- rep(lty,K)
+ if (length(lwd)<K) lwd <- rep(lwd,K)
+ if (length(alpha)<K) alpha <- rep(alpha,K)
+ if (length(trend)<K) trend <- rep(trend,K)
+ if (length(trend.col)<K) trend.col <- rep(trend.col,K)
+ if (length(trend.lty)<K) trend.lty <- rep(trend.lty,K)
+ if (length(trend.alpha)<K) trend.alpha <- rep(trend.alpha,K)
+ if (length(trend.lwd)<K) trend.lwd <- rep(trend.lwd,K)
+ for (i in seq_len(K)) {
+ spaghetti(formula,data=dd[[i]],id=id,type=type[i],
+ lty=lty[i],pch=pch[i],col=col[i],lwd=lwd[i],
+ alpha=alpha[i],
+ group=NULL,
+ trend=trend[i],tau=tau,
+ trend.col=trend.col[i],
+ trend.alpha=trend.alpha[i],
+ trend.lwd=trend.lwd[i],
+ trend.lty=trend.lty[i],
+ trend.delta=trend.delta,
+ trend.formula=trend.formula,
+ add=TRUE,...)
+ }
+ if (!is.null(legend)) {
+ graphics::legend(legend,names(dd),lwd=lwd,col=col,lty=lty)
+ }
+ return(invisible(NULL))
+ }
+
+ if (inherits(id,"formula")) id <- all.vars(id)
+ if (inherits(group,"formula")) group <- all.vars(group)
+ if (is.character(id) && length(id)==1) Id <-
+ y <- getoutcome(formula)
+ x <- attributes(y)$x
+ Idx <- function(vname,widenames) {
+ idx <- which(unlist(lapply(widenames,function(x) length(grep(vname,substr(x,1,nchar(vname))))>0)))
+ nn <- widenames[idx]
+ ord <- order(char2num(unlist(lapply(nn,function(x) gsub(vname,"",x)))))
+ idx[ord]
+ }
+
+ if (!requireNamespace("mets",quietly=TRUE)) stop("'mets' package required")
+
+ if (length(x)==0) {
+ data <- data[,c(id,y),drop=FALSE]
+ wide <- mets::fast.reshape(data,id=id,varying=y,...)
+ yidx <- Idx(y,names(wide))
+ Y <- wide[,yidx,drop=FALSE]
+ X <- NULL
+ matplot(t(Y),type=type,lty=lty,pch=pch,lwd=lwd,col=Col(col[1],alpha[1]),xlab=xlab,ylab=ylab,...)
+ } else {
+ data <- data[,c(id,x,y),drop=FALSE]
+ wide <- mets::fast.reshape(data[order(data[,id],data[,x]),],id=id,varying=c(y,x),...)
+ yidx <- Idx(y,names(wide))
+ xidx <- Idx(x,names(wide))
+ Y <- wide[,yidx,drop=FALSE]
+ X <- wide[,xidx,drop=FALSE]
+ matplot(t(X),t(Y),type=type,pch=pch,lty=lty,lwd=lwd,col=Col(col[1],alpha[1]),xlab=xlab,ylab=ylab,add=add,...)
+ if (trend) {
+ if (is.numeric(trend.formula)) {
+ trend.formula <- sort(trend.formula)
+ tf <- toformula(y,"1")
+ res <- c()
+ if (!is.null(tau)) {
+ if (length(trend.alpha)<length(tau)) trend.alpha <- rep(trend.alpha,length(tau))
+ if (length(trend.lty)<length(tau)) trend.lty <- rep(trend.lty,length(tau))
+ if (length(trend.col)<length(tau)) trend.col <- rep(trend.col,length(tau))
+ if (length(trend.lwd)<length(tau)) trend.lwd <- rep(trend.lwd,length(tau))
+ }
+ for (i in trend.formula) {
+ data0 <- data[data[,x]==i,,drop=FALSE]
+ newdata <- data.frame(i); names(newdata) <- x
+ if (!is.null(tau)) {
+ ##if (!require(quantreg)) stop("Install 'quantreg'")
+ suppressWarnings(r1 <- quantreg::rq(tf,data=data0,tau=tau))
+ pr <- predict(r1,newdata=newdata,level=level)
+ res <- rbind(res,pr)
+ } else {
+ l1 <- lm(tf,data0)
+ pr <- predict(l1,newdata=newdata,interval="confidence",level=level)
+ res <- rbind(res,pr)
+ }
+ }
+ if (!is.null(tau)) {
+ for (j in seq_len(ncol(res))) {
+ if (trend.join) lines(trend.formula,res[,j],col=trend.col[j],lwd=trend.lwd[j],lty=trend.lty[j],...)
+ if (trend.delta>0) confband(trend.formula,res[,j],line=FALSE,col=trend.col[j],lty=trend.lty[j],lwd=trend.lwd[j],delta=trend.delta,...)
+ }
+ } else {
+ confband(trend.formula,res[,2],res[,3],res[,1],col=Col(trend.col,trend.alpha),lty=trend.lty,lwd=trend.lwd,polygon=trend.join,...)
+ }
+ } else {
+ tf <- getoutcome(trend.formula)
+ if (is.list(tf)) {
+ trend.formula <- update(trend.formula,toformula(y,"."))
+ }
+ if (!is.null(tau)) {
+ ##if (!require(quantreg)) stop("Install 'quantreg'")
+ suppressWarnings(r1 <- quantreg::rq(trend.formula,data=data,tau=tau))
+ newdata <- data.frame(seq(min(X,na.rm=TRUE),max(X,na.rm=TRUE),length.out=100))
+ names(newdata) <- x
+ pr <- predict(r1,newdata=newdata,interval="confidence",level=level)
+ ##confband(xx,pr[,3],pr[,2],polygon=TRUE,col=Col(trend.col,trend.alpha),border=FALSE)
+ for (i in seq_along(tau))
+ lines(newdata[,1],pr[,i],col=trend.col,lwd=trend.lwd,lty=trend.lty)
+ } else {
+ l1. <- lm(trend.formula,data)
+ l1 <- estimate(l1.,id=data[,id],level=level)
+ xy <- plotConf(l1.,vcov=vcov(l1),data=data,partres=FALSE,plot=FALSE,level=level,...)
+ xx <- xy$x
+ pr <- xy$predict$fit
+ if (is.factor(xx)) {
+ xx <- char2num(as.character(xx))
+ if (trend.jitter>0) xx <- jitter(xx,trend.jitter)
+ confband(xx,pr[,3],pr[,2],pr[,1],col=trend.col,lwd=2)
+ } else {
+ confband(xx,pr[,3],pr[,2],polygon=TRUE,col=Col(trend.col,trend.alpha),border=FALSE)
+ lines(xx,pr[,1],col=trend.col,lwd=trend.lwd,lty=trend.lty)
+ }
+ }
+ }
+ }
+ }
+ return(invisible(list(Y,X)))
+}
+
diff --git a/R/stack.R b/R/stack.R
new file mode 100644
index 0000000..ffd3a80
--- /dev/null
+++ b/R/stack.R
@@ -0,0 +1,49 @@
+##' Stack estimating equations
+##'
+##' Stack estimating equations
+##' @param x Model 1
+##' @param model2 Model 2
+##' @param D1u Derivative of score of model 2 w.r.t. parameter vector of model 1
+##' @param inv.D2u Inverse of deri
+##' @param weights weights (vector or function)
+##' @param dweights derivative of weight wrt parameters of model 1
+##' @param U Optional score function (model 2) as function of all parameters
+##' @param k Debug argument
+##' @param keep1 If TRUE only parameters of model 2 i s returned
+##' @param ... Additional arguments to lower level functions
+##' @aliases stack.estimate
+##' @export
+stack.estimate <- function(x,model2,D1u,inv.D2u,weights,dweights,U,k=1,keep1=FALSE,...) {
+ iid1 <- iid(x)
+ iid2 <- iid(model2)
+ if (missing(inv.D2u)) {
+ inv.D2u <- -attributes(iid2)$bread
+ }
+ if (is.null(inv.D2u)) stop("Need derivative of second stage score")
+ if (!missing(U)) {
+ D1u <- numDeriv::jacobian(U,coef(x))
+ }
+ if (!missing(weights) && is.function(weights)) {
+ dweights <- numDeriv::jacobian(weights,coef(x))
+ weights <- weights(coef(x))
+ }
+ if (!missing(dweights)) {
+ D2u <- Inverse(inv.D2u)
+ u2 <- iid2%*%D2u ## Score of stage two equation derived from estimated influence function
+ ## Derivative of score wrt first set of parameters (weights model)
+ D1u <- crossprod(apply(u2,2,function(x) -x/weights),dweights)
+ }
+ ii <- iid(merge(x,model2))
+ iid1. <- ii[,seq_along(coef(x)),drop=FALSE]
+ iid2. <- ii[,length(coef(x))+seq_along(coef(model2)),drop=FALSE]
+ iid3 <- t(inv.D2u%*%(D1u%*%t(iid1.)))
+ if (!keep1) return(estimate(coef=coef(model2),iid=cbind(iid2.+k*iid3)))
+ estimate(coef=c(coef(x),coef(model2)),iid=cbind(iid1.,iid2. + k*iid3))
+}
+
+##' @export
+stack.glm <- function(x,model2,...) {
+ stack(estimate(x),estimate(model2),...)
+}
+
+
diff --git a/R/startvalues.R b/R/startvalues.R
new file mode 100644
index 0000000..467590f
--- /dev/null
+++ b/R/startvalues.R
@@ -0,0 +1,388 @@
+mgstart <- function(x,p) {
+ if (is.list(p)) {
+ npar <- with(x, npar+npar.mean+length(unlist(expar)))
+ pos <- modelPar(x,seq(npar))$p
+ start <- matrix(NA,ncol=npar,nrow=x$ngroup)
+ startl <- lapply(pos, function(x) rep(NA,length(x)))
+ for (i in seq_len(x$ngroup)) {
+ p0 <- p[[i]]
+ pos0 <- pos[[i]]
+ if (!is.null(names(p0))) {
+ ii <- parpos(Model(x)[[i]],names(p0))
+ startl[[i]][ii] <- p0[names(ii)]
+ } else {
+ ii <- seq(min(length(p0),length(startl[[i]])))
+ startl[[i]][ii] <- p0[ii]
+ }
+ start[i,pos0] <- startl[[i]]
+ }
+ start0 <- apply(start,2,function(x) mean(x,na.rm=TRUE))
+ }
+ return(start0)
+}
+
+
+###{{{ starter.multigroup
+
+##' @export
+starter.multigroup <- function(x, starterfun=startvalues2, meanstructure=TRUE,silent=TRUE,...) {
+ ## Initial values:
+ W <- c() ## Weight-vector
+ s <- list()
+ for (i in seq_len(x$ngroup)) {
+ mydata <- x$data[[i]][,manifest(x$lvm[[i]]),drop=FALSE]
+ W <- c(W, nrow(mydata))
+ if (nrow(mydata)<3) {
+ ii <- index(x$lvm[[i]])
+ nn <- ifelse(meanstructure, ii$npar+ii$npar.mean, ii$npar)
+ s0 <- rep(1,nn)
+ }
+ else {
+ S <- x$samplestat[[i]]$S
+ mu <- if (meanstructure) x$samplestat[[i]]$mu else NULL;
+ ## S <- cov(mydata); mu <- if (meanstructure) colMeans(mydata) else NULL;
+ s0 <- do.call(starterfun, list(x$lvm[[i]], S=S, mu=mu,silent=TRUE))
+ }
+ s <- c(s, list(s0))
+ }
+
+ Wtotal <- sum(W); W <- W/Wtotal
+
+ pg <- vector("list", x$npar); for (i in seq_len(length(pg))) pg[[i]] <- rep(0,x$ngroup)
+ meang <- vector("list", x$npar.mean); for (i in seq_len(length(meang))) meang[[i]] <- rep(0,x$ngroup)
+
+ for (i in seq_len(x$ngroup)) {
+ pp <- modelPar(x$lvm[[i]],s[[i]])
+ pos <- sapply(x$parlist[[i]], function(y) char2num(substr(y,2,nchar(y))))
+ for (j in seq_len(length(pos)))
+ pg[[ pos[j] ]][i] <- pp$p[j]
+
+ pos <- sapply(x$meanlist[[i]], function(y) char2num(substr(y,2,nchar(y))))
+ ptype <- sapply(x$meanlist[[i]], function(y) substr(y,1,1)=="m")
+ if (!(any(ptype)))
+ pos <- NULL
+ else
+ pos <- pos[ptype]
+ if (length(pos)>0)
+ for (j in seq_len(length(pos))) {
+ meang[[ pos[j] ]][i] <- pp$meanpar[j]
+ }
+ }
+
+ ## Weighted average
+ wp <- unlist(lapply(pg, function(y) {
+ ppos <- !is.na(y)
+ myweight <- W[ppos]/sum(W[ppos])
+ sum(y[ppos]*myweight)
+ }))
+ wmean <- unlist(lapply(meang, function(y) {
+ ppos <- !is.na(y)
+ myweight <- W[ppos]/sum(W[ppos])
+ sum(y[ppos]*myweight)
+ }))
+ res <- c(wmean,wp)
+ res[!is.finite(res) | is.nan(res) | is.na(res) | is.complex(res)] <- .5
+ return(as.numeric(res))
+}
+
+###}}}
+
+###{{{ startmean
+
+startmean <- function(x,p,mu) {
+ if (is.null(mu))
+ return(p)
+ meanpar <- numeric(index(x)$npar.mean)
+ mymeans <- vars(x)[index(x)$v1==1]
+ midx <- na.omit(match(names(mu),mymeans))
+ meanpar[midx] <- mu[midx]
+ AP <- matrices(x,p,meanpar)
+ nu <- numeric(length(vars(x)))
+ nu[vars(x)%in%manifest(x)] <- mu
+ meanstart <- ((diag(nrow=nrow(AP$A))-t(AP$A))%*%nu)[index(x)$v1==1]
+ names(meanstart) <- vars(x)[index(x)$v1==1]
+ return( c(meanstart, p) )
+}
+
+###}}}
+
+###{{{ startvalues3
+
+`startvalues3` <-
+function(x, S, debug=FALSE, tol=1e-6,...) {
+ S <- reorderdata.lvm(x,S)
+ if (nrow(S)!=length(manifest(x))) stop("Number of observed variables in data and models does not agree.")
+ J <- index(x)$J ## Manifest selection
+ P0 <- index(x)$P0 ## covariance 'adjacency'
+ A <- t(index(x)$M) ## Adjacency matrix
+ n <- nrow(S) ## Number of manifest variables
+ m <- nrow(A) ## Number of variables
+ A1 <- t(index(x)$M1) ## Adjacency matrix (without fixed parameters and duplicates)
+ A0 <- t(index(x)$M0) ## Adjacency matrix (without fixed parameters)
+
+ obs.idx <- index(x)$obs.idx;
+ ##obs.idx <- as.vector(J%*%(seq_len(m)));
+ latent.idx <- setdiff(seq_len(m), obs.idx)
+ lat <- colnames(A)[latent.idx]
+
+ exo.idx <- index(x)$exo.idx ## match(exogenous(x),vars(x))
+ exo.idxObs <- index(x)$exo.obsidx ##match(exogenous(x),manifest(x))
+
+ AP0 <- moments(x, rep(0,index(x)$npar))
+ newP <- t(AP0$P)
+ newA <- t(AP0$A)
+ fixed <- t(x$fix)
+
+ for (i in latent.idx) {
+ fix.idx <- colnames(fixed)[which(!is.na(t(fixed[,i])))[1]]
+ lambda0 <- newA[fix.idx,i]
+ rel.idx <- which(A0[,i]==1)
+ rel.all <- which(A[,i]==1)
+ rel.pos <- colnames(A)[rel.all]
+ ## Estimation of lambda (latent -> endogenous)
+ for (j in rel.idx) {
+ lambda <- lambda0*S[fix.idx, j]/S[fix.idx,fix.idx]
+ newA[j,i] <- lambda
+ }
+ lambdas <- newA[rel.pos,i]
+
+
+ ## Estimation of beta (covariate -> latent)
+ exo2latent <- which(A0[i,exo.idx]==1)
+ exo.pos <- colnames(S)[exo.idxObs[exo2latent]]
+ varX.eta <- S[exo.pos, exo.pos]
+ InvvarX.eta <- Inverse(varX.eta,tol=1e-3)
+ rel.pos <- setdiff(rel.pos,lat)
+ covXY <- S[exo.pos, rel.pos,drop=FALSE]
+ beta <- 0
+ for (j in seq_len(length(rel.pos)))
+ beta <- beta + 1/lambdas[j]*InvvarX.eta %*% covXY[,j]
+ beta <- beta/length(rel.pos)
+
+ for (k in seq_len(length(exo.pos))) {
+ if (A0[i,exo.pos[k]]==1) {
+ newA[i,exo.pos[k]] <- beta[k]
+ }
+ }
+
+ beta.eta <- matrix(newA[i,exo.pos], ncol=1)
+
+ ## Estimation of zeta^2 (variance of latent variable)
+ betavar <- matrix(beta.eta,nrow=1)%*%varX.eta%*%beta.eta
+
+ zetas <- c()
+ for (r1 in seq_len(length(rel.pos)-1))
+ for (r2 in seq(r1+1,length(rel.pos))) {
+ zetas <- c(zetas, S[rel.pos[r1], rel.pos[r2]]/ (lambdas[r1]*lambdas[r2]) - betavar)
+ }
+ zeta <- mean(zetas)
+
+ newP[i,i] <- zeta
+ for (j in rel.all) {
+ pos <- colnames(newA)[j]
+ vary <- S[pos,pos] - newA[pos,i]^2*(zeta+betavar)
+ newP[pos,pos] <- ifelse(vary<0.25,0.25,vary)
+ }
+
+ }
+ Debug(list("start=",start), debug)
+ start <- pars(x, A=t(newA), P=newP)
+ return(start)
+}
+
+###}}} startvalues3
+
+###{{{ startvalues2
+
+
+## Estimate sub-models (measurement models)
+##' @export
+`startvalues2` <-
+ function(x, S, mu=NULL, debug=FALSE, silent=FALSE,...) {
+ if (!silent) cat("Obtaining start values...\n")
+ S <- reorderdata.lvm(x,S)
+ ss <- startvalues(x,S)
+ Debug(list("ss=",ss),debug);
+ g <- measurement(x,silent=TRUE)
+ keep <- c()
+ if (length(g)>1) {
+ for (i in seq_len(length(g))) {
+ if (length(endogenous(g[[i]]))>2)
+ keep <- c(keep,i)
+ }
+ g <- g[keep]
+ }
+ if (length(g)<2)
+ return(startmean(x,ss,mu=mu))
+ ## if (!silent) cat("Fitting marginal measurement models...\n")
+ op <- options(warn=-1)
+ e <- lapply(g, function(y) {
+ estimate(y, data=list(S=S[manifest(y),manifest(y),drop=FALSE], mu=mu[manifest(y)], n=100), control=list(meanstructure=FALSE, starterfun="startvalues", estimator="Simple", method="nlminb1"), optcontrol=list(), debug=FALSE, silent=TRUE)
+ })
+ for (l in e) {
+ ## a <- coef(l$estimate)[,1]
+ a <- coef(l)
+ for (i in seq_len(length(a))) {
+ pos <- match(names(a)[i],names(ss))
+ if (!is.na(pos))
+ ss[pos] <- a[i]
+ }
+ }
+ options(op)
+ startmean(x,ss,mu=mu)
+ }
+
+###}}} startvalues2
+
+###{{{ startvalues0
+
+##' @export
+startvalues1 <- function(x,S,mu=NULL,tol=1e-6,delta=1e-6,...) {
+ p0 <- startvalues(x,S,mu,...)
+ p0[index(x)$npar.mean+variances(x)] <- 0.1
+ p0[index(x)$npar.mean+offdiags(x)] <- 0
+ p0
+}
+
+startvalues00 <- function(x,S,mu=NULL,tol=1e-6,delta=1e-6,...) {
+ p0 <- startvalues(x,S,mu,...)
+ p0 <- numeric(length(p0))
+ P0 <- x$cov*1
+ ##P0[!is.na(x$covfix)] <-
+ ##P0 <- x$covfix; P0[is.na(P0)] <- 0
+ ##diag(P0)[index(x)$endo.idx] <- diag(S)[index(x)$endo.obsidx]/2
+ lu <- min(diag(P0)[index(x)$endo.idx])/2
+ ## diag(P0)[] <- 0.1
+ ## diag(P0)[index(x)$endo.idx] <- 1
+ diag(P0)[index(x)$eta.idx] <- 0.1 ##mean(diag(S)[index(x)$endo.idx])/2
+ ee <- eigen(P0)
+ tol <- 1e-6
+ ii <- ee$values
+ ii[ee$values<tol] <- tol
+ P0 <- ee$vectors%*%diag(ii,nrow=length(ii))%*%t(ee$vectors)
+ A0 <- P0
+ pp <- pars(x,A=t(A0),P=P0,v=rep(0,index(x)$npar.mean))
+ idx <- index(x)$npar.mean + c(offdiags(x),variances(x))
+ p0[idx] <- pp[idx]
+ return(p0)
+}
+
+
+##' @export
+startvalues0 <- function(x,S,mu=NULL,tol=1e-6,delta=1e-6,...) {
+ p0 <- startvalues(x,S,mu,...)
+ A <- t(index(x)$M) ## Adjacency matrix
+ P0 <- A0 <- matrix(0,nrow(A),ncol(A))
+ A0[,index(x)$eta.idx] <- A[,index(x)$eta.idx]
+ diag(P0)[index(x)$endo.idx] <- diag(S)[index(x)$endo.obsidx]/3
+ ##lu <- min(diag(P0)[index(x)$endo.idx])
+ lu <- 0.9
+ diag(P0)[index(x)$eta.idx] <- lu##mean(diag(S)[index(x)$endo.idx])/2
+ pp <- pars(x,A=t(A0),P=P0,v=rep(1,length(index(x)$vars)))
+ nu <- numeric(length(vars(x)))
+ pp[pp==1] <- p0[pp==1]
+ ## if (!is.null(mu)) {
+ ## nu[vars(x)%in%manifest(x)] <- mu
+ ## (diag(nrow(A0))-t(A0))%*%nu
+ ## meanstart <- solve(diag(nrow(A0))+t(A0))%*%nu
+ ## meanstart <- meanstart[which(is.na(x$mean))]
+ ## if (length(meanstart)>0)
+ ## pp[seq(length(meanstart))] <- meanstart
+ ## }
+ names(pp) <- coef(x, silent=TRUE, fixed=FALSE, mean=TRUE)[seq_len(length(pp))]
+ pp[!is.finite(pp) | is.nan(pp) | is.na(pp)] <- 0.01
+ return(pp)
+}
+
+###}}} startvalues0
+
+###{{{ startvalues
+
+## McDonald & Hartmann, 1992
+##' @export
+startvalues <-
+function(x, S, mu=NULL, debug=FALSE, silent=FALSE, tol=1e-6, delta=1e-6,...) {
+ ## As proposed by McDonald & Hartmann, 1992.
+ ## Implementation based on John Fox's implementation in the 'sem' R-package
+ S <- reorderdata.lvm(x,S)
+ if (nrow(S)!=length(manifest(x))) stop("Number of observed variables in data and models does not agree.")
+ J <- index(x)$J ## Manifest selection
+ P0 <- index(x)$P0 ## covariance 'adjacency'
+ A <- t(index(x)$M) ## Adjacency matrix
+ n <- nrow(S) ## Number of manifest variables
+ m <- nrow(A) ## Number of variables
+ A0 <- t(index(x)$M0) ## Adjacency matrix (without fixed parameters)
+ obs.idx <- as.vector(J%*%(seq_len(m))); latent.idx <- setdiff(seq_len(m), obs.idx)
+ s <- sqrt(diag(S))
+ suppressWarnings(R <- (cov2cor(S))) ## S/outer(s,s)
+ C <- P0
+ Debug(list("obs.idx", obs.idx), debug)
+ C[obs.idx,obs.idx] <- R
+ ## Estimates of covariance between latent and manifest variables
+ Debug((C), debug)
+ for (i in latent.idx) {
+ inRelation <- A[obs.idx,i]==1
+ for (j in seq_len(length(obs.idx))) {
+ Debug((j), debug)
+ C[obs.idx[j],i] <- C[i,obs.idx[j]] <- if (any(inRelation)) {
+ numerator <- sum(R[j, which(inRelation)])
+ denominator <- sqrt(sum(R[which(inRelation), which(inRelation)]))
+ numerator/denominator ## as proposed by McDonald & Hartmann
+ } else {
+ runif(1, .3, .5) ## No arrows => small random covariance
+ }
+ }
+ }
+ ## Estimates of covariance between latent variables
+ for (i in latent.idx) {
+ for (j in latent.idx) {
+ C[i,j] <- C[j,i] <-
+ if (i==j) {
+ 1
+ } else {
+ inRelation.i <- A[obs.idx, i]==1
+ inRelation.j <- A[obs.idx, j]==1
+ if ((any(inRelation.i)) | (any(inRelation.j))) {
+ numerator <- sum(R[which(inRelation.i), which(inRelation.j)])
+ denominator <- sqrt( sum(R[which(inRelation.i), which(inRelation.i)])
+ * sum(R[which(inRelation.j), which(inRelation.j)]))
+ numerator/(denominator+0.01) ## Avoid division by zero
+ } else {
+ runif(1, .3, .5)
+ }
+ }
+ }
+ }
+ if (debug) {
+ print("C="); print(C);
+ }
+ Ahat <- matrix(0,m,m)
+ C[is.nan(C)] <- 0
+ for (j in seq_len(m)) { ## OLS-estimates
+ relation <- A[j,]==1
+ if (!any(relation)) next
+ Ahat[j, relation] <- tryCatch(Inverse(C[relation,relation] + diag(nrow=sum(relation))*delta,tol=1e-3) %*% C[relation,j], error=function(...) 0)
+ }
+ Ahat[obs.idx,] <- Ahat[obs.idx,]*matrix(s, n, m)
+ Ahat[,obs.idx] <- Ahat[,obs.idx]/matrix(s, m, n, byrow=TRUE)
+ Chat <- C
+ Chat[obs.idx,] <- Chat[obs.idx,]*matrix(s,n,m) ##
+ Chat[,obs.idx] <- Chat[,obs.idx]*matrix(s,m,n,byrow=TRUE) ##
+ Phat <- (diag(m)-Ahat)%*%Chat%*%t(diag(m)-Ahat)
+ ##diag(Phat) <- abs(diag(Phat))
+ ## Guarantee PD-matrix:
+ Phat[is.nan(Phat) | is.na(Phat)] <- 0
+ diag(Phat)[diag(Phat)==0] <- 1
+ eig <- eigen(Phat)
+ L <- abs(eig$values); L[L<1e-3] <- 1e-3
+ Phat <- eig$vectors%*%diag(L,ncol=ncol(eig$vectors))%*%t(eig$vectors)
+
+ Debug(list("start=",start), debug)
+ start <- pars(x, A=t(Ahat*A0), P=(Phat*P0))
+ names(start) <- coef(x, silent=TRUE, fixed=FALSE, mean=FALSE)[seq_len(length(start))]
+ res <- startmean(x,start,mu)
+ res[!is.finite(res) | is.nan(res) | is.na(res)] <- 1
+ res
+}
+
+###}}} startvalues
diff --git a/R/subgraph.R b/R/subgraph.R
new file mode 100644
index 0000000..0b70541
--- /dev/null
+++ b/R/subgraph.R
@@ -0,0 +1,19 @@
+subgraph <- function(g,from,to,Tree=new("graphNEL",node=c(to,from),edgemode="directed"),...) {
+ adjnodes <- graph::adj(g,from)[[1]]
+ newnodes <- !(adjnodes %in% graph::nodes(Tree))
+ if (length(adjnodes)==0)
+ return(Tree)
+ for (v in adjnodes) {
+ if (v==to) {
+ Tree <- graph::addEdge(from, v, Tree)
+ }
+ re1 <- graph::acc(g,v)[[1]] ## Reachable nodes from v
+ if ((to %in% names(re1)[re1>0])) {
+ if (!(v %in% graph::nodes(Tree)))
+ Tree <- graph::addNode(v,Tree)
+ Tree <- graph::addEdge(from, v, Tree)
+ Tree <- path(g,v,to,Tree)
+ }
+ }
+ return(Tree)
+}
diff --git a/R/subset.R b/R/subset.R
new file mode 100644
index 0000000..46fe13d
--- /dev/null
+++ b/R/subset.R
@@ -0,0 +1,54 @@
+##' Extract subset of latent variable model
+##'
+##' Extract measurement models or user-specified subset of model
+##'
+##'
+##' @aliases measurement
+##' @param x \code{lvm}-object.
+##' @param vars Character vector or formula specifying variables to include in
+##' subset.
+##' @param \dots Additional arguments to be passed to the low level functions
+##' @return A \code{lvm}-object.
+##' @author Klaus K. Holst
+##' @keywords models regression
+##' @examples
+##'
+##' m <- lvm(c(y1,y2)~x1+x2)
+##' subset(m,~y1+x1)
+##'
+##' @export
+##' @method subset lvm
+subset.lvm <- function(x, vars, ...) {
+ if (missing(vars)) return(x)
+ if (inherits(vars,"formula")) vars <- all.vars(vars)
+ if (!all(vars%in%vars(x))) stop("Not a subset of model")
+ latentvars <- intersect(vars,latent(x))
+ ## g0 <- subGraph(vars, Graph(x))
+ ## res <- graph2lvm(g0)
+ res <- lvm(vars)
+ M <- t(x$M[vars,vars,drop=FALSE])
+ for (i in seq_len(nrow(M))) {
+ if (any(M[,i]==1)) {
+ res <- regression(res, y=rownames(M)[M[,i]==1], x=rownames(M)[i], ...)
+ }
+ }
+ if (length(latentvars)>0)
+ latent(res) <- latentvars
+ res$cov[vars,vars] <- x$cov[vars,vars]
+ ## Fixed parameters:
+ res$par[vars,vars] <- x$par[vars,vars]
+ res$fix[vars,vars] <- x$fix[vars,vars]
+ res$covpar[vars,vars] <- x$covpar[vars,vars]
+ res$covfix[vars,vars] <- x$covfix[vars,vars]
+ res$mean[vars] <- x$mean[vars]
+ res$attributes <- x$attributes
+ for (i in seq_along(x$attributes)) {
+ val <- x$attributes[[i]]
+ if (length(val)>0) {
+ val <- val[intersect(vars,names(val))]
+ res$attributes[[i]] <- val
+ }
+ }
+ index(res) <- reindex(res)
+ return(res)
+}
diff --git a/R/summary.R b/R/summary.R
new file mode 100644
index 0000000..8900918
--- /dev/null
+++ b/R/summary.R
@@ -0,0 +1,183 @@
+###{{{ summary.lvm
+
+##' @export
+`summary.lvm` <-
+function(object,...) {
+ k <- length(vars(object))
+ ## cat("Latent Variable Model \n\twith: ", k, " variables.\n", sep="");
+ print(object,print.transform=FALSE,...)
+ if (length(transform(object))>0) {
+ cat("\nTransformations:\n")
+ print(transform(object),quote=FALSE,...)
+ }
+ cat("\n")
+ if (length(index(object))>0)
+ cat("Number of free parameters: ", with(index(object),npar+npar.mean+npar.ex),"\n", sep="")
+
+ if (k==0)
+ return()
+ ##cat("Npar=", index(object)$npar, "+", index(object)$npar.mean, "\n", sep="")
+ cat("\n")
+ print(regression(object),...)
+ print(covariance(object),...)
+ print(intercept(object),...)
+ if (length(object$exfix)>0) {
+ cat("Additional parameters:\n")
+ val <- unlist(object$exfix)
+ M <- rbind(val); colnames(M) <- names(val)
+ rownames(M) <- " "
+ print(M,quote=FALSE,...)
+ }
+ if (length(constrain(object))>0) {
+ cat("Non-linear constraints:\n")
+ print(constrain(object),quote=FALSE,...)
+ }
+ ## printmany(object$cov, printmany(object$covpar, object$covfix, name1="Labels:", name2="Fixed:", print=FALSE), name1="covariance:")
+ cat("\n")
+}
+
+###}}} summary.lvm
+
+###{{{ summary.lvmfit
+
+##' @export
+`summary.lvmfit` <-
+function(object,std="xy", level=9, labels=2, ...) {
+ cc <- CoefMat(object,labels=labels,std=std,level=level,...)
+ mycoef <- coef(object,level=9)
+ nlincon <- attributes(mycoef)$nlincon
+ nonexo <- setdiff(vars(object),index(Model(object))$exogenous)
+ attributes(mycoef) <- attributes(mycoef)[1:2]
+ mygof <- object$opt$summary.message
+ if (is.null(mygof)) {
+ mygof <- gof
+ }
+ if (class(object)[1]=="lvm.missing") {
+ nn <- unlist(lapply(object$multigroup$data, nrow))
+ nc <- nn[object$cc]
+ if (length(nc)==0) nc <- 0
+ ngroup <- object$multigroup$ngroup
+ res <- list(object=object, coef=mycoef, coefmat=cc, nlincon=nlincon, gof=mygof(object), n=sum(nn), nc=nc, ngroup=ngroup,
+ varmat=modelVar(object)$P[nonexo,nonexo], latent=latent(object), opt=object$opt, vcov=vcov(object), estimator=object$estimator, rsq=rsq(object))
+ } else {
+ n <- nrow(model.frame(object))
+ if (is.null(n)) n <- model.frame(object)$n
+ res <- list(coef=mycoef, coefmat=cc, nlincon=nlincon, gof=mygof(object), n=n, nc=n, latent=latent(object),
+ opt=object$opt, vcov=vcov(object), estimator=object$estimator, rsq=rsq(object))##, varmat=modelVar(object)$P[nonexo,nonexo])
+ }
+ class(res) <- "summary.lvmfit"
+ res
+}
+
+##' @export
+print.summary.lvmfit <- function(x,varmat=TRUE,...) {
+ if (!is.null(x$control$method)) {
+ l2D <- sum(x$opt$grad^2)
+ rnkV <- qr(x$vcov)$rank
+ if (l2D>1e-2) warning("Possible problems with convergence!")
+ cat("||score||^2=",l2D,"\n",sep="")
+ np <- nrow(x$vcov)
+ if (rnkV<np) warning("Possible problems with identification (rank(informaion)=",rnkV,"<",np,"!")
+ }
+ cat("Latent variables:", x$latent, "\n")
+ cat("Number of rows in data=",x$n,sep="")
+ if (x$nc!=x$n) {
+ cat(" (",x$nc," complete cases, ", x$ngroup, " groups)",sep="")
+ }; cat("\n")
+ printline()
+ print(x$coefmat,quote=FALSE,right=TRUE)
+## if (varmat) {
+## cat("\nResidual covariance matrix:\n")
+## print(x$varmat)
+## }
+ if (!is.null(x$nlincon)) {
+ cat("\nNon-linear constraints:\n")
+ printCoefmat(x$nlincon,signif.stars=FALSE)
+ }
+ printline()
+ cat("Estimator:",x$estimator,"\n")
+ printline()
+ if (!is.null(x$gof)) {
+ if (class(x$gof)[1]=="list") {
+ for (i in x$gof) {
+ print(i)
+ }
+ } else {
+ print(x$gof,optim=FALSE)
+ }
+ printline()
+ }
+ if (!is.null(x$rsq)) {
+ if (!is.list(x$rsq)) {
+ cat("R-square\n")
+ print(round(x$rsq,3),quote=FALSE)
+ } else {
+ for (i in seq_len(length(x$rsq))) {
+ cat(names(x$rsq)[i],"\n")
+ print(round(x$rsq[[i]],3),quote=FALSE)
+ }
+ }
+ }
+ invisible(x)
+}
+
+##' @export
+coef.summary.lvmfit <- function(object,...) object$coef
+
+###}}} summary.lvmfit
+
+###{{{ summary.multigroupfit
+
+##' @export
+summary.multigroupfit <- function(object,groups=NULL,...) {
+ if (is.null(groups) | length(groups)==0) {
+ if (object$model$missing) {
+ groups <- object$model$complete
+ if (length(groups)==0)
+ groups <- seq_len(object$model0$ngroup)
+ } else {
+ groups <- seq_len(object$model$ngroup)
+ }
+ }
+ cc <- CoefMat.multigroupfit(object,groups=groups,...)
+ res <- list(coef=coef(object,level=2,groups=groups,...), object=object, coefmat=cc, gof=gof(object), object=object, opt=object$opt, latent=object$latent, estimator=object$estimator)
+ class(res) <- "summary.multigroupfit"
+ res
+}
+
+##' @export
+print.summary.multigroupfit <- function(x,...) {
+ l2D <- sum(x$opt$grad^2)
+ if (l2D>1e-2) warning("Possible problems with convergence!")
+ cat("||score||^2=",l2D,"\n")
+ cat("Latent variables:", x$latent, "\n")
+ print(x$object,...)
+ ##print(x$coefmat,quote=FALSE,right=TRUE)
+ printline()
+ if (!is.null(attributes(x$coefmat)$nlincon)) {
+ cat("Non-linear constraints:\n")
+ print(attributes(x$coefmat)$nlincon)
+ printline()
+ }
+ cat("Estimator:",x$estimator,"\n")
+ printline()
+ if (!is.null(x$gof)) {
+ print(x$gof)
+ printline()
+ }
+ invisible(x)
+}
+
+###}}} summary.multigroupfit
+
+###{{{ summary.multigroup
+
+##' @export
+summary.multigroup <- function(object,...) {
+ for (m in object$lvm)
+ print(m,...)
+ print(object)
+ invisible(object)
+}
+
+###}}}
diff --git a/R/timedep.R b/R/timedep.R
new file mode 100644
index 0000000..bb6c5aa
--- /dev/null
+++ b/R/timedep.R
@@ -0,0 +1,85 @@
+##' Add time-varying covariate effects to model
+##'
+##' @title Time-dependent parameters
+##' @param object Model
+##' @param formula Formula with rhs specifying time-varying covariates
+##' @param rate Optional rate parameters. If given as a vector this
+##' parameter is interpreted as the raw (baseline-)rates within each
+##' time interval defined by \code{timecut}. If given as a matrix the
+##' parameters are interpreted as log-rates (and log-rate-ratios for
+##' the time-varying covariates defined in the formula).
+##' @param timecut Time intervals
+##' @param type Type of model (default piecewise constant intensity)
+##' @param ... Additional arguments to lower level functions
+##' @author Klaus K. Holst
+##' @aliases timedep timedep<-
+##' @export
+##' @examples
+##'
+##' ## Piecewise constant hazard
+##' m <- lvm(y~1)
+##' m <- timedep(m,y~1,timecut=c(0,5),rate=c(0.5,0.3))
+##'
+##' \dontrun{
+##' d <- sim(m,1e4); d$status <- TRUE
+##' dd <- mets::lifetable(Surv(y,status)~1,data=d,breaks=c(0,5,10));
+##' exp(coef(glm(events ~ offset(log(atrisk)) + -1 + interval, dd, family=poisson)))
+##' }
+##'
+##'
+##' ## Piecewise constant hazard and time-varying effect of z1
+##' m <- lvm(y~1)
+##' distribution(m,~z1) <- ones.lvm(0.5)
+##' R <- log(cbind(c(0.2,0.7,0.9),c(0.5,0.3,0.3)))
+##' m <- timedep(m,y~z1,timecut=c(0,3,5),rate=R)
+##'
+##' \dontrun{
+##' d <- sim(m,1e4); d$status <- TRUE
+##' dd <- mets::lifetable(Surv(y,status)~z1,data=d,breaks=c(0,3,5,Inf));
+##' exp(coef(glm(events ~ offset(log(atrisk)) + -1 + interval+z1:interval, dd, family=poisson)))
+##' }
+##'
+##'
+##'
+##' ## Explicit simulation of time-varying effects
+##' m <- lvm(y~1)
+##' distribution(m,~z1) <- ones.lvm(0.5)
+##' distribution(m,~z2) <- binomial.lvm(p=0.5)
+##' #variance(m,~m1+m2) <- 0
+##' #regression(m,m1[m1:0] ~ z1) <- log(0.5)
+##' #regression(m,m2[m2:0] ~ z1) <- log(0.3)
+##' regression(m,m1 ~ z1,variance=0) <- log(0.5)
+##' regression(m,m2 ~ z1,variance=0) <- log(0.3)
+##' intercept(m,~m1+m2) <- c(-0.5,0)
+##' m <- timedep(m,y~m1+m2,timecut=c(0,5))
+##'
+##' \dontrun{
+##' d <- sim(m,1e5); d$status <- TRUE
+##' dd <- mets::lifetable(Surv(y,status)~z1,data=d,breaks=c(0,5,Inf))
+##' exp(coef(glm(events ~ offset(log(atrisk)) + -1 + interval + interval:z1, dd, family=poisson)))
+##' }
+timedep <- function(object,formula,rate,timecut,type="coxExponential.lvm",...) {
+ if (missing(timecut)) stop("'timecut' needed")
+ ##if (inherits(formula,"formula"))
+ ff <- getoutcome(formula)
+ simvars <- attributes(ff)$x
+ if (is.null(object$attributes$simvar)) {
+ object$attributes$simvar <- list(simvars)
+ names(object$attributes$simvar) <- ff
+ object$attributes$timedep <- object$attributes$simvar
+ } else {
+ object$attributes$simvar[[ff]] <- simvars
+ object$attributes$timedep[[ff]] <- simvars
+ }
+ if (missing(rate)) rate <- rep(1,length(timecut))
+
+ args <- list(timecut=timecut,rate=rate,...)
+ covariance(object,ff) <- 1
+ distribution(object,ff) <- do.call(type,args)
+ return(object)
+}
+
+##' @export
+"timedep<-" <- function(object,...,value) {
+ timedep(object,value,...)
+}
diff --git a/R/toformula.R b/R/toformula.R
new file mode 100644
index 0000000..ed02fa0
--- /dev/null
+++ b/R/toformula.R
@@ -0,0 +1,37 @@
+##' Converts strings to formula
+##'
+##' Converts a vector of predictors and a vector of responses (characters) i#nto
+##' a formula expression.
+##'
+##'
+##' @param y vector of predictors
+##' @param x vector of responses
+##' @return An object of class \code{formula}
+##' @author Klaus K. Holst
+##' @seealso \code{\link{as.formula}},
+##' @keywords models utilities
+##' @examples
+##'
+##' toformula(c("age","gender"), "weight")
+##'
+##' @export
+toformula <- function (y = ".", x = ".")
+{
+ xst <- x[1]
+ xn <- length(x)
+ if (xn > 1)
+ for (i in 2:length(x)) {
+ xst <- paste(xst, "+", x[i])
+ }
+ yst <- y[1]
+ yn <- length(y)
+ if (yn > 1) {
+ yst <- paste0("c(", yst)
+ for (i in 2:length(y)) {
+ yst <- paste0(yst, ", ", y[i])
+ }
+ yst <- paste0(yst, ")")
+ }
+ ff <- paste(yst, "~", xst)
+ return(as.formula(ff))
+}
diff --git a/R/tr.R b/R/tr.R
new file mode 100644
index 0000000..4f12068
--- /dev/null
+++ b/R/tr.R
@@ -0,0 +1,29 @@
+##' Trace operator
+##'
+##' Calculates the trace of a square matrix.
+##' @param x Square numeric matrix
+##' @param \dots Additional arguments to lower level functions
+##' @return \code{numeric}
+##' @author Klaus K. Holst
+##' @seealso \code{\link{crossprod}}, \code{\link{tcrossprod}}
+##' @keywords math algebra
+##' @examples
+##'
+##' tr(diag(1:5))
+##' @export
+"tr" <- function(x,...) UseMethod("tr")
+
+##' @export
+`tr.matrix` <-
+function(x,na.rm=FALSE,...) {
+ if (length(x)==1)
+ return(x)
+ n <- nrow(x)
+ if (!n)
+ stop("0 x 0 matrix")
+ if (n != ncol(x))
+ stop("non-square matrix")
+ if (!na.rm && any(!is.finite(x)))
+ stop("infinite or missing values")
+ return(sum(diag(x),na.rm=na.rm))
+}
diff --git a/R/transform.R b/R/transform.R
new file mode 100644
index 0000000..5c6b9bb
--- /dev/null
+++ b/R/transform.R
@@ -0,0 +1,99 @@
+##' @export
+"transform<-" <- function(`_data`,...,value) UseMethod("transform<-")
+
+##' @export
+"transform<-.lvm" <- function(`_data`,formula=NULL,...,value) {
+ transform(`_data`,formula,value,...)
+}
+
+##' @export
+print.transform.lvm <- function(x,...) {
+ for (i in seq_along(x)) {
+ cat("Variable: ", names(x)[i],"\n",sep="")
+ cat("Transformation: (",paste0(x[[i]]$x,collapse=","),") -> ",sep="")
+ print(x[[i]]$fun)
+ cat("\n")
+ }
+ invisible(x)
+}
+
+##' @export
+"transform.lvm" <- function(`_data`,formula,fun,post=TRUE,y,x,...) {
+ if (missing(formula)) {
+ if (length(tr <- `_data`$attributes$transform)==0) {
+ return(NULL)
+ }
+ return(structure(`_data`$attributes$transform,class="transform.lvm"))
+ }
+
+ if (!missing(y) && !missing(x)) {
+ xx <- x
+ } else {
+ if (is.character(formula)) {
+ y <- NULL; xx <- formula
+ } else {
+ y <- getoutcome(formula)
+ xx <- attributes(y)$x
+ }
+ }
+ if (length(xx)==0) { xx <- y; y <- NULL }
+ if (length(y)==0) {
+ if (post) {
+ `_data`$constrainY[xx] <- NULL
+ `_data`$constrain[xx] <- NULL
+ if (is.null(`_data`$attributes$selftransform))
+ `_data`$attributes$selftransform <- list()
+ `_data`$attributes$selftransform[[xx]] <- fun
+ return(`_data`)
+ }
+ `_data`$attributes$selftransform[xx] <- NULL
+ constrain(`_data`,xx,y,...) <- fun
+ return(`_data`)
+ }
+
+
+ `_data`$attributes$selftransform[y] <- NULL
+ addvar(`_data`) <- y
+ intercept(`_data`,y) <- 0; covariance(`_data`,y) <- 0
+ if (is.null(`_data`$attributes$transform))
+ `_data`$attributes$transform <- list()
+ if (is.null(fun)) `_data`$attributes$transform[y] <- NULL
+ else {
+ if (length(y)>1) {
+ if (is.null(`_data`$attributes$multitransform))
+ `_data`$attributes$multitransform <- list()
+ `_data`$attributes$multitransform
+ for (yi in y) {
+ `_data`$attributes$transform[yi] <- NULL
+ }
+ rmidx <- c()
+ for (i in seq_along(`_data`$attributes$multitransform)) {
+ l <- `_data`$attributes$multitransform[[i]]
+ if (any(y%in%letters)) rmidx <- c(rmidx,i)
+ }
+ if (length(rmidx)>0) `_data`$attributes$transform[rmidx] <- NULL
+ `_data`$attributes$multitransform <- c(`_data`$attributes$multitransform,
+ list(list(fun=fun,y=y,x=xx)))
+ } else {
+ `_data`$attributes$transform[[y]] <- list(fun=fun,x=xx)
+ }
+ }
+ return(`_data`)
+}
+
+
+addhook("plothook.transform","plot.post.hooks")
+
+plothook.transform <- function(x,...) {
+ trans <- x$attributes$transform
+ transnames <- names(trans)
+ for (v in transnames) {
+ xx <- trans[[v]][["x"]]
+ if (length(xx)>0) {
+ x <- regression(x,x=xx,y=v)
+ edgelabels(x,from=xx,to=v,col="gray70") <- ""
+ }
+ }
+ return(x)
+}
+
diff --git a/R/trim.R b/R/trim.R
new file mode 100644
index 0000000..7633744
--- /dev/null
+++ b/R/trim.R
@@ -0,0 +1,13 @@
+##' Trim tring of (leading/trailing/all) white spaces
+##' @title Trim tring of (leading/trailing/all) white spaces
+##' @param x String
+##' @param all Trim all whitespaces?
+##' @param \dots additional arguments to lower level functions
+##' @author Klaus K. Holst
+##' @export
+trim <- function(x,all=FALSE,...) {
+ ## y <- gsub("^ .", "", x) # remove leading white space
+ ## y <- gsub(". $", "", x) # remove trailing white space
+ if (!all) return(gsub("^\\s+|\\s+$", "", x))
+ return(gsub(" ","",x,fixed=TRUE))
+}
diff --git a/R/twostage.R b/R/twostage.R
new file mode 100644
index 0000000..1889457
--- /dev/null
+++ b/R/twostage.R
@@ -0,0 +1,374 @@
+twostagelvm <- function(object, model2,
+ formula=NULL, model.object=FALSE, predict.fun=NULL,
+ type="quadratic",...) {
+ if (!inherits(model2,c("lvm"))) stop("Expected lava object ('lvm',...)")
+ if (!is.null(formula)) {
+ model2 <- nonlinear(model2, formula, type=type)
+ }
+ nonlin <- NULL
+ val <- nonlinear(model2)
+ if (is.null(formula) && length(val)==0 && length(nonlinear(object))>0) {
+ val <- nonlinear(object)
+ }
+ xnam <- c()
+ if (length(val)>0) {
+ predict.fun <- NULL
+ for (i in seq_along(val)) {
+ if (!all(val[[i]]$newx%in%xnam)) {
+ xnam <- union(xnam,val[[i]]$newx)
+ predict.fun <- c(predict.fun, list(val[[i]]$pred))
+ }
+ model2$attributes$nonlinear <- NULL
+ if (inherits(object,"lvmfit")) {
+ object$model$attributes$nonlinear <- NULL
+ }
+ model2 <- regression(model2, to=names(val)[i], from=val[[i]]$newx)
+ }
+ nonlin <- val
+ }
+ if (model.object) {
+ model <- Model(object) %++% model2
+ cl <- match.call(expand.dots=TRUE)
+ cl[[1]] <- twostage
+ cl$object <- object
+ cl$model2 <- model2
+ cl$predict.fun <- predict.fun
+ cl["model.object"] <- NULL
+ return(structure(list(model=model, nonlinear=nonlin, call=cl), class="twostage.lvm"))
+ }
+ res <- c(list(object=object, model2=model2), list(...))
+ res$predict.fun <- predict.fun
+ res$nonlinear <- val
+ return(res)
+}
+
+
+uhat <- function(p=coef(model1), model1, data=model.frame(model1), nlobj) {
+ if (!is.function(nlobj)) {
+ predict.fun <- lapply(nlobj, function(x) x[["pred"]])
+ } else { predict.fun <- nlobj }
+ if (inherits(model1, "lvm.mixture")) {
+ Pr <- predict(model1, p=p, data=data)
+ P <- list(mean=Pr, var=attr(Pr,"cond.var"))
+ } else {
+ P <- predictlvm(model1, p=p, data=data)
+ }
+ if (is.list(predict.fun)) {
+ unams <- lapply(nlobj,function(x) x$newx)
+ unam <- unique(unlist(unams))
+ args <- list(P$mean, P$var, data)
+ res <- matrix(0, NROW(data), ncol=length(unam))
+ colnames(res) <- unam
+ for (i in seq_along(predict.fun)) {
+ res[, unams[[i]]] <- do.call(predict.fun[[i]], args)
+ }
+ return(res)
+ }
+ return(cbind(predict.fun(P$mean, P$var, model.frame(model1))))
+}
+
+
+##' Two-stage estimator
+##'
+##' Generic function.
+##'
+##' @seealso twostage.lvm twostage.lvmfit twostage.lvm.mixture twostage.estimate
+##' @export
+##' @param object Model object
+##' @param ... Additional arguments to lower level functions
+"twostage" <- function(object,...) UseMethod("twostage")
+
+##' Two-stage estimator (non-linear SEM)
+##'
+##' Two-stage estimator for non-linear structural equation models
+##' @export
+##' @param object Stage 1 measurement model
+##' @param model2 Stage 2 SEM
+##' @param data data.frame
+##' @param predict.fun Prediction of latent variable
+##' @param id1 Optional id-variable (stage 1 model)
+##' @param id2 Optional id-variable (stage 2 model)
+##' @param all If TRUE return additional output (naive estimates)
+##' @param formula optional formula specifying non-linear relation
+##' @param std.err If FALSE calculations of standard errors will be skipped
+##' @param ... Additional arguments to lower level functions
+##' @aliases twostage.lvmfit twostage.lvm twostage.lvm.mixture twostage.estimate nonlinear nonlinear<-
+##' @examples
+##' m <- lvm(c(x1,x2,x3)~f1,f1~z,
+##' c(y1,y2,y3)~f2,f2~f1+z)
+##' latent(m) <- ~f1+f2
+##' d <- simulate(m,100,p=c("f2,f2"=2,"f1,f1"=0.5),seed=1)
+##'
+##' ## Full MLE
+##' ee <- estimate(m,d)
+##'
+##' ## Manual two-stage
+##' \dontrun{
+##' m1 <- lvm(c(x1,x2,x3)~f1,f1~z); latent(m1) <- ~f1
+##' e1 <- estimate(m1,d)
+##' pp1 <- predict(e1,f1~x1+x2+x3)
+##'
+##' d$u1 <- pp1[,]
+##' d$u2 <- pp1[,]^2+attr(pp1,"cond.var")[1]
+##' m2 <- lvm(c(y1,y2,y3)~eta,c(y1,eta)~u1+u2+z); latent(m2) <- ~eta
+##' e2 <- estimate(m2,d)
+##' }
+##'
+##' ## Two-stage
+##' m1 <- lvm(c(x1,x2,x3)~f1,f1~z); latent(m1) <- ~f1
+##' m2 <- lvm(c(y1,y2,y3)~eta,c(y1,eta)~u1+u2+z); latent(m2) <- ~eta
+##' pred <- function(mu,var,data,...)
+##' cbind("u1"=mu[,1],"u2"=mu[,1]^2+var[1])
+##' (mm <- twostage(m1,model2=m2,data=d,predict.fun=pred))
+##'
+##' if (interactive()) {
+##' pf <- function(p) p["eta"]+p["eta~u1"]*u + p["eta~u2"]*u^2
+##' plot(mm,f=pf,data=data.frame(u=seq(-2,2,length.out=100)),lwd=2)
+##' }
+##'
+##' ## Splines
+##' f <- function(x) cos(2*x)+x+-0.25*x^2
+##' m <- lvm(x1+x2+x3~eta1, y1+y2+y3~eta2, latent=~eta1+eta2)
+##' functional(m, eta2~eta1) <- f
+##' d <- sim(m,500,seed=1,latent=TRUE)
+##' m1 <- lvm(x1+x2+x3~eta1,latent=~eta1)
+##' m2 <- lvm(y1+y2+y3~eta2,latent=~eta2)
+##' mm <- twostage(m1,m2,formula=eta2~eta1,type="spline")
+##' if (interactive()) plot(mm)
+##'
+##' nonlinear(m2,type="quadratic") <- eta2~eta1
+##' a <- twostage(m1,m2,data=d)
+##' if (interactive()) plot(a)
+##'
+##' kn <- c(-1,0,1)
+##' nonlinear(m2,type="spline",knots=kn) <- eta2~eta1
+##' a <- twostage(m1,m2,data=d)
+##' x <- seq(-3,3,by=0.1)
+##' y <- predict(a, newdata=data.frame(eta1=x))
+##'
+##' if (interactive()) {
+##' plot(eta2~eta1, data=d)
+##' lines(x,y, col="red", lwd=5)
+##'
+##' p <- estimate(a,f=function(p) predict(a,p=p,newdata=x))$coefmat
+##' plot(eta2~eta1, data=d)
+##' lines(x,p[,1], col="red", lwd=5)
+##' confband(x,lower=p[,3],upper=p[,4],center=p[,1], polygon=TRUE, col=Col(2,0.2))
+##'
+##' l1 <- lm(eta2~splines::ns(eta1,knots=kn),data=d)
+##' p1 <- predict(l1,newdata=data.frame(eta1=x),interval="confidence")
+##' lines(x,p1[,1],col="green",lwd=5)
+##' confband(x,lower=p1[,2],upper=p1[,3],center=p1[,1], polygon=TRUE, col=Col(3,0.2))
+##' }
+##'
+##' \dontrun{ ## Reduce timing
+##' ## Cross-validation example
+##' ma <- lvm(c(x1,x2,x3)~u,latent=~u)
+##' ms <- functional(ma, y~u, f=function(x) -.4*x^2)
+##' d <- sim(ms,500)#,seed=1)
+##' ea <- estimate(ma,d)
+##'
+##' mb <- lvm()
+##' mb1 <- nonlinear(mb,type="linear",y~u)
+##' mb2 <- nonlinear(mb,type="quadratic",y~u)
+##' mb3 <- nonlinear(mb,type="spline",knots=c(-3,-1,0,1,3),y~u)
+##' mb4 <- nonlinear(mb,type="spline",knots=c(-3,-2,-1,0,1,2,3),y~u)
+##' ff <- lapply(list(mb1,mb2,mb3,mb4),
+##' function(m) function(data,...) twostage(ma,m,data=data,st.derr=FALSE))
+##' a <- cv(ff,data=d,rep=1,mc.cores=1)
+##' a
+##'}
+twostage.lvmfit <- function(object, model2, data=NULL,
+ predict.fun=function(mu,var,data,...)
+ cbind("u1"=mu[,1],"u2"=mu[,1]^2+var[1]),
+ id1=NULL, id2=NULL, all=FALSE,
+ formula=NULL, std.err=TRUE,
+ ...) {
+ val <- twostagelvm(object=object,model2=model2,predict.fun=predict.fun,
+ id1=id1, id2=id2, all=all, formula=formula, ...)
+ object <- val$object
+ model2 <- val$model2
+ predict.fun <- val$predict.fun
+ p1 <- coef(object)
+ if (length(val$nonlinear)==0) {
+ val$nonlinear <- predict.fun
+ }
+ pp <- uhat(p1,object,nlobj=val$nonlinear)
+ newd <- data
+ newd[,colnames(pp)] <- pp
+
+ model2 <- estimate(model2,data=newd,...)
+ p2 <- coef(model2)
+ if (std.err) {
+ if (is.null(id1)) id1 <- seq(nrow(model.frame(object)))
+ if (is.null(id2)) id2 <- seq(nrow(model.frame(model2)))
+ model1 <- object
+ if (!inherits(object,"estimate")) {
+ model1 <- estimate(NULL,coef=p1,id=id1,iid=iid(object))
+ }
+
+ e2 <- estimate(model2, id=id2)
+ U <- function(alpha=p1,beta=p2) {
+ pp <- uhat(alpha,object,nlobj=val$nonlinear)
+ newd <- model.frame(model2)
+ newd[,colnames(pp)] <- pp
+ score(model2,p=beta,data=newd)
+ }
+ Ia <- -numDeriv::jacobian(function(p) U(p),p1)
+ stacked <- stack(model1,e2,Ia)
+ } else {
+ e2 <- estimate(coef=p2,vcov=NA)
+ }
+ coef <- model2$coef
+ res <- model2
+ res$estimator <- "generic"
+
+ if (std.err) {
+ res[names(stacked)] <- stacked
+ cc <- stacked$coefmat[,c(1,2)];
+ cc <- cbind(cc,cc[,1]/cc[,2],stacked$coefmat[,5])
+ coef[,] <- cc
+ res$coef <- coef
+ res$vcov <- vcov(stacked)
+ if (all) {
+ res$naive <- model2
+ res$naive.robust <- e2
+ }
+ } else {
+ res$coef[,-1] <- NA
+ }
+ res$fun <- predict.fun
+ res$estimate1 <- object
+ res$estimate2 <- model2
+ res$nonlinear <- val$nonlinear
+ structure(res,class=c("twostage.lvmfit","measurement.error","lvmfit","estimate"))
+}
+
+##' @export
+estimate.twostage.lvm <- function(x,data,...) {
+ if (missing(data)) stop("'data' needed")
+ m1 <- x$call$object
+ m2 <- x$call$model2
+ nl <- x$nonlinear
+ if (!inherits(m1,"lvmfit")) {
+ args <- c(list(x=m1, data=data), list(...))
+ args <- args[intersect(names(as.list(base::args(estimate.lvm))),names(args))]
+ m1 <- do.call(estimate, args)
+ }
+ m2$attributes$nonlinear <- nl
+ twostage(object=m1,model2=m2,data=data,predict.fun=nl[[1]]$pred,...)
+}
+
+##' @export
+twostage.twostage.lvm <- function(object,...) estimate.twostage.lvm(object,...)
+
+
+##' @export
+twostage.lvm <- function(object,model2,data=NULL, ...) {
+ if (is.null(data)) {
+ return(twostagelvm(object=object, model2=model2, model.object=TRUE, ...))
+ }
+ args <- c(list(x=object, data=data), list(...))
+ args <- args[intersect(names(as.list(base::args(estimate.lvm))),names(args))]
+ e1 <- do.call(estimate, args)
+ twostage(object=e1,model2=model2,data=data, ...)
+}
+
+##' @export
+twostage.lvm.mixture <- twostage.lvmfit
+
+##' @export
+twostage.estimate <- twostage.lvmfit
+
+##' @export
+print.twostage.lvm <- function(x,...) {
+ printline()
+ cat("Model 1:\n")
+ print(Model(x$call$object))
+ printline()
+ cat("Model 2:\n")
+ print(Model(x$call$model2))
+
+}
+
+##' @export
+plot.twostage.lvm <- function(x,...) {
+ model <- x$model
+ m1 <- Model(x$call$object)
+ m2 <- x$call$model2
+ nl <- nonlinear(x)
+ model <- regression(model, to=nl[[1]]$newx, from=nl[[1]]$x)
+ elist <- edgeList(m1)
+ vlist <- vars(m1)
+ model <- beautify(model)
+ for (i in seq_len(nrow(elist))) {
+ e <- toformula(y=vlist[elist[i,2]],x=vlist[elist[i,1]])
+ edgelabels(model, e, cex=0.7) <- 1
+ }
+ elist <- edgeList(m2)
+ vlist <- vars(m2)
+ for (i in seq_len(nrow(elist))) {
+ e <- toformula(vlist[elist[i,2]],vlist[elist[i,1]])
+ edgelabels(model, e, cex=0.7) <- 2
+ }
+ nodecolor(model, nl[[1]]$newx) <- "gray"
+ for (xx in nl[[1]]$newx) {
+ e <- toformula(y=names(nl)[1],x=xx)
+ edgelabels(model,e,col="gray", cex=0.7, lty=1) <- 2
+ }
+ for (xx in nl[[1]]$newx) {
+ e <- toformula(y=xx,x=nl[[1]]$x)
+ edgelabels(model,e,col="gray", cex=0.7, lty=2) <- ""
+ }
+ plot(model, ...)
+}
+
+
+##' @export
+predict.twostage.lvmfit <- function(object,
+ newdata,
+ variable=names(nonlinear(object)),
+ p=coef(object),
+ type=c("model2","latent"),
+ ...) {
+ if (missing(newdata)) stop("provide data for prediction")
+ nl <- nonlinear(object)
+ unam <- unique(unlist(lapply(nl,function(x) x$x)))
+ if (is.vector(newdata) || all(colnames(newdata)%in%unam))
+ type <- "latent"
+ if (tolower(type[1])%ni%c("latent")) {
+ p1 <- coef(object$estimate1)
+ pred1 <- uhat(p1, data=newdata, object$estimate1, nlobj=nl)
+ if (tolower(type[1])==c("model1"))
+ return(pred1)
+ newdata <- as.data.frame(newdata)
+ newdata[,colnames(pred1)] <- pred1
+ pred <- predict(object$estimate2,...,p=p,data=newdata)
+ attr(pred,"p") <- NULL
+ attr(pred,"e") <- NULL
+ return(pred)
+ }
+
+ ## Association between predicted latent variables and child nodes:
+ if (is.numeric(variable)) {
+ variable <- names(nonlinear(object))[variable]
+ }
+ nl <- nl[variable]
+ res <- matrix(nrow=NROW(newdata),ncol=length(nl))
+ colnames(res) <- names(nl)
+ ##unam <- unique(unlist(lapply(nl, function(x) x$newx)))
+ #colnames(res) <- unam
+ for (i in seq_along(nl)) {
+ pnam <- c(variable,paste0(variable,"~",nl[[i]]$newx))
+ pidx <- match(pnam,names(coef(object)))
+ b <- p[pidx]
+ F <- nl[[i]]$f
+ if (is.vector(newdata)) {
+ res[,i] <- F(b,newdata)
+ } else {
+ res[,i] <- F(b,newdata[,nl[[i]]$x])
+ }
+ }
+ return(res)
+}
+
diff --git a/R/utils.R b/R/utils.R
new file mode 100644
index 0000000..606e878
--- /dev/null
+++ b/R/utils.R
@@ -0,0 +1,443 @@
+char2num <- function(x,...) {
+ idx <- grep("^[-]*[0-9\\.]+",x,perl=TRUE,invert=TRUE)
+ if (length(idx)>0) x[idx] <- NA
+ as.numeric(x)
+}
+
+###{{{ substArg
+
+substArg <- function(x,env,...) {
+ if (!missing(env)) {
+ a <- with(env,substitute(x))
+# a <- substitute(x,environment(env))
+ } else {
+ a <- substitute(x)
+ }
+ myclass <- tryCatch(class(eval(a)),error=function(e) NULL)
+ if (is.null(myclass) || myclass=="name") {
+# if (is.null(myclass)) {
+ res <- unlist(sapply(as.character(a),
+ function(z) {
+ trimmed <- gsub(" ","",z,fixed=TRUE)
+ val <- strsplit(trimmed,"+",fixed=TRUE)
+ if (val[1]=="") val <- NULL
+ val
+ })); attributes(res)$names <- NULL
+ return(res)
+ }
+ return(eval(a))
+}
+
+## g <- function(zz,...) {
+## env=new.env(); assign("x",substitute(zz),env)
+## substArg(zz,env=env)
+## }
+## h <- function(x,...) {
+## env=new.env(); assign("x",substitute(x),env)
+## substArg(x,env=TRUE)
+## }
+
+###}}}
+
+###{{{ procrandomslope
+
+procrandomslope <- function(object,data=object$data,...) {
+ Xfix <- FALSE
+ xfix <- myfix <- list()
+ xx <- object
+ for (i in seq_len(object$ngroup)) {
+ x0 <- object$lvm[[i]]
+ data0 <- data[[i]]
+ xfix0 <- colnames(data0)[(colnames(data0)%in%parlabels(x0,exo=TRUE))]
+ xfix <- c(xfix, list(xfix0))
+ if (length(xfix0)>0) { ## Yes, random slopes
+ Xfix<-TRUE
+ }
+ xx$lvm[[i]] <- x0
+ }
+ if (Xfix) {
+ for (k in seq_len(object$ngroup)) {
+ x1 <- x0 <- object$lvm[[k]]
+ data0 <- data[[k]]
+ nrow <- length(vars(x0))
+ xpos <- lapply(xfix[[k]],function(y) which(regfix(x0)$labels==y))
+ colpos <- lapply(xpos, function(y) ceiling(y/nrow))
+ rowpos <- lapply(xpos, function(y) (y-1)%%nrow+1)
+ myfix0 <- list(var=xfix[[k]], col=colpos, row=rowpos)
+ myfix <- c(myfix, list(myfix0))
+ for (i in seq_along(myfix0$var))
+ for (j in seq_along(myfix0$col[[i]]))
+ regfix(x0,
+ from=vars(x0)[myfix0$row[[i]][j]],to=vars(x0)[myfix0$col[[i]][j]]) <-
+ colMeans(data0[,myfix0$var[[i]],drop=FALSE],na.rm=TRUE)
+ index(x0) <- reindex(x0,zeroones=TRUE,deriv=TRUE)
+ object$lvm[[k]] <- x0
+ yvars <- endogenous(x0)
+ #parkeep <- c(parkeep, parord[[k]][coef(x1,mean=TRUE)%in%coef(x0,mean=TRUE)])
+ }
+# parkeep <- sort(unique(parkeep))
+ object <- multigroup(object$lvm,data,fix=FALSE,exo.fix=FALSE)
+ }
+ return(list(model=object,fix=myfix))
+}
+
+###}}} procrandomslope
+
+###{{{ kronprod
+
+## ' Calculate matrix product with kronecker product
+## '
+## ' \deqn{(A\crossprod B) Y}
+## ' @title Calculate matrix product with kronecker product
+## ' @param A
+## ' @param B
+## ' @param Y
+## ' @author Klaus K. Holst
+kronprod <- function(A,B,Y) {
+ if (missing(Y)) {
+ ## Assume 'B'=Identity, (A otimes B)Y
+ k <- nrow(B)/ncol(A)
+ res <- rbind(apply(B,2,function(x) matrix(x,nrow=k)%*%t(A)))
+ return(res)
+ }
+ rbind(apply(Y,2,function(x) B%*%matrix(x,nrow=ncol(B))%*%t(A)))
+}
+
+###}}} kronprod
+
+###{{{ izero
+
+izero <- function(i,n) { ## n-1 zeros and 1 at ith entry
+ x <- rep(0,n); x[i] <- 1
+ x
+}
+
+###}}}
+
+###{{{ Debug
+
+`Debug` <-
+ function(msg, cond=lava.options()$debug) {
+ if (cond)
+ print(paste(msg, collapse=" "))
+ }
+
+###}}}
+
+###{{{ categorical2dummy
+
+categorical2dummy <- function(x,data,silent=TRUE,...) {
+ x0 <- x
+ X <- intersect(index(x)$exogenous,colnames(data))
+ catX <- c()
+ for (i in X) {
+ if (!is.numeric(data[,i])) catX <- c(catX,i)
+ }
+ if (length(catX)==0) return(list(x=x,data=data))
+ f <- as.formula(paste("~ 1+", paste(catX,collapse="+")))
+ opt <- options(na.action="na.pass")
+ M <- model.matrix(f,data)
+
+ options(opt)
+ Mnames <- colnames(M)
+ Mpos <- attributes(M)$assign
+ A <- index(x)$A
+ F <- regfix(x)
+ count <- 0
+ for (i in catX) {
+ count <- count+1
+ mnames <- Mnames[Mpos==count]
+ kill(x0) <- i
+ Y <- colnames(A)[A[i,]==1]
+ if (length(mnames)==1) {
+ fix <- as.list(F$labels[i,])
+ fixval <- F$values[i,]
+ fix[which(!is.na(fixval))] <- fixval[na.omit(fixval)]
+ regression(x0,to=Y,from=mnames,silent=silent) <- fix[Y]
+ } else {
+ x0 <- regression(x0,to=Y,from=mnames,silent=silent)
+ }
+ }
+ index(x0) <- reindex(x0,zeroones=TRUE,deriv=TRUE)
+ return(list(x=x0,data=cbind(data,M)))
+}
+
+###}}}
+
+###{{{ procdata.lvm
+
+`procdata.lvm` <-
+ function(x,data,categorical=FALSE,
+ na.method=ifelse(any(is.na(data[,intersect(colnames(data),manifest(x))])),"complete.obs","pairwise.complete.obs"),
+ missing=FALSE
+ ) {
+ if (is.numeric(data) & !is.list(data)) {
+ data <- rbind(data)
+ }
+ if (is.data.frame(data) | is.matrix(data)) {
+ nn <- colnames(data)
+ data <- as.data.frame(data); colnames(data) <- nn; rownames(data) <- NULL
+ obs <- setdiff(intersect(vars(x), colnames(data)),latent(x))
+ Debug(obs)
+ mydata <- subset(data, select=obs)
+ if (NROW(mydata)==0) stop("No observations")
+ for (i in seq_len(ncol(mydata))) {
+ if (inherits(mydata[,i],"Surv"))
+ mydata[,i] <- mydata[,i][,1]
+ if (is.character(mydata[,i]) | is.factor(mydata[,i]))
+ mydata[,i] <- as.numeric(as.factor(mydata[,i]))-1
+ }
+
+## mydata <- data[,obs]
+## if (any(is.na(mydata))) {
+## warning("Discovered missing data. Going for a complete-case analysis. For data missing at random see 'missingMLE'.\n", immediate.=TRUE)
+## mydata <- na.omit(mydata)
+## }
+ S <- NULL
+ n <- nrow(mydata)
+ if (n==1) {
+ S <- diag(nrow=ncol(mydata)); colnames(S) <- rownames(S) <- obs
+ }
+ if (na.method=="complete.obs" && !missing) {
+ mydata0 <- na.omit(mydata)
+ n <- nrow(mydata0)
+ mu <- colMeans(mydata0)
+ if (is.null(S) && n>2)
+ S <- (n-1)/n*cov(mydata0) ## MLE variance matrix of observed variables
+ rm(mydata0)
+ }
+ nS <- is.null(S) || any(is.na(S))
+ if (na.method=="pairwise.complete.obs" || nS) {
+ mu <- colMeans(mydata,na.rm=TRUE)
+ if (nS) {
+ n <- nrow(mydata)
+ S <- (n-1)/n*cov(mydata,use="pairwise.complete.obs")
+ S[is.na(S)] <- 1e-3
+ }
+ }
+ }
+ else
+ if (is.list(data)) {
+ if ("cov"%in%names(data)) data$S <- data$cov
+ if ("var"%in%names(data)) data$S <- data$var
+ if ("mean"%in%names(data)) data$mu <- data$mean
+ n <- data$n
+ S <- reorderdata.lvm(x,data$S)
+ mu <- reorderdata.lvm(x,data$mu)
+ ## if (is.null(n)) stop("n was not specified");
+ }
+ else
+ stop("Unexpected type of data!");
+ if (nrow(S)!=ncol(S)) stop("Wrong type of data!");
+ return(list(S=S,mu=mu,n=n))
+ }
+
+###}}}
+
+###{{{ reorderdata.lvm
+
+`reorderdata.lvm` <-
+ function(x, data) {
+ if (is.vector(data)) {
+ nn <- names(data)
+ ii <- na.omit(match(index(x)$manifest, nn))
+ data[ii,drop=FALSE]
+ } else {
+ nn <- colnames(data)
+ ii <- na.omit(match(index(x)$manifest, nn))
+ data[ii,ii,drop=FALSE]
+ }
+ }
+
+###}}}
+
+###{{{ symmetrize
+
+`symmetrize` <-
+function(M, upper=TRUE) {
+ if (length(M)==1) return(M)
+ if (!is.matrix(M) | ncol(M)!=nrow(M)) stop("Only implemented for square matrices.")
+ if (upper) {
+ for (i in seq_len(ncol(M)-1))
+ for (j in seq(i+1,nrow(M)))
+ M[i,j] <- M[j,i]
+ return(M)
+ } else {
+ for (i in seq_len(ncol(M)))
+ for (j in seq_len(nrow(M)))
+ if (M[i,j]==0)
+ M[i,j] <- M[j,i]
+ else
+ M[j,i] <- M[i,j]
+ return(M)
+ }
+}
+
+###}}}
+
+###{{{ naiveGrad
+
+naiveGrad <- function(f, x, h=1e-9) {
+ nabla <- numeric(length(x))
+ for (i in seq_along(x)) {
+ xh <- x; xh[i] <- x[i]+h
+ nabla[i] <- (f(xh)-f(x))/h
+ }
+ return(nabla)
+}
+
+###}}}
+
+###{{{ CondMom
+
+# conditional on Compl(idx)
+CondMom <- function(mu,S,idx,X) {
+ idxY <- idx
+
+ idxX <- setdiff(seq_len(ncol(S)),idxY)
+ SXX <- S[idxX,idxX,drop=FALSE];
+ SYY <- S[idxY,idxY,drop=FALSE]
+ SYX <- S[idxY,idxX,drop=FALSE]
+ iSXX <- solve(SXX)
+ condvar <- SYY-SYX%*%iSXX%*%t(SYX)
+ if (missing(mu)) return(condvar)
+
+ muY <- mu[,idxY,drop=FALSE]
+ muX <- mu[,idxX,drop=FALSE]
+ if (is.matrix(mu))
+ Z <- t(X-muX)
+ else
+ Z <- apply(X,1,function(xx) xx-muX)
+ SZ <- t(SYX%*%iSXX%*%Z)
+## condmean <- matrix(
+ if (is.matrix(mu))
+ condmean <- SZ+muY
+ else
+ condmean <- t(apply(SZ,1,function(x) muY+x))
+## ,ncol=ncol(SZ),nrow=nrow(SZ))
+ return(list(mean=condmean,var=condvar))
+}
+
+###}}} CondMom
+
+###{{{ Depth-First/acc (accessible)
+
+DFS <- function(M,v,explored=c()) {
+ explored <- union(explored,v)
+ incident <- M[v,]
+ for (v1 in setdiff(which(incident==1),explored)) {
+ explored <- DFS(M,v1,explored)
+ }
+ return(explored)
+}
+
+acc <- function(M,v) {
+ if (is.character(v)) v <- which(colnames(M)==v)
+ colnames(M)[setdiff(DFS(M,v),v)]
+}
+
+###}}} Depth-First/acc (accessible)
+
+
+npar.lvm <- function(x) {
+ return(index(x)$npar+ index(x)$npar.mean+index(x)$npar.ex)
+
+}
+
+as.numeric.list <- function(x,...) {
+ res <- list()
+ asnum <- as.numeric(x)
+ lapply(x,function(y) ifelse(is.na(as.numeric(y)),y,as.numeric(y)))
+}
+
+edge2pair <- function(e) {
+ sapply(e,function(x) strsplit(x,"~"))
+}
+numberdup <- function(xx) { ## Convert to numbered list
+ dup.xx <- duplicated(xx)
+ dups <- xx[dup.xx]
+ xx.new <- numeric(length(xx))
+ count <- 0
+ for (i in seq_along(xx)) {
+ if (!dup.xx[i]) {
+ count <- count+1
+ xx.new[i] <- count
+ } else {
+ xx.new[i] <- xx.new[match(xx[i],xx)[1]]
+ }
+ }
+ return(xx.new)
+}
+
+extractvar <- function(f) {
+ yy <- getoutcome(f)
+ xx <- attributes(terms(f))$term.labels
+ myvars <- all.vars(f)
+ return(list(y=yy,x=xx,all=myvars))
+}
+
+##' @export
+getoutcome <- function(formula,sep,...) {
+ aa <- attributes(terms(formula,...))
+ if (aa$response==0) {
+ res <- NULL
+ } else {
+ res <- paste(deparse(formula[[2]]),collapse="")
+ }
+ if (!missing(sep) && length(aa$term.labels)>0) {
+ attributes(res)$x <- lapply(strsplit(aa$term.labels,"\\|")[[1]],
+ function(x) as.formula(paste0("~",x)))
+ } else {
+ attributes(res)$x <- aa$term.labels
+ }
+ return(res)
+}
+
+
+##' @export
+Specials <- function(f,spec,split2="+",...) {
+ tt <- terms(f,spec)
+ pos <- attributes(tt)$specials[[spec]]
+ if (is.null(pos)) return(NULL)
+ x <- rownames(attributes(tt)$factors)[pos]
+ st <- gsub(" ","",x)
+ res <- unlist(strsplit(st,"[()]"))[2]
+ if (is.null(split2)) return(res)
+ unlist(strsplit(res,"+",fixed=TRUE))
+}
+
+
+##' @export
+decomp.specials <- function(x,pattern="[()]",pattern2=NULL, pattern.ignore=NULL, sep="[,\\+]",perl=TRUE,reverse=FALSE,...) {
+ st <- gsub(" |^\\(|)$","",x) # Remove white space and leading/trailing parantheses
+ if (!is.null(pattern.ignore)) {
+ if (grepl(pattern.ignore,st,perl=perl,...)) return(st)
+ }
+ if (!is.null(pattern)) {
+ st <- rev(unlist(strsplit(st,pattern,perl=perl,...)))[1]
+ }
+ if (!is.null(pattern2)) {
+ st <- (unlist(strsplit(st,pattern2,perl=perl,...)))
+ if (reverse) st <- rev(st)
+ }
+ unlist(strsplit(st,sep,perl=perl,...))
+}
+
+Decomp.specials <- function(x,pattern="[()]") {
+ st <- gsub(" ","",x)
+ st <- gsub("\n","",st)
+ mysplit <- rev(unlist(strsplit(st,pattern)))
+ type <- mysplit[2]
+ vars <- mysplit[1]
+ res <- unlist(strsplit(vars,","))
+ if (type=="s" | type=="seq") {
+ return(paste0(res[1],seq(char2num(res[2]))))
+ }
+ unlist(strsplit(vars,","))
+
+}
+
+printline <- function(n=70) {
+ cat(rep("_", n), "\n", sep="");
+
+}
diff --git a/R/variances.R b/R/variances.R
new file mode 100644
index 0000000..911f829
--- /dev/null
+++ b/R/variances.R
@@ -0,0 +1,20 @@
+### Return position of variance elements in the parameter vector (without mean parameters)
+### Optimization constraints are needed on these parameters
+##' @export
+variances <- function(x,mean=FALSE) {
+## if (is.null(x$parpos))
+## x$parpos <- parpos(x)
+ x$parpos <- parpos(Model(x),mean=TRUE)
+ res <- diag(x$parpos$P)[which(diag(index(x)$P0)==1)]
+ if (!mean) {
+ return(res - index(x)$npar.mean)
+ }
+ return(res)
+}
+## And the off-diagonal (covariance) parameters
+##' @export
+offdiags <- function(x,mean=FALSE) {
+ parpos <- parpos(x,mean=mean)
+ pp <- parpos$P
+ pp[lower.tri(pp)][(index(x)$P0)[lower.tri(pp)]==1]
+}
diff --git a/R/vars.R b/R/vars.R
new file mode 100644
index 0000000..92c05e4
--- /dev/null
+++ b/R/vars.R
@@ -0,0 +1,105 @@
+##' Extract variable names from latent variable model
+##'
+##' Extract exogenous variables (predictors), endogenous variables (outcomes),
+##' latent variables (random effects), manifest (observed) variables from a
+##' \code{lvm} object.
+##'
+##' \code{vars} returns all variables of the \code{lvm}-object including
+##' manifest and latent variables. Similarily \code{manifest} and \code{latent}
+##' returns the observered resp. latent variables of the model.
+##' \code{exogenous} returns all manifest variables without parents, e.g.
+##' covariates in the model, however the argument \code{latent=TRUE} can be used
+##' to also include latent variables without parents in the result. Pr. default
+##' \code{lava} will not include the parameters of the exogenous variables in
+##' the optimisation routine during estimation (likelihood of the remaining
+##' observered variables conditional on the covariates), however this behaviour
+##' can be altered via the assignment function \code{exogenous<-} telling
+##' \code{lava} which subset of (valid) variables to condition on. Finally
+##' \code{latent} returns a vector with the names of the latent variables in
+##' \code{x}. The assigment function \code{latent<-} can be used to change the
+##' latent status of variables in the model.
+##'
+##' @aliases vars vars.lvm vars.lvmfit latent latent<- latent.lvm latent<-.lvm
+##' latent.lvmfit latent.multigroup manifest manifest.lvm manifest.lvmfit
+##' manifest.multigroup exogenous exogenous<- exogenous.lvm exogenous<-.lvm
+##' exogenous.lvmfit exogenous.multigroup endogenous endogenous.lvm
+##' endogenous.lvmfit endogenous.multigroup
+##' @usage
+##'
+##' vars(x,...)
+##'
+##' endogenous(x,...)
+##'
+##' exogenous(x,...)
+##'
+##' manifest(x,...)
+##'
+##' latent(x,...)
+##'
+##' \method{exogenous}{lvm}(x,silent = FALSE, xfree = TRUE,...) <- value
+##'
+##' \method{exogenous}{lvm}(x,latent=FALSE,index=TRUE,...)
+##'
+##' \method{latent}{lvm}(x,clear=FALSE,...) <- value
+##'
+##' @param x \code{lvm}-object
+##' @param latent Logical defining whether latent variables without parents
+##' should be included in the result
+##' @param index For internal use only
+##' @param clear Logical indicating whether to add or remove latent variable
+##' status
+##' @param silent Suppress messages
+##' @param xfree For internal use only
+##' @param value Formula or character vector of variable names.
+##' @param \dots Additional arguments to be passed to the low level functions
+##' @return Vector of variable names.
+##' @author Klaus K. Holst
+##' @seealso \code{\link{endogenous}}, \code{\link{manifest}},
+##' \code{\link{latent}}, \code{\link{exogenous}}, \code{\link{vars}}
+##' @keywords models regression
+##' @examples
+##'
+##' g <- lvm(eta1 ~ x1+x2)
+##' regression(g) <- c(y1,y2,y3) ~ eta1
+##' latent(g) <- ~eta1
+##' endogenous(g)
+##' exogenous(g)
+##' identical(latent(g), setdiff(vars(g),manifest(g)))
+##'
+##' @export
+`vars` <-
+function(x,...) UseMethod("vars")
+
+##' @export
+`vars.graph` <-
+ function(x,...) {
+ graph::nodes(x)
+ }
+
+##' @export
+`vars.lvm` <-
+ function(x,...) {
+ colnames(x$M)
+ }
+
+##' @export
+`vars.lvmfit` <-
+ function(x,...) {
+ vars(Model(x),...)
+ }
+
+##' @export
+vars.list <- function(x,...) {
+ varlist <- c()
+ for (i in seq_along(x)) {
+ varlist <- c(varlist, vars(x[[i]]))
+ }
+ varlist <- unique(varlist)
+ return(varlist)
+}
+
+##' @export
+`vars.lm` <-
+ function(x,...) {
+ c(endogenous(x),exogenous(x))
+ }
diff --git a/R/vcov.R b/R/vcov.R
new file mode 100644
index 0000000..e4db8b2
--- /dev/null
+++ b/R/vcov.R
@@ -0,0 +1,19 @@
+##' @export
+vcov.lvmfit <- function(object,...) {
+ res <- object$vcov
+ if (inherits(object,"lvm.missing")) {
+ resnames <- names(coef(object))
+
+ } else {
+ resnames <- coef(Model(object),fix=FALSE, mean=object$control$meanstructure)
+ }
+ colnames(res) <- rownames(res) <- resnames
+ return(res)
+}
+
+##' @export
+vcov.multigroupfit <- function(object,...) {
+ res <- object$vcov
+ colnames(res) <- rownames(res) <- object$model$name
+ return(res)
+}
diff --git a/R/vec.R b/R/vec.R
new file mode 100644
index 0000000..8b264b5
--- /dev/null
+++ b/R/vec.R
@@ -0,0 +1,26 @@
+##' vec operator
+##'
+##' Convert array into vector
+##' @title vec operator
+##' @param x Array
+##' @param matrix If TRUE a row vector (matrix) is returned
+##' @param sep Seperator
+##' @param ... Additional arguments
+##' @author Klaus Holst
+##' @export
+vec <- function(x,matrix=FALSE,sep=".",...) {
+ if (is.vector(x) && !is.list(x)) {
+ res <- x
+ } else if (is.list(x)) {
+ res <- stats::setNames(unlist(x),names(x))
+ } else {
+ if (is.matrix(x) && is.null(rownames(x))) {
+ nn <- colnames(x)
+ } else {
+ nn <- apply(expand.grid(dimnames(x)),1,function(x) paste(x,collapse=sep))
+ }
+ res <- as.vector(x); names(res) <- nn
+ }
+ if (matrix) return(cbind(res))
+ return(res)
+}
diff --git a/R/weights.R b/R/weights.R
new file mode 100644
index 0000000..26a00bf
--- /dev/null
+++ b/R/weights.R
@@ -0,0 +1,5 @@
+##' @export
+`Weights` <- function(x,...) UseMethod("Weights")
+
+##' @export
+Weights.default <- function(x,...) eval(x$weights)
diff --git a/R/wrapvec.R b/R/wrapvec.R
new file mode 100644
index 0000000..4e6e4fc
--- /dev/null
+++ b/R/wrapvec.R
@@ -0,0 +1,16 @@
+##' Wrap vector
+##'
+##' Wrap vector
+##' @param x Vector or integer
+##' @param delta Shift
+##' @param ... Additional parameters
+##' @export
+##' @examples
+##' wrapvec(5,2)
+wrapvec <- function(x,delta=0L,...) {
+ if (length(x)==1 && floor(x)==x && x>0) {
+ x <- seq(x)
+ }
+ if (delta==0L) return(x)
+ x[(seq_along(x)+delta-1L)%%length(x)+1L]
+}
diff --git a/R/zcolorbar.R b/R/zcolorbar.R
new file mode 100644
index 0000000..a087246
--- /dev/null
+++ b/R/zcolorbar.R
@@ -0,0 +1,68 @@
+##' Add color-bar to plot
+##'
+##' @title Add color-bar to plot
+##' @param clut Color look-up table
+##' @param x.range x range
+##' @param y.range y range
+##' @param values label values
+##' @param digits number of digits
+##' @param label.offset label offset
+##' @param srt rotation of labels
+##' @param cex text size
+##' @param border border of color bar rectangles
+##' @param alpha Alpha (transparency) level 0-1
+##' @param position Label position left/bottom (1) or top/right (2) or no text (0)
+##' @param direction horizontal or vertical color bars
+##' @param \dots additional low level arguments (i.e. parsed to \code{text})
+##' @export
+##' @examples
+##' \dontrun{
+##' plotNeuro(x,roi=R,mm=-18,range=5)
+##' colorbar(clut=Col(rev(rainbow(11,start=0,end=0.69)),0.5),
+##' x=c(-40,40),y.range=c(84,90),values=c(-5:5))
+##'
+##' colorbar(clut=Col(rev(rainbow(11,start=0,end=0.69)),0.5),
+##' x=c(-10,10),y.range=c(-100,50),values=c(-5:5),
+##' direction="vertical",border=1)
+##' }
+colorbar <- function(clut=Col(rev(rainbow(11,start=0,end=0.69)),alpha),
+ x.range=c(-.5,.5),y.range=c(-.1,.1),
+ values=seq(clut),digits=2,label.offset,srt=45,
+ cex=0.5,border=NA,
+ alpha=0.5,
+ position=1,
+ direction=c("horizontal","vertical"),...) {
+ nlut <- length(clut)
+ X <- length(agrep(tolower(direction[1]),"horizontal"))>0
+ scale <- ifelse(X,diff(x.range),diff(y.range))/nlut
+ barsize <- ifelse(X,diff(y.range),diff(x.range))
+ if (missing(label.offset)) label.offset <- barsize/3
+ delta <- ifelse(X,x.range[1],y.range[1])
+ if (!is.null(values)) dM <- diff(range(values))/(nlut-1)
+ for (i in seq_len(nlut+1)-1) {
+ pos <- delta + (i-1)*scale
+ if (X) {
+ x1 <- pos; x2 <- pos+scale; y1 <- y.range[1]; y2 <- y.range[2]
+ } else {
+ y1 <- pos; y2 <- pos+scale; x1 <- x.range[1]; x2 <- x.range[2]
+ }
+ if (i>0)
+ rect(x1,y1,x2,y2, col=clut[i], border=border, xpd=TRUE)
+ }
+ if (!is.null(values)) {
+ for (i in seq_len(nlut+1)-1) {
+ pos <- delta + (i-1)*scale
+ rund <- format(round(min(values)+dM*i,max(1,digits)),digits=digits)
+ ## rund <- round((min(values)+dM*i)*10^digits)/(10^digits)
+ x0 <- pos+(1+0.5)*scale; y0 <- y.range[2]+label.offset
+ if (!X) {
+ y0 <- x0;
+ if (position==1) x0 <- x.range[1]-label.offset
+ if (position==2) x0 <- x.range[1]+label.offset*5
+ if (position==3) x0 <- x.range[1]+label.offset*1
+ }
+ if (i<nlut)
+ text(x0,y0,rund,cex=cex,srt=srt,xpd=TRUE,...)
+ }
+ }
+}
diff --git a/R/zgetmplus.R b/R/zgetmplus.R
new file mode 100644
index 0000000..b62e1fe
--- /dev/null
+++ b/R/zgetmplus.R
@@ -0,0 +1,248 @@
+##' Read Mplus output files
+##'
+##' @title Read Mplus output
+##' @param infile Mplus output file
+##' @param coef Coefficients only
+##' @param \dots additional arguments to lower level functions
+##' @author Klaus K. Holst
+##' @export
+##' @seealso getSAS
+`getMplus` <-
+function(infile="template.out",coef=TRUE,...) {
+## mycmd <- paste("grep -n \"Estimates S.E. Est./S.E.\" | cut -f1 -d:", outfile)
+
+ if (coef) {
+ start <- "MODEL RESULTS"
+ end1 <- "R-SQUARE"
+ res0 <- findfileseg(infile,start)[-c(seq(5))]
+ res <- sapply(res0,function(x) { val <- strsplit(x," ")[[1]]; val[val!=""] })
+ res <- res[unlist(lapply(res, length))!=0]
+
+ coef.idx <- unlist(lapply(res, length))>3
+ lab.idx <- which(!coef.idx)
+ count <- 0
+ mycoef <- c()
+ myrownames <- c()
+ for (i in seq_along(res)) {
+ if (i %in% lab.idx) {
+ count <- count+1
+ } else {
+ val <- char2num(res[[i]][-1])
+ if (length(val)<5) val <- c(val,rep(0,5-length(val)))
+ mycoef <- rbind(mycoef, val)
+ myrownames <- c(myrownames,
+ paste(paste(res[[lab.idx[count]]],collapse=" "),res[[i]][1])
+ )
+
+ }
+ }
+ rownames(mycoef) <- myrownames
+ colnames(mycoef) <- c("Estimate","Std.Err","Z-value","Std","StdYX")
+ return(mycoef)
+ }
+
+ start <- "Estimate S.E. Est./S.E."
+ end1 <- "MODEL RESULTS"
+ end2 <- "QUALITY OF NUMERICAL RESULTS"
+## start <- "Estimate S.E. Est./S.E."
+## end1 <- "Beginning Time:"
+ ## end2 <- "TECHNICAL"
+ res <- findfileseg(infile,start,end1);
+## res2 <- findfileseg(infile,start,end2);
+## if (length(res)>length(res2))
+## res <- res2
+ cat(paste(res,"\n"))
+
+ res <- findfileseg(infile, "TESTS OF MODEL FIT", "Chi-Square Test of Model Fit for the Baseline Model")
+ cat(paste(res,"\n"))
+}
+
+
+
+`findfileseg` <-
+function(infile, startstring, endstring,nlines) {
+ con <- file(infile, blocking = FALSE)
+ inp <- readLines(con)
+ close(con)
+ nullstring <- 0
+ linestart <- 1; lineend <- length(inp)
+
+ mycmd1 <- paste0("grep -n \"",startstring,"\" ", infile); a1 <- system(mycmd1,intern=TRUE);
+ if (length(a1)>0)
+ linestart <- char2num(strsplit(a1,":")[[1]][1])
+
+ nn <- length(inp)
+ if (!missing(nlines)) nn <- linestart+nlines
+ if (missing(endstring)) {
+ for (i in seq(linestart,nn)) {
+ lineend <- i-1
+ if (inp[i]==inp[i-1]) break;
+ }
+ } else {
+ mycmd2 <- paste0("grep -n \"",endstring,"\" ", infile); a2 <- system(mycmd2,intern=TRUE);
+ if (length(a2)>0)
+ lineend <- char2num(strsplit(a2,":")[[1]][1])
+ }
+
+ res <- inp[linestart:lineend-1]
+ return(res)
+}
+
+
+##################################################
+### Generate code and run mplus...
+##################################################
+
+`mplus` <-
+function(file="template.mplus",wait=TRUE,intern=TRUE,...) {
+ if (!file.exists(file)) file <- paste0(file,".mplus")
+ if (!file.exists(file)) stop("File does not exist")
+ if (!exists("winecmd")) winecmd <- "wine"
+ if (!exists("mplus.directory")) mplus.directory <- ""
+ mycmd <- paste0(winecmd, " \"", mplus.directory, "mplus.exe\" ", file)
+ system(mycmd, wait=wait, intern=TRUE)
+ prefix <- strsplit(file, ".", fixed=TRUE)[[1]][1]
+ return(getMplus(paste0(prefix,".out"),coef=TRUE))
+}
+
+`toMplus.data.frame` <-
+function(x, datafile="data.tab",
+ mplusfile="template.mplus",
+ na.string=".", model="!f1 by x1;",
+ analysis=NULL,
+ categorical=NULL,
+ group,
+ run=FALSE, techout=FALSE,missing=TRUE,...) {
+ write.table(x, file=datafile, sep="\t",
+ quote=FALSE, row.names=FALSE, col.names=FALSE, na=na.string)
+ varnames <- c()
+ ngroups <- ceiling(ncol(x)/4)
+
+ for (i in seq_len(ngroups)) {
+ newline <- c("\t",colnames(x)[((i-1)*4+1):min(ncol(x), (i*4))],"\n")
+ varnames <- c(varnames, newline)
+ }
+
+### mplusfilesummary <- paste0("summary",mplusfile)
+### zz <- file(mplusfilesummary, "w") # open an output file connection
+### cat(file=zz, "TITLE: Summary-statistics\n")
+### cat(file=zz, "!-----------------------------------------------------\n")
+### cat(file=zz,"DATA:\n\tFILE=\"", datafile, "\";\n")
+### cat(file=zz,"VARIABLE:\n\tNAMES ARE\n")
+### cat(file=zz, varnames, ";\n\n")
+
+### cat(file=zz, "!-----------------------------------------------------\n")
+### cat(file=zz, "USEVARIABLES=\n!?;\n")
+### cat(file=zz, "!CATEGORICAL=?;\n")
+### cat(file=zz, "!MISSING=?;\n")
+### cat(file=zz, "!IDVARIABLE=?;\n")
+### cat(file=zz, "!-----------------------------------------------------\n")
+### cat(file=zz, "ANALYSIS:\n\tTYPE IS BASIC;\n")
+### cat(file=zz, "!-----------------------------------------------------\n")
+### cat(file=zz, "OUTPUT:\t\tstandardized sampstat;")
+### close(zz)
+
+ zz <- file(mplusfile, "w") # open an output file connection
+ cat(file=zz, "TITLE: ...\n")
+ cat(file=zz, "!-----------------------------------------------------\n")
+ cat(file=zz,"DATA:\n\tFILE=\"", datafile, "\";\n")
+ cat(file=zz,"VARIABLE:\n\tNAMES ARE\n")
+ cat(file=zz, varnames, ";\n")
+ if (!missing(group)) {
+ groups <- unique(x[,group])
+ mygroupdef <- paste("(",paste(groups,groups,sep="=",collapse=","),")")
+ cat(file=zz, "GROUPING IS ", group, mygroupdef, ";\n", sep="")
+ } else {
+ cat(file=zz, "!GROUPING IS g (1=male, 2=female);\n")
+ }
+ cat(file=zz, "USEVARIABLES=\n", varnames,";\n")
+ if (!is.null(categorical))
+ cat(file=zz, paste("CATEGORICAL=",paste(categorical,collapse=" "),";\n"))
+ cat(file=zz, "MISSING=",na.string,";\n",sep="")
+ cat(file=zz, "!IDVARIABLE=?;\n")
+ cat(file=zz, "!DEFINE: define new variables here;\n")
+ cat(file=zz, "!SAVEDATA: save data and/or results;\n\n")
+ if (is.null(analysis)) {
+ cat(file=zz, "ANALYSIS: TYPE=MEANSTRUCTURE");
+ if (missing) cat(file=zz, " MISSING;\n")
+ else cat(file=zz,";\n")
+ cat(file=zz, "ESTIMATOR=ML;\n")
+ cat(file=zz, "INFORMATION=EXPECTED;\n")
+ cat(file=zz, "ITERATIONS=5000;\n")
+ cat(file=zz, "CONVERGENCE=0.00005;\n\n")
+ } else {
+ cat(file=zz,"ANALYSIS:\n")
+ cat(file=zz, analysis,"\n")
+ }
+ cat(file=zz, "!-----------------------------------------------------\n")
+ cat(file=zz, "MODEL:\n")
+ cat(file=zz, model,"\n")
+ cat(file=zz, "!-----------------------------------------------------\n")
+ if (!techout)
+ cat(file=zz, "OUTPUT: STANDARDIZED;\n")
+ else
+ cat(file=zz, "OUTPUT: MODINDICES(0); TECH1; TECH2; TECH5; STANDARDIZED;\n")
+ cat(file=zz, "!\tSAMPSTAT;RESIDUAL;CINTERVAL;MODINDICES(0);\n")
+ cat(file=zz, "!Other output options are:\n")
+ cat(file=zz, "!\tSTANDARDIZED; !Standardized coefficients\n")
+ cat(file=zz, "!\tH1SE; !Standard errors for the H1 model\n")
+ cat(file=zz, "!\tH1TECH3; !Estimated covar,corr matrices for par. estimates\n")
+ cat(file=zz, "!\tPATTERNS; !Summary of missing data patterns\n")
+ cat(file=zz, "!\tFSCOEFFICIENT; !Factor score coefficients and posterior covar matrix\n")
+ cat(file=zz, "!\tFSDERTERMINACY; !Factor score determinacy for each factor\n")
+ cat(file=zz, "!\tTECH1; !Parameter specifications and starting values\n")
+ cat(file=zz, "!\tTECH2 !Parameter derivatives;\n")
+ cat(file=zz, "!\tTECH3; !Covar and Corr matrices for estimates\n")
+ cat(file=zz, "!\tTECH4; !Estimated means and covar for the latent variables\n")
+ cat(file=zz, "!\tTECH5; !Optimization matrix\n")
+ cat(file=zz, "!\tTECH6; !Optimization for categorical variables\n")
+ cat(file=zz, "!\tTECH7; !output for type Mixture\n")
+ cat(file=zz, "!\tTECH8; !Output for type mixture\n")
+ cat(file=zz, "!\tTECH9; !Error messages for MC study\n")
+ cat(file=zz, "!\tMONTECARLO: File is\n")
+ close(zz)
+
+ if (run & exists("mplus")) {
+ res <- mplus(mplusfile)
+ outfile <- paste0(strsplit(mplusfile,".",fixed=TRUE)[[1]][1],".out")
+ getMplus(outfile)
+ return(res)
+ }
+}
+
+`toMplus.lvmfit` <-
+function(x, model=NULL, data=model.frame(x), run=TRUE, categorical=NULL,##binary(Model(x)),
+ mplusfile="template.mplus", ...) {
+ mymodel <- ""
+ M <- index(x)$M
+ P <- index(x)$P
+ nn <- vars(x)
+ p <- length(nn)
+ lat.var <- latent(x)
+ lat.idx <- match(lat.var, vars(x))
+ for (i in seq_len(p)) {
+ for (j in seq_len(p)) {
+ if (M[i,j]!=0) {
+ var1 <- nn[i]; var2 <- nn[j];
+ if (i %in% lat.idx & !(j %in% lat.idx)) {## & !(j %in% lat.idx)) {
+ key <- " on "
+ mymodel <- paste0(mymodel, "\n", var1, " by ", var2, ";")
+ } else {
+ mymodel <- paste0(mymodel, "\n", var2, " on ", var1, ";")
+ }
+ }
+ }
+ }
+ for (i in seq_len(p-1)) {
+ for (j in ((i+1):p)) {
+ if (P[i,j]!=0) {
+ var1 <- nn[i]; var2 <- nn[j];
+ mymodel <- paste0(mymodel, "\n", var1, " with ", var2, ";")
+ }
+ }
+ }
+ if (is.null(model))
+ model <- mymodel
+ mydata <- subset(as.data.frame(data), select=setdiff(nn,lat.var))
+ toMplus.data.frame(mydata,model=mymodel,run=run, mplusfile=mplusfile, ...)
+}
diff --git a/R/zgetsas.R b/R/zgetsas.R
new file mode 100644
index 0000000..96e9857
--- /dev/null
+++ b/R/zgetsas.R
@@ -0,0 +1,44 @@
+##' Run SAS code like in the following:
+##'
+##' ODS CSVALL BODY="myest.csv";
+##' proc nlmixed data=aj qpoints=2 dampstep=0.5;
+##' ...
+##' run;
+##' ODS CSVALL Close;
+##'
+##' and read results into R with:
+##'
+##' \code{getsas("myest.csv","Parameter Estimates")}
+##'
+##' @title Read SAS output
+##' @param infile file (csv file generated by ODS)
+##' @param entry Name of entry to capture
+##' @param \dots additional arguments to lower level functions
+##' @author Klaus K. Holst
+##' @export
+##' @seealso getMplus
+getSAS <- function(infile,entry="Parameter Estimates",...) {
+ con <- file(infile, blocking = FALSE)
+ inp <- readLines(con)
+ close(con)
+ nullstring <- 0
+ linestart <- 1; lineend <- length(inp)
+ ## mycmd1 <- paste0("grep -n \"",entry,"\" ", csvfile); a1 <- system(mycmd1,intern=TRUE);
+ ## linestart <- char2num(strsplit(a1,":")[[1]][1])
+ idx <- sapply(inp,function(x) length(grep(entry, x))>0)
+ if (sum(idx)==1) {
+ linestart <- which(idx)
+ for (i in seq(linestart,length(inp))) {
+ lineend <- i-1
+ ## if (inp[i]==inp[i-1]) break;
+ if (inp[i]=="") break;
+ }
+ } else {
+ stop("No match or duplicate entries!")
+ }
+ subinp <- inp[(linestart+1):(lineend)]
+ con <- textConnection(subinp)
+ res <- read.csv(con,header=TRUE)
+ close(con)
+ return(res)
+}
diff --git a/R/zib.R b/R/zib.R
new file mode 100644
index 0000000..0dbf002
--- /dev/null
+++ b/R/zib.R
@@ -0,0 +1,397 @@
+##' Dose response calculation for binomial regression models
+##'
+##' @title Dose response calculation for binomial regression models
+##' @param model Model object or vector of parameter estimates
+##' @param intercept Index of intercept parameters
+##' @param slope Index of intercept parameters
+##' @param prob Index of mixture parameters (only relevant for
+##' \code{zibreg} models)
+##' @param x Optional weights
+##' length(x)=length(intercept)+length(slope)+length(prob)
+##' @param level Probability at which level to calculate dose
+##' @param ci.level Level of confidence limits
+##' @param vcov Optional estimate of variance matrix of parameter
+##' estimates
+##' @param family Optional distributional family argument
+##' @param EB Optional ratio of treatment effect and adverse effects
+##' used to find optimal dose (regret-function argument)
+##' @author Klaus K. Holst
+##' @export
+PD <- function(model,intercept=1,slope=2,prob=NULL,x,level=0.5,
+ ci.level=0.95,vcov,family, EB=NULL) {
+ if (is.vector(model)) {
+ beta <- model
+ if (missing(vcov)) stop("vcov argument needed")
+ if (missing(family)) stop("family argument needed")
+ } else beta <- coef(model)
+ if (missing(vcov)) vcov <- stats::vcov(model)
+ if (missing(family)) family <- stats::family(model)
+ N <- length(intercept)+length(slope)+length(prob)
+ if (length(intercept)<length(beta)) {
+ B.intercept <- rep(0,length(beta));
+ if (!missing(x)) {
+ if (length(x)!=N) stop("x should be of same length as the total length of 'intercept','slope','prob'")
+ B.intercept[intercept] <- x[seq_len(length(intercept))]
+ } else B.intercept[intercept] <- 1
+ } else {
+ B.intercept <- intercept
+ }
+ if (length(slope)<length(beta)) {
+ B.slope <- rep(0,length(beta));
+ if (!missing(x))
+ B.slope[slope] <- x[length(intercept)+seq_len(length(slope))]
+ else
+ B.slope[slope] <- 1
+ } else {
+ B.slope <- slope
+ }
+ if (!is.null(prob)) {
+ if (length(prob)<length(beta)) {
+ B.prob <- rep(0,length(beta));
+ if (!missing(x))
+ B.prob[prob] <- x[length(intercept)+length(slope)+seq_len(length(prob))]
+ else
+ B.prob[prob] <- 1
+ } else {
+ B.prob <- prob
+ }
+ }
+ if (is.null(prob)) B.prob <- NULL
+ B <- rbind(B.intercept,B.slope,B.prob)
+ S <- B%*%vcov%*%t(B)
+ b <- as.vector(B%*%beta)
+
+ f <- function(b) {
+ mylevel <- level
+ if (!is.null(EB)) {
+ if (is.null(prob)) stop("Index of mixture-probability parameters needed")
+ pi0 <- family$linkinv(b[3])
+ mylevel <- 1-(1-pi0)/pi0*(EB)/(1-EB)
+ }
+ return(structure((family$linkfun(mylevel)-b[1])/b[2],level=mylevel))
+ }
+
+ xx <- f(b)
+ Dxx <- -1/b[2]*rbind(1,xx)
+ if (!is.null(EB))
+ Dxx <- numDeriv::grad(f,b)
+ se <- diag(t(Dxx)%*%S%*%Dxx)^0.5
+ res <- cbind(Estimate=xx,"Std.Err"=se)
+ alpha <- 1-ci.level
+ alpha.str <- paste(c(alpha/2,1-alpha/2)*100,"",sep="%")
+ res <- cbind(res,res[,1]-qnorm(1-alpha/2)*res[,2],res[,1]+qnorm(1-alpha/2)*res[,2])
+ colnames(res)[3:4] <- alpha.str
+ rownames(res) <- paste0(round(1000*attributes(xx)$level)/10,"%")
+ structure(res,b=b)
+}
+
+
+TN.zibreg <- function(object,data=model.frame(object),p=coef(object),intercept=1,slope=2,alpha=0.95,...) {
+ pp <- predict(object,link=FALSE,p=p,newdata=data)
+ X <- attributes(pp)$grad$beta
+ Z <- attributes(pp)$grad$gamma
+ db1 <- db2 <- matrix(0,nrow(X),ncol(X))
+ db1[,intercept] <- X[,intercept]
+ db2[,slope[1]] <- 1; db2[,slope[-1]] <- X[,slope[-1]]
+ b1 <- as.vector(db1%*%p[object$beta.idx])
+ b2 <- as.vector(db2%*%p[object$beta.idx])
+ ginv <- object$family$linkinv
+ dginv <- object$family$mu.eta ## D[linkinv]
+ g <- object$family$linkfun
+ dg <- function(x) 1/dginv(g(x)) ## Dh^-1 = 1/(h'(h^-1(x)))
+ pi0 <- ginv(pp[,2])
+ A2 <- dginv(pp[,2])
+ dpi0 <- rbind(apply(Z,2,function(z) A2*z))
+ h <- function(pi0) (alpha+pi0-1)/(alpha*pi0)
+ dh <- function(pi0) (1-alpha)/(alpha*pi0^2)
+ lev <- h(pi0)
+ eta <- g(lev)
+ detad2 <- rbind(apply(dpi0,2,function(z) dg(lev)*dh(pi0)*z))
+ val <- (eta-b1)/b2
+ dvald1 <- -(db1+db2*val)/b2
+ return(structure(val,grad=cbind(dvald1,detad2/b2),varnames="theta"))
+ ## structure(g(coef(object)),grad=grad(g,coef(object)))
+}
+
+
+
+##' Regression model for binomial data with unkown group of immortals (zero-inflated binomial regression)
+##'
+##' @title Regression model for binomial data with unkown group of immortals
+##' @param formula Formula specifying
+##' @param formula.p Formula for model of disease prevalence
+##' @param data data frame
+##' @param family Distribution family (see the help page \code{family})
+##' @param offset Optional offset
+##' @param start Optional starting values
+##' @param var Type of variance (robust, expected, hessian, outer)
+##' @param ... Additional arguments to lower level functions
+##' @author Klaus K. Holst
+##' @export
+##' @examples
+##'
+##' ## Simulation
+##' n <- 2e3
+##' x <- runif(n,0,20)
+##' age <- runif(n,10,30)
+##' z0 <- rnorm(n,mean=-1+0.05*age)
+##' z <- cut(z0,breaks=c(-Inf,-1,0,1,Inf))
+##' p0 <- lava:::expit(model.matrix(~z+age) %*% c(-.4, -.4, 0.2, 2, -0.05))
+##' y <- (runif(n)<lava:::tigol(-1+0.25*x-0*age))*1
+##' u <- runif(n)<p0
+##' y[u==0] <- 0
+##' d <- data.frame(y=y,x=x,u=u*1,z=z,age=age)
+##' head(d)
+##'
+##' ## Estimation
+##' e0 <- zibreg(y~x*z,~1+z+age,data=d)
+##' e <- zibreg(y~x,~1+z+age,data=d)
+##' compare(e,e0)
+##' e
+##' PD(e0,intercept=c(1,3),slope=c(2,6))
+##'
+##' B <- rbind(c(1,0,0,0,20),
+##' c(1,1,0,0,20),
+##' c(1,0,1,0,20),
+##' c(1,0,0,1,20))
+##' prev <- summary(e,pr.contrast=B)$prevalence
+##'
+##' x <- seq(0,100,length.out=100)
+##' newdata <- expand.grid(x=x,age=20,z=levels(d$z))
+##' fit <- predict(e,newdata=newdata)
+##' plot(0,0,type="n",xlim=c(0,101),ylim=c(0,1),xlab="x",ylab="Probability(Event)")
+##' count <- 0
+##' for (i in levels(newdata$z)) {
+##' count <- count+1
+##' lines(x,fit[which(newdata$z==i)],col="darkblue",lty=count)
+##' }
+##' abline(h=prev[3:4,1],lty=3:4,col="gray")
+##' abline(h=prev[3:4,2],lty=3:4,col="lightgray")
+##' abline(h=prev[3:4,3],lty=3:4,col="lightgray")
+##' legend("topleft",levels(d$z),col="darkblue",lty=seq_len(length(levels(d$z))))
+zibreg <- function(formula,formula.p=~1,data,family=stats::binomial(),offset=NULL,start,var="hessian",...) {
+ md <- cbind(model.frame(formula,data),model.frame(formula.p,data))
+ y <- md[,1]
+ X <- model.matrix(formula,data)
+ Z <- model.matrix(formula.p,data)
+ beta.idx <- seq(ncol(X)); gamma.idx <- seq(ncol(Z))+ncol(X)
+ if (missing(start)) start <- rep(0,ncol(X)+ncol(Z))
+ op <- nlminb(start,function(x)
+ -zibreg_logL(x[beta.idx],x[gamma.idx],y,X,Z),
+ gradient=function(x)
+ -zibreg_score(x[beta.idx],x[gamma.idx],y,X,Z),...)
+ beta <- op$par[beta.idx]; gamma <- op$par[gamma.idx]
+ cc <- c(beta,gamma)
+ names(cc) <- c(colnames(X),paste0("pr:",colnames(Z)))
+ bread <- Inverse(zibreg_information(beta,gamma,y,X,Z,offset,type="hessian",...))
+ if (tolower(var[1])%in%c("robust","sandwich")) {
+ meat <- zibreg_information(beta,gamma,y,X,Z,offset,family,type="outer",...)
+ V <- bread%*%meat%*%bread
+ } else {
+ V <- bread
+ }
+ colnames(V) <- rownames(V) <- names(cc)
+ res <- list(coef=cc,opt=op,beta=beta,gamma=gamma,
+ beta.idx=beta.idx,gamma.idx=gamma.idx,bread=bread,
+ formula=formula,formula.p=formula.p, y=y, X=X, Z=Z, offset=offset, vcov=V, model.frame=md,family=family)
+ class(res) <- "zibreg"
+ res$fitted.values <- predict(res)
+ return(res)
+}
+
+##' @export
+vcov.zibreg <- function(object,...) object$vcov
+
+##' @export
+coef.zibreg <- function(object,...) object$coef
+
+##' @export
+family.zibreg <- function(object,...) object$family
+
+##' @export
+predict.zibreg <- function(object,p=coef(object),gamma,newdata,link=TRUE,subdist=FALSE,...) {
+ newf <- as.formula(paste("~",as.character(object$formula)[3]))
+ if (missing(newdata)) {
+ X <- object$X; Z <- object$Z
+ } else {
+ X <- model.matrix(newf,newdata)
+ Z <- model.matrix(object$formula.p,newdata)
+ }
+ if (length(p)==length(object$beta)+length(object$gamma)) {
+ gamma <- p[object$gamma.idx]
+ p <- p[object$beta.idx]
+ }
+ g <- object$family$linkfun
+ ginv <- object$family$linkinv
+ dginv <- object$family$mu.eta ## D[linkinv]
+ Xbeta <- as.vector(X%*%p)
+ Zgamma <- as.vector(Z%*%gamma)
+ if (!link) {
+ res <- cbind(beta=Xbeta,gamma=Zgamma)
+ return(structure(res,grad=list(beta=X,gamma=Z)))
+ }
+ Pred <- ginv(Xbeta)
+ p0 <- ginv(Zgamma)
+ A1 <- dginv(Xbeta)
+ A2 <- dginv(Zgamma)
+ if (subdist) {
+ dgamma <- apply(Z,2,function(z) A2*z)
+ dbeta <- apply(X,2,function(x) A1*x)
+ res <- cbind(subdist=Pred,pr=p0)
+ return(structure(res,grad=list(subdist=dbeta,pr=dgamma)))
+ }
+ Pred <- p0*Pred
+ A1 <- p0*A1
+ A2 <- Pred*dginv(Zgamma)
+ dgamma <- apply(Z,2,function(z) A2*z)
+ dbeta <- apply(X,2,function(x) A1*x)
+ attributes(Pred)$grad <- cbind(dbeta,p0*dgamma)
+ return(Pred)
+}
+
+##' @export
+residuals.zibreg <- function(object,newdata,...) {
+ if (missing(newdata)) {
+ y <- object$y
+ } else {
+ y <- model.frame(object$formula,newdata)[,1]
+ }
+ y-predict(object,newdata=newdata,...)
+}
+
+##' @export
+summary.zibreg <- function(object,level=0.95,pr.contrast,...) {
+ alpha <- 1-level
+ alpha.str <- paste(c(alpha/2,1-alpha/2)*100,"",sep="%")
+ cc <- cbind(coef(object),diag(vcov(object))^0.5)
+ pval <- 2*(pnorm(abs(cc[,1]/cc[,2]),lower.tail=FALSE))
+ qq <- qnorm(1-alpha/2)
+ cc <- cbind(cc[,1],cc[,1]-qq*cc[,2],cc[,1]+qq*cc[,2],pval)
+ colnames(cc) <- c("Estimate",alpha.str,"P-value")
+ pr.names <- unlist(lapply(rownames(cc)[object$gamma.idx],
+ function(x) substr(x,4,nchar(x))))
+ if (missing(pr.contrast)) {
+ withIntercept <- pr.names[1]=="(Intercept)"
+ pr.contrast <- diag(length(object$gamma.idx))
+ if (withIntercept) pr.contrast[,1] <- 1
+ }
+ pr.cc <- cbind(pr.contrast%*%cc[object$gamma.idx,1],
+ diag((pr.contrast)%*%vcov(object)[object$gamma.idx,object$gamma.idx]%*%t(pr.contrast))^0.5)
+ pr.cc <- object$family$linkinv(cbind(pr.cc[,1],pr.cc[,1]-qq*pr.cc[,2],pr.cc[,1]+qq*pr.cc[,2]))
+ colnames(pr.cc) <- colnames(cc)[1:3]
+ ## B <- cbind(0,cbind(0,pr.contrast))
+ ## print(compare(object,contrast=B))
+ pr.rnames <- c()
+ for (i in seq_len(nrow(pr.contrast))) {
+ Bidx <- which(pr.contrast[i,]!=0)
+ Bval <- pr.contrast[i,Bidx]; Bval[Bval==1] <- ""
+ pr.rnames <- c(pr.rnames,
+ paste0(paste0(Bval,paste0("{",pr.names[Bidx],"}"),collapse=" + ")))
+ }
+ rownames(pr.cc) <- pr.rnames
+
+ return(structure(list(coef=cc, prevalence=pr.cc),class="summary.zibreg"))
+}
+
+
+##' @export
+print.summary.zibreg <- function(x,...) {
+ print(x$coef,...)
+ cat("\nPrevalence probabilities:\n")
+ print(x$prevalence,...)
+}
+
+##' @export
+print.zibreg <- function(x,...) {
+ print(summary(x,...))
+}
+
+##' @export
+logLik.zibreg <- function(object,beta=object$beta,gamma=object$gamma,data,offset=object$offset,indiv=FALSE,...) {
+ if (!missing(data)) {
+ y <- model.frame(object$formula,data)[,1]
+ X <- model.matrix(object$formula,data)
+ Z <- model.matrix(object$formula.p,data)
+ return(zibreg_logL(beta,gamma,y,X,Z,offset,object$family,indiv=indiv,...))
+ }
+ zibreg_logL(beta,gamma,object$y,object$X,object$Z,offset,object$family,indiv=indiv,...)
+}
+zibreg_logL <- function(beta,gamma,y,X,Z,offset=NULL,family=stats::binomial(),indiv=FALSE,...) {
+ g <- family$linkfun
+ ginv <- family$linkinv
+ dginv <- family$mu.eta ## D[linkinv]
+ n <- nrow(X)
+ Xbeta <- as.vector(X%*%beta)
+ Zgamma <- as.vector(Z%*%gamma)
+ p0 <- ginv(Zgamma)
+ if (!is.null(offset)) Xbeta <- Xbeta+offset
+ Pr <- p0*ginv(Xbeta)
+ loglik <- y*log(Pr)+(1-y)*log(1-Pr)
+ if (indiv) return(loglik)
+ loglik <- sum(loglik)
+ structure(loglik,nobs=n,df=length(beta)+length(gamma),class="logLik")
+}
+
+##' @export
+score.zibreg <- function(x,beta=x$beta,gamma=x$gamma,data,offset=x$offset,indiv=FALSE,...) {
+ if (!missing(data)) {
+ y <- model.frame(x$formula,data)[,1]
+ X <- model.matrix(x$formula,data)
+ Z <- model.matrix(x$formula.p,data)
+ s <- zibreg_score(beta,gamma,y,X,Z,offset,x$family,indiv=indiv,...)
+ } else {
+ s <- zibreg_score(beta,gamma,x$y,x$X,x$Z,offset,x$family,indiv=indiv,...)
+ }
+ if (indiv) colnames(s) <- names(x$coef) else names(s) <- names(x$coef)
+ return(s)
+}
+
+zibreg_score <- function(beta,gamma,y,X,Z,offset=NULL,family=stats::binomial(),indiv=FALSE,...) {
+ g <- family$linkfun
+ ginv <- family$linkinv
+ dginv <- family$mu.eta ## D[linkinv]
+ n <- nrow(X)
+ Xbeta <- as.vector(X%*%beta)
+ Zgamma <- as.vector(Z%*%gamma)
+ p0 <- ginv(Zgamma)
+ if (!is.null(offset)) Xbeta <- Xbeta+offset
+ Pr <- p0*ginv(Xbeta)
+ A0 <- (y/Pr - (1-y)/(1-Pr))
+ A1 <- A0*p0*dginv(Xbeta)
+ A2 <- A0*ginv(Xbeta)*dginv(Zgamma)
+ dbeta <- apply(X,2,function(x) A1*x)
+ dgamma <- apply(Z,2,function(z) A2*z)
+ ss <- cbind(dbeta,dgamma)
+ if (indiv) return(ss)
+ colSums(ss)
+}
+
+##' @export
+information.zibreg <- function(x,beta=x$beta,gamma=x$gamma,data,offset=x$offset,type=c("robust","outer","obs"),...) {
+ if (!missing(data)) {
+ y <- model.frame(x$formula,data)[,1]
+ X <- model.matrix(x$formula,data)
+ Z <- model.matrix(x$formula.p,data)
+ I <- zibreg_information(beta,gamma,y,X,Z,offset,x$family,type=type,...)
+ } else {
+ I <- zibreg_information(beta,gamma,x$y,x$X,x$Z,offset,x$family,type=type,...)
+ }
+ colnames(I) <- rownames(I) <- names(x$coef)
+ return(I)
+}
+
+zibreg_information <- function(beta,gamma,y,X,Z,offset=NULL,family=stats::binomial(),type=c("outer","obs","robust"),...) {
+ if (tolower(type[1])%in%c("obs","hessian")) {
+ beta.idx <- seq(ncol(X)); gamma.idx <- seq(ncol(Z))+ncol(X)
+ I <- -numDeriv::jacobian(function(x)
+ zibreg_score(x[beta.idx],x[gamma.idx],y,X,Z,offset,family,...),c(beta,gamma))
+ return(I)
+ }
+ if (tolower(type[1])%in%c("robust","sandwich")) {
+ I <- zibreg_information(beta,gamma,y,X,Z,offset,family,type="obs")
+ J <- zibreg_information(beta,gamma,y,X,Z,offset,family,type="outer")
+ return(J%*%Inverse(I)%*%J)
+ }
+ S <- zibreg_score(beta,gamma,y,X,Z,offset,family,indiv=TRUE,...)
+ crossprod(S)
+}
diff --git a/R/zorg.R b/R/zorg.R
new file mode 100644
index 0000000..b64a8b6
--- /dev/null
+++ b/R/zorg.R
@@ -0,0 +1,72 @@
+##' Convert object to ascii suitable for org-mode
+##'
+##' @title Convert object to ascii suitable for org-mode
+##' @param x R object
+##' @param ... additional arguments to lower level functions
+##' @param ncol If \code{x} is a vector and \code{ncol} is given as argument, the resulting output will be a \code{matrix} with \code{ncol} columns
+##' @param include.rownames If \code{FALSE} row names are removed
+##' @param include.colnames If \code{FALSE} column names are removed
+##' @param header If TRUE the header is included
+##' @param frame Frame argument (see \code{ascii})
+##' @param rownames Optional vector of row names
+##' @param colnames Optional vector of column names
+##' @param type Type argument (see \code{ascii})
+##' @param tab Tabulate?
+##' @param margins Add margins to table?
+##' @param print print or return result
+##' @param html HTML prefix (added to ATTR_HTML)
+##' @param latex LaTeX prefix (added to ATTR_LaTeX)
+##' @param sep separator with type='ascii'
+##' @author Klaus K. Holst
+##' @export
+Org <- function(x,...,ncol,include.rownames=TRUE,include.colnames=TRUE,header=TRUE, frame="topbot",rownames=NULL,colnames=NULL,type="org",tab=FALSE,margins=TRUE,print=TRUE,html,latex,sep=" ") {
+ if (type=="ascii") {
+ x <- format(x,...)
+ dots <- c(list(x=paste(x,collapse=sep)),list(...))
+ dots <- dots[intersect(names(dots),names(formals(strwrap)))]
+ writeLines(do.call(strwrap,dots))
+ return(invisible(x))
+ }
+ if (!requireNamespace("ascii",quietly=TRUE)) stop("ascii package required")
+ dots <- list(...)
+ if (tab) {
+ if (!inherits(x,"table")) {
+ x <- table(x)
+ }
+ if (is.null(dots$digits)) dots$digits <- 0
+ if (margins) x <- addmargins(x)
+ }
+ if (!missing(ncol)) {
+ y <- formatC(as.vector(x))
+ n0 <- length(y)%%ncol
+ if (n0 > 0)
+ y <- c(y, rep("", ncol - n0))
+ x <- matrix(y, ncol = ncol, byrow = TRUE)
+ }
+ if (is.vector(x)) {
+ if (is.null(names(x))) {
+ include.colnames <- FALSE
+ header <- FALSE
+ }
+ x <- rbind(x)
+ if (!is.null(rownames)) {
+ rownames(x) <- rownames[1]
+ } else {
+ include.rownames <- FALSE
+ }
+ }
+ args <- c(list(x=x,include.rownames=include.rownames,include.colnames=include.colnames,header=header,frame=frame,type=type,rownames=rownames,colnames=colnames),dots)
+ x <- do.call(getFromNamespace("ascii","ascii"),args)
+ if (print) {
+ op <- options(asciiType=type)
+ if (!missing(html))
+ cat("#+ATTR_HTML: ",html,"\n",sep="")
+ if (!missing(latex))
+ cat("#+ATTR_LaTeX: ",latex,"\n",sep="")
+ suppressWarnings(do.call(getFromNamespace("print", "ascii"),c(x=x,dots)))
+ options(op)
+ }
+ invisible(x)
+}
+
+org <- Org
diff --git a/data/bmd.rda b/data/bmd.rda
new file mode 100644
index 0000000..bb80b9d
Binary files /dev/null and b/data/bmd.rda differ
diff --git a/data/bmidata.rda b/data/bmidata.rda
new file mode 100644
index 0000000..9093249
Binary files /dev/null and b/data/bmidata.rda differ
diff --git a/data/brisa.rda b/data/brisa.rda
new file mode 100644
index 0000000..224c4fc
Binary files /dev/null and b/data/brisa.rda differ
diff --git a/data/calcium.rda b/data/calcium.rda
new file mode 100644
index 0000000..87fa6cf
Binary files /dev/null and b/data/calcium.rda differ
diff --git a/data/hubble.rda b/data/hubble.rda
new file mode 100644
index 0000000..8465774
Binary files /dev/null and b/data/hubble.rda differ
diff --git a/data/hubble2.rda b/data/hubble2.rda
new file mode 100644
index 0000000..416930e
Binary files /dev/null and b/data/hubble2.rda differ
diff --git a/data/indoorenv.rda b/data/indoorenv.rda
new file mode 100644
index 0000000..d015a04
Binary files /dev/null and b/data/indoorenv.rda differ
diff --git a/data/missingdata.rda b/data/missingdata.rda
new file mode 100644
index 0000000..d9cc4cd
Binary files /dev/null and b/data/missingdata.rda differ
diff --git a/data/nldata.rda b/data/nldata.rda
new file mode 100644
index 0000000..6da9f1a
Binary files /dev/null and b/data/nldata.rda differ
diff --git a/data/nsem.rda b/data/nsem.rda
new file mode 100644
index 0000000..7bb95a0
Binary files /dev/null and b/data/nsem.rda differ
diff --git a/data/semdata.rda b/data/semdata.rda
new file mode 100644
index 0000000..21376fd
Binary files /dev/null and b/data/semdata.rda differ
diff --git a/data/serotonin.rda b/data/serotonin.rda
new file mode 100644
index 0000000..9dc9426
Binary files /dev/null and b/data/serotonin.rda differ
diff --git a/data/serotonin2.rda b/data/serotonin2.rda
new file mode 100644
index 0000000..3e8996c
Binary files /dev/null and b/data/serotonin2.rda differ
diff --git a/data/twindata.rda b/data/twindata.rda
new file mode 100644
index 0000000..181d4dc
Binary files /dev/null and b/data/twindata.rda differ
diff --git a/demo/00Index b/demo/00Index
new file mode 100644
index 0000000..8df8438
--- /dev/null
+++ b/demo/00Index
@@ -0,0 +1,5 @@
+lava All demos
+model Model specification
+simulation Simulation
+estimation Estimation
+inference Inference
diff --git a/demo/estimation.R b/demo/estimation.R
new file mode 100644
index 0000000..28f47a2
--- /dev/null
+++ b/demo/estimation.R
@@ -0,0 +1,3 @@
+example(estimate)
+example(constrain)
+example(zigreg)
diff --git a/demo/inference.R b/demo/inference.R
new file mode 100644
index 0000000..860e17e
--- /dev/null
+++ b/demo/inference.R
@@ -0,0 +1,5 @@
+example(gof)
+example(effects)
+example(estimate.default)
+example(modelsearch)
+example(predict.lvm)
diff --git a/demo/lava.R b/demo/lava.R
new file mode 100644
index 0000000..552235c
--- /dev/null
+++ b/demo/lava.R
@@ -0,0 +1,5 @@
+demo(lava:::model)
+demo(lava:::simulation)
+demo(lava:::estimation)
+demo(lava:::inference)
+
diff --git a/demo/model.R b/demo/model.R
new file mode 100644
index 0000000..f27d7cd
--- /dev/null
+++ b/demo/model.R
@@ -0,0 +1,6 @@
+example(lvm)
+example(regression)
+example(covariance)
+example(intercept)
+example(labels)
+example(plot.lvm)
diff --git a/demo/simulation.R b/demo/simulation.R
new file mode 100644
index 0000000..606c32b
--- /dev/null
+++ b/demo/simulation.R
@@ -0,0 +1,2 @@
+example(sim)
+example(eventTime)
diff --git a/inst/CITATION b/inst/CITATION
new file mode 100644
index 0000000..95e4fa9
--- /dev/null
+++ b/inst/CITATION
@@ -0,0 +1,30 @@
+## desc <- packageDescription("lava")
+## year <- sub(".*(2[[:digit:]]{3})-.*", "\\1", desc[["Date"]])
+## vers <- paste("R package version", desc[["Version"]])
+## title <- paste(desc[["Package"]], ": ", desc[["Title"]], sep="")
+## author <- desc[["Author"]]
+## plist <- personList(as.person(author))
+## textver <- paste(author, " (", year, "). ", title, ". ", vers, ".", sep="")
+
+author <- "Klaus K. Holst and Esben Budtz-Joergensen"
+year <- 2013
+journal <- "Computational Statistics"
+title <- "Linear Latent Variable Models: The lava-package"
+note <- "http://dx.doi.org/10.1007/s00180-012-0344-y"
+volume <- 28
+number <- 4
+pages <- "1385-1452"
+textver <- paste(author, " (", year, "). ", title, ". ", journal, " ", volume, " (", number ,"), pp. ", pages, ". ", note, sep="")
+
+citHeader("To cite 'lava' in publications use:")
+
+citEntry(entry="Article",
+ title = title,
+ author = author,
+ year = year,
+ volume=volume,
+ number=number,
+ pages=pages,
+ journal = journal,
+ note = note,
+ textVersion = textver)
diff --git a/inst/doc/reference.pdf b/inst/doc/reference.pdf
new file mode 100644
index 0000000..2b18a79
Binary files /dev/null and b/inst/doc/reference.pdf differ
diff --git a/inst/gof1.png b/inst/gof1.png
new file mode 100644
index 0000000..8dec11f
Binary files /dev/null and b/inst/gof1.png differ
diff --git a/inst/lava1.png b/inst/lava1.png
new file mode 100644
index 0000000..b1a656c
Binary files /dev/null and b/inst/lava1.png differ
diff --git a/inst/me1.png b/inst/me1.png
new file mode 100644
index 0000000..ca2b96b
Binary files /dev/null and b/inst/me1.png differ
diff --git a/inst/mediation1.png b/inst/mediation1.png
new file mode 100644
index 0000000..c20d68c
Binary files /dev/null and b/inst/mediation1.png differ
diff --git a/inst/mediation2.png b/inst/mediation2.png
new file mode 100644
index 0000000..c376342
Binary files /dev/null and b/inst/mediation2.png differ
diff --git a/man/By.Rd b/man/By.Rd
new file mode 100644
index 0000000..a56d581
--- /dev/null
+++ b/man/By.Rd
@@ -0,0 +1,34 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/By.R
+\name{By}
+\alias{By}
+\title{Apply a Function to a Data Frame Split by Factors}
+\usage{
+By(x, INDICES, FUN, COLUMNS, array = FALSE, ...)
+}
+\arguments{
+\item{x}{Data frame}
+
+\item{INDICES}{Indices (vector or list of indices, vector of column names, or formula of column names)}
+
+\item{FUN}{A function to be applied to data frame subsets of 'data'.}
+
+\item{COLUMNS}{(Optional) subset of columns of x to work on}
+
+\item{array}{if TRUE an array/matrix is always returned}
+
+\item{...}{Additional arguments to lower-level functions}
+}
+\description{
+Apply a Function to a Data Frame Split by Factors
+}
+\details{
+Simple wrapper of the 'by' function
+}
+\examples{
+By(datasets::CO2,~Treatment+Type,colMeans,~conc)
+By(datasets::CO2,~Treatment+Type,colMeans,~conc+uptake)
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/Col.Rd b/man/Col.Rd
new file mode 100644
index 0000000..12bcb9f
--- /dev/null
+++ b/man/Col.Rd
@@ -0,0 +1,34 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/Col.R
+\name{Col}
+\alias{Col}
+\title{Generate a transparent RGB color}
+\usage{
+Col(col, alpha = 0.2, locate = 0)
+}
+\arguments{
+\item{col}{Color (numeric or character)}
+
+\item{alpha}{Degree of transparency (0,1)}
+
+\item{locate}{Choose colour (with mouse)}
+}
+\value{
+A character vector with elements of 7 or 9 characters, '"\#"'
+ followed by the red, blue, green and optionally alpha values in
+hexadecimal (after rescaling to '0 ... 255').
+}
+\description{
+This function transforms a standard color (e.g. "red") into an
+transparent RGB-color (i.e. alpha-blend<1).
+}
+\details{
+This only works for certain graphics devices (Cairo-X11 (x11 as of R>=2.7), quartz, pdf, ...).
+}
+\examples{
+plot(runif(1000),cex=runif(1000,0,4),col=Col(c("darkblue","orange"),0.5),pch=16)
+}
+\author{
+Klaus K. Holst
+}
+\keyword{color}
diff --git a/man/Combine.Rd b/man/Combine.Rd
new file mode 100644
index 0000000..e6745f1
--- /dev/null
+++ b/man/Combine.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/combine.R
+\name{Combine}
+\alias{Combine}
+\title{Report estimates across different models}
+\usage{
+Combine(x, ...)
+}
+\arguments{
+\item{x}{list of model objects}
+
+\item{...}{additional arguments to lower level functions}
+}
+\description{
+Report estimates across different models
+}
+\examples{
+data(serotonin)
+m1 <- lm(cau ~ age*gene1 + age*gene2,data=serotonin)
+m2 <- lm(cau ~ age + gene1,data=serotonin)
+m3 <- lm(cau ~ age*gene2,data=serotonin)
+
+Combine(list(A=m1,B=m2,C=m3),fun=function(x)
+ c("_____"="",R2=" "\%++\%format(summary(x)$r.squared,digits=2)))
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/Expand.Rd b/man/Expand.Rd
new file mode 100644
index 0000000..9553762
--- /dev/null
+++ b/man/Expand.Rd
@@ -0,0 +1,31 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/Expand.R
+\name{Expand}
+\alias{Expand}
+\title{Create a Data Frame from All Combinations of Factors}
+\usage{
+Expand(`_data`, ...)
+}
+\arguments{
+\item{_data}{Data.frame}
+
+\item{...}{vectors, factors or a list containing these}
+}
+\description{
+Create a Data Frame from All Combinations of Factors
+}
+\details{
+Simple wrapper of the 'expand.grid' function. If x is a table
+then a data frame is returned with one row pr individual
+observation.
+}
+\examples{
+dd <- Expand(iris, Sepal.Length=2:8, Species=c("virginica","setosa"))
+summary(dd)
+
+T <- with(warpbreaks, table(wool, tension))
+Expand(T)
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/Graph.Rd b/man/Graph.Rd
new file mode 100644
index 0000000..9c56ba4
--- /dev/null
+++ b/man/Graph.Rd
@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/graph.R
+\name{Graph}
+\alias{Graph}
+\alias{Graph<-}
+\title{Extract graph}
+\usage{
+Graph(x, ...)
+
+Graph(x, ...) <- value
+}
+\arguments{
+\item{x}{Model object}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+
+\item{value}{New \code{graphNEL} object}
+}
+\description{
+Extract or replace graph object
+}
+\examples{
+
+m <- lvm(y~x)
+Graph(m)
+
+}
+\seealso{
+\code{\link{Model}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{graphs}
+\keyword{models}
diff --git a/man/Missing.Rd b/man/Missing.Rd
new file mode 100644
index 0000000..c79b2a8
--- /dev/null
+++ b/man/Missing.Rd
@@ -0,0 +1,76 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/Missing.R
+\name{Missing}
+\alias{Missing}
+\alias{Missing,}
+\alias{Missing<-}
+\title{Missing value generator}
+\usage{
+Missing(object, formula, Rformula, missing.name, suffix = "0", ...)
+}
+\arguments{
+\item{object}{\code{lvm}-object.}
+
+\item{formula}{The right hand side specifies the name of a latent
+variable which is not always observed. The left hand side
+specifies the name of a new variable which is equal to the latent
+variable but has missing values. If given as a string then this
+is used as the name of the latent (full-data) name, and the
+observed data name is 'missing.data'}
+
+\item{Rformula}{Missing data mechanism with left hand side
+specifying the name of the observed data indicator (may also just
+be given as a character instead of a formula)}
+
+\item{missing.name}{Name of observed data variable (only used if
+'formula' was given as a character specifying the name of the
+full-data variable)}
+
+\item{suffix}{If missing.name is missing, then the name of the
+oberved data variable will be the name of the full-data variable +
+the suffix}
+
+\item{...}{Passed to binomial.lvm.}
+}
+\value{
+lvm object
+}
+\description{
+Missing value generator
+}
+\details{
+This function adds a binary variable to a given \code{lvm} model
+and also a variable which is equal to the original variable where
+the binary variable is equal to zero
+}
+\examples{
+library(lava)
+set.seed(17)
+m <- lvm(y0~x01+x02+x03)
+m <- Missing(m,formula=x1~x01,Rformula=R1~0.3*x02+-0.7*x01,p=0.4)
+sim(m,10)
+
+
+m <- lvm(y~1)
+m <- Missing(m,"y","r")
+## same as
+## m <- Missing(m,y~1,r~1)
+sim(m,10)
+
+## same as
+m <- lvm(y~1)
+Missing(m,"y") <- r~x
+sim(m,10)
+
+m <- lvm(y~1)
+m <- Missing(m,"y","r",suffix=".")
+## same as
+## m <- Missing(m,"y","r",missing.name="y.")
+## same as
+## m <- Missing(m,y.~y,"r")
+sim(m,10)
+
+}
+\author{
+Thomas A. Gerds <tag at biostat.ku.dk>
+}
diff --git a/man/Model.Rd b/man/Model.Rd
new file mode 100644
index 0000000..62f5369
--- /dev/null
+++ b/man/Model.Rd
@@ -0,0 +1,38 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/model.R
+\name{Model}
+\alias{Model}
+\alias{Model<-}
+\title{Extract model}
+\usage{
+Model(x, ...)
+
+Model(x, ...) <- value
+}
+\arguments{
+\item{x}{Fitted model}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+
+\item{value}{New model object (e.g. \code{lvm} or \code{multigroup})}
+}
+\value{
+Returns a model object (e.g. \code{lvm} or \code{multigroup})
+}
+\description{
+Extract or replace model object
+}
+\examples{
+
+m <- lvm(y~x)
+e <- estimate(m, sim(m,100))
+Model(e)
+
+}
+\seealso{
+\code{\link{Graph}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
diff --git a/man/Org.Rd b/man/Org.Rd
new file mode 100644
index 0000000..6b2c262
--- /dev/null
+++ b/man/Org.Rd
@@ -0,0 +1,50 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/zorg.R
+\name{Org}
+\alias{Org}
+\title{Convert object to ascii suitable for org-mode}
+\usage{
+Org(x, ..., ncol, include.rownames = TRUE, include.colnames = TRUE,
+ header = TRUE, frame = "topbot", rownames = NULL, colnames = NULL,
+ type = "org", tab = FALSE, margins = TRUE, print = TRUE, html, latex,
+ sep = " ")
+}
+\arguments{
+\item{x}{R object}
+
+\item{...}{additional arguments to lower level functions}
+
+\item{ncol}{If \code{x} is a vector and \code{ncol} is given as argument, the resulting output will be a \code{matrix} with \code{ncol} columns}
+
+\item{include.rownames}{If \code{FALSE} row names are removed}
+
+\item{include.colnames}{If \code{FALSE} column names are removed}
+
+\item{header}{If TRUE the header is included}
+
+\item{frame}{Frame argument (see \code{ascii})}
+
+\item{rownames}{Optional vector of row names}
+
+\item{colnames}{Optional vector of column names}
+
+\item{type}{Type argument (see \code{ascii})}
+
+\item{tab}{Tabulate?}
+
+\item{margins}{Add margins to table?}
+
+\item{print}{print or return result}
+
+\item{html}{HTML prefix (added to ATTR_HTML)}
+
+\item{latex}{LaTeX prefix (added to ATTR_LaTeX)}
+
+\item{sep}{separator with type='ascii'}
+}
+\description{
+Convert object to ascii suitable for org-mode
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/PD.Rd b/man/PD.Rd
new file mode 100644
index 0000000..b8d6a0d
--- /dev/null
+++ b/man/PD.Rd
@@ -0,0 +1,40 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/zib.R
+\name{PD}
+\alias{PD}
+\title{Dose response calculation for binomial regression models}
+\usage{
+PD(model, intercept = 1, slope = 2, prob = NULL, x, level = 0.5,
+ ci.level = 0.95, vcov, family, EB = NULL)
+}
+\arguments{
+\item{model}{Model object or vector of parameter estimates}
+
+\item{intercept}{Index of intercept parameters}
+
+\item{slope}{Index of intercept parameters}
+
+\item{prob}{Index of mixture parameters (only relevant for
+\code{zibreg} models)}
+
+\item{x}{Optional weights
+length(x)=length(intercept)+length(slope)+length(prob)}
+
+\item{level}{Probability at which level to calculate dose}
+
+\item{ci.level}{Level of confidence limits}
+
+\item{vcov}{Optional estimate of variance matrix of parameter
+estimates}
+
+\item{family}{Optional distributional family argument}
+
+\item{EB}{Optional ratio of treatment effect and adverse effects
+used to find optimal dose (regret-function argument)}
+}
+\description{
+Dose response calculation for binomial regression models
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/Range.lvm.Rd b/man/Range.lvm.Rd
new file mode 100644
index 0000000..60c9ec0
--- /dev/null
+++ b/man/Range.lvm.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/constrain.R
+\name{Range.lvm}
+\alias{Range.lvm}
+\title{Define range constraints of parameters}
+\usage{
+Range.lvm(a = 0, b = 1)
+}
+\arguments{
+\item{a}{Lower bound}
+
+\item{b}{Upper bound}
+}
+\value{
+function
+}
+\description{
+Define range constraints of parameters
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/addvar.Rd b/man/addvar.Rd
new file mode 100644
index 0000000..7f1ff52
--- /dev/null
+++ b/man/addvar.Rd
@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/addvar.R
+\name{addvar}
+\alias{addvar}
+\alias{addvar<-}
+\title{Add variable to (model) object}
+\usage{
+addvar(x, ...)
+}
+\arguments{
+\item{x}{Model object}
+
+\item{\dots}{Additional arguments}
+}
+\description{
+Generic method for adding variables to model object
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/backdoor.Rd b/man/backdoor.Rd
new file mode 100644
index 0000000..e4dfe4f
--- /dev/null
+++ b/man/backdoor.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/backdoor.R
+\name{backdoor}
+\alias{backdoor}
+\title{Backdoor criterion}
+\usage{
+backdoor(object, f, cond, ..., return.graph = FALSE)
+}
+\arguments{
+\item{object}{lvm object}
+
+\item{f}{formula. Conditioning, z, set can be given as y~x|z}
+
+\item{cond}{Vector of variables to conditon on}
+
+\item{...}{Additional arguments to lower level functions}
+
+\item{return.graph}{Return moral ancestral graph with z and effects from x removed}
+}
+\description{
+Check backdoor criterion of a lvm object
+}
+\examples{
+m <- lvm(y~c2,c2~c1,x~c1,m1~x,y~m1, v1~c3, x~c3,v1~y,
+ x~z1, z2~z1, z2~z3, y~z3+z2+g1+g2+g3)
+ll <- backdoor(m, y~x)
+backdoor(m, y~x|c1+z1+g1)
+}
diff --git a/man/baptize.Rd b/man/baptize.Rd
new file mode 100644
index 0000000..3e2a872
--- /dev/null
+++ b/man/baptize.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/baptize.R
+\name{baptize}
+\alias{baptize}
+\title{Label elements of object}
+\usage{
+baptize(x, ...)
+}
+\arguments{
+\item{x}{Object}
+
+\item{\dots}{Additional arguments}
+}
+\description{
+Generic method for labeling elements of an object
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/blockdiag.Rd b/man/blockdiag.Rd
new file mode 100644
index 0000000..8599eaa
--- /dev/null
+++ b/man/blockdiag.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/blockdiag.R
+\name{blockdiag}
+\alias{blockdiag}
+\title{Combine matrices to block diagonal structure}
+\usage{
+blockdiag(x, ..., pad = 0)
+}
+\arguments{
+\item{x}{Matrix}
+
+\item{\dots}{Additional matrices}
+
+\item{pad}{Vyalue outside block-diagonal}
+}
+\description{
+Combine matrices to block diagonal structure
+}
+\examples{
+A <- diag(3)+1
+blockdiag(A,A,A,pad=NA)
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/bmd.Rd b/man/bmd.Rd
new file mode 100644
index 0000000..5cc41c2
--- /dev/null
+++ b/man/bmd.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{bmd}
+\alias{bmd}
+\title{Longitudinal Bone Mineral Density Data (Wide format)}
+\format{data.frame}
+\source{
+Vonesh & Chinchilli (1997), Table 5.4.1 on page 228.
+}
+\description{
+Bone Mineral Density Data consisting of 112 girls randomized to receive
+calcium og placebo. Longitudinal measurements of bone mineral density
+(g/cm^2) measured approximately every 6th month in 3 years.
+}
+\seealso{
+calcium
+}
+\keyword{datasets}
diff --git a/man/bmidata.Rd b/man/bmidata.Rd
new file mode 100644
index 0000000..d10f686
--- /dev/null
+++ b/man/bmidata.Rd
@@ -0,0 +1,11 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{bmidata}
+\alias{bmidata}
+\title{Data}
+\format{data.frame}
+\description{
+Description
+}
+\keyword{datasets}
diff --git a/man/bootstrap.Rd b/man/bootstrap.Rd
new file mode 100644
index 0000000..81c9126
--- /dev/null
+++ b/man/bootstrap.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/bootstrap.R
+\name{bootstrap}
+\alias{bootstrap}
+\title{Generic bootstrap method}
+\usage{
+bootstrap(x, ...)
+}
+\arguments{
+\item{x}{Model object}
+
+\item{\dots}{Additional arguments}
+}
+\description{
+Generic method for calculating bootstrap statistics
+}
+\seealso{
+\code{bootstrap.lvm} \code{bootstrap.lvmfit}
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/bootstrap.lvm.Rd b/man/bootstrap.lvm.Rd
new file mode 100644
index 0000000..f2b05e1
--- /dev/null
+++ b/man/bootstrap.lvm.Rd
@@ -0,0 +1,80 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/bootstrap.R
+\name{bootstrap.lvm}
+\alias{bootstrap.lvm}
+\alias{bootstrap.lvmfit}
+\title{Calculate bootstrap estimates of a lvm object}
+\usage{
+\method{bootstrap}{lvm}(x,R=100,data,fun=NULL,control=list(),
+ p, parametric=FALSE, bollenstine=FALSE,
+ constraints=TRUE,sd=FALSE,silent=FALSE,
+ parallel=lava.options()$parallel,
+ mc.cores=NULL,
+ ...)
+
+\method{bootstrap}{lvmfit}(x,R=100,data=model.frame(x),
+ control=list(start=coef(x)),
+ p=coef(x), parametric=FALSE, bollenstine=FALSE,
+ estimator=x$estimator,weights=Weights(x),...)
+}
+\arguments{
+\item{x}{\code{lvm}-object.}
+
+\item{R}{Number of bootstrap samples}
+
+\item{data}{The data to resample from}
+
+\item{fun}{Optional function of the (bootstrapped) model-fit defining the
+statistic of interest}
+
+\item{control}{Options to the optimization routine}
+
+\item{p}{Parameter vector of the null model for the parametric bootstrap}
+
+\item{parametric}{If TRUE a parametric bootstrap is calculated. If FALSE a
+non-parametric (row-sampling) bootstrap is computed.}
+
+\item{bollenstine}{Bollen-Stine transformation (non-parametric bootstrap) for bootstrap hypothesis testing.}
+
+\item{constraints}{Logical indicating whether non-linear parameter
+constraints should be included in the bootstrap procedure}
+
+\item{sd}{Logical indicating whether standard error estimates should be
+included in the bootstrap procedure}
+
+\item{silent}{Suppress messages}
+
+\item{parallel}{If TRUE parallel backend will be used}
+
+\item{mc.cores}{Number of threads (if NULL foreach::foreach will be used, otherwise parallel::mclapply)}
+
+\item{\dots}{Additional arguments, e.g. choice of estimator.}
+
+\item{estimator}{String definining estimator, e.g. 'gaussian' (see
+\code{estimator})}
+
+\item{weights}{Optional weights matrix used by \code{estimator}}
+}
+\value{
+A \code{bootstrap.lvm} object.
+}
+\description{
+Draws non-parametric bootstrap samples
+}
+\examples{
+m <- lvm(y~x)
+d <- sim(m,100)
+e <- estimate(y~x, d)
+\donttest{ ## Reduce Ex.Timings
+B <- bootstrap(e,R=50,parallel=FALSE)
+B
+}
+}
+\seealso{
+\code{\link{confint.lvmfit}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/brisa.Rd b/man/brisa.Rd
new file mode 100644
index 0000000..ea5e00d
--- /dev/null
+++ b/man/brisa.Rd
@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{brisa}
+\alias{brisa}
+\title{Simulated data}
+\format{data.frame}
+\source{
+Simulated
+}
+\description{
+Simulated data
+}
+\keyword{datasets}
diff --git a/man/calcium.Rd b/man/calcium.Rd
new file mode 100644
index 0000000..42ebb90
--- /dev/null
+++ b/man/calcium.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{calcium}
+\alias{calcium}
+\title{Longitudinal Bone Mineral Density Data}
+\format{A data.frame containing 560 (incomplete) observations. The 'person'
+column defines the individual girls of the study with measurements at
+visiting times 'visit', and age in years 'age' at the time of visit. The
+bone mineral density variable is 'bmd' (g/cm^2).}
+\source{
+Vonesh & Chinchilli (1997), Table 5.4.1 on page 228.
+}
+\description{
+Bone Mineral Density Data consisting of 112 girls randomized to receive
+calcium og placebo. Longitudinal measurements of bone mineral density
+(g/cm^2) measured approximately every 6th month in 3 years.
+}
+\keyword{datasets}
diff --git a/man/cancel.Rd b/man/cancel.Rd
new file mode 100644
index 0000000..1fddea0
--- /dev/null
+++ b/man/cancel.Rd
@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/cancel.R
+\name{cancel}
+\alias{cancel}
+\alias{cancel<-}
+\title{Generic cancel method}
+\usage{
+cancel(x, ...)
+}
+\arguments{
+\item{x}{Object}
+
+\item{\dots}{Additioal arguments}
+}
+\description{
+Generic cancel method
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/children.Rd b/man/children.Rd
new file mode 100644
index 0000000..3bc09c4
--- /dev/null
+++ b/man/children.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/children.R
+\name{children}
+\alias{children}
+\alias{parents}
+\alias{ancestors}
+\alias{descendants}
+\alias{roots}
+\alias{sinks}
+\alias{adjMat}
+\alias{edgeList}
+\title{Extract children or parent elements of object}
+\usage{
+children(object, ...)
+}
+\arguments{
+\item{object}{Object}
+
+\item{\dots}{Additional arguments}
+}
+\description{
+Generic method for memberships from object (e.g. a graph)
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/click.Rd b/man/click.Rd
new file mode 100644
index 0000000..22c579a
--- /dev/null
+++ b/man/click.Rd
@@ -0,0 +1,61 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/interactive.R
+\name{click}
+\alias{click}
+\alias{idplot}
+\alias{click.default}
+\alias{colsel}
+\title{Identify points on plot}
+\usage{
+\method{click}{default}(x, y=NULL, label=TRUE, n=length(x), pch=19, col="orange", cex=3, ...)
+idplot(x,y,...,id=list())
+}
+\arguments{
+\item{x}{X coordinates}
+
+\item{\dots}{Additional arguments parsed to \code{plot} function}
+
+\item{y}{Y coordinates}
+
+\item{label}{Should labels be added?}
+
+\item{n}{Max number of inputs to expect}
+
+\item{pch}{Symbol}
+
+\item{col}{Colour}
+
+\item{cex}{Size}
+
+\item{id}{List of arguments parsed to \code{click} function}
+}
+\description{
+Extension of the \code{identify} function
+}
+\details{
+For the usual 'X11' device the identification process is
+terminated by pressing any mouse button other than the first. For
+the 'quartz' device the process is terminated by pressing either
+the pop-up menu equivalent (usually second mouse button or
+'Ctrl'-click) or the 'ESC' key.
+}
+\examples{
+if (interactive()) {
+ n <- 10; x <- seq(n); y <- runif(n)
+ plot(y ~ x); click(x,y)
+
+ data(iris)
+ l <- lm(Sepal.Length ~ Sepal.Width*Species,iris)
+ res <- plotConf(l,var2="Species")## ylim=c(6,8), xlim=c(2.5,3.3))
+ with(res, click(x,y))
+
+ with(iris, idplot(Sepal.Length,Petal.Length))
+}
+}
+\seealso{
+\code{\link{idplot}}, \code{identify}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{iplot}
diff --git a/man/closed.testing.Rd b/man/closed.testing.Rd
new file mode 100644
index 0000000..2515125
--- /dev/null
+++ b/man/closed.testing.Rd
@@ -0,0 +1,44 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/multipletesting.R
+\name{closed.testing}
+\alias{closed.testing}
+\alias{p.correct}
+\title{Closed testing procedure}
+\usage{
+closed.testing(object, idx = seq_along(coef(object)), null = rep(0,
+ length(idx)), ...)
+}
+\arguments{
+\item{object}{estimate object}
+
+\item{idx}{Index of parameters to adjust for multiple testing}
+
+\item{null}{Null hypothesis value}
+
+\item{...}{Additional arguments}
+}
+\description{
+Closed testing procedure
+}
+\examples{
+m <- lvm()
+regression(m, c(y1,y2,y3,y4,y5,y6,y7)~x) <- c(0,0.25,0,0.25,0.25,0,0)
+regression(m, to=endogenous(m), from="u") <- 1
+variance(m,endogenous(m)) <- 1
+set.seed(2)
+d <- sim(m,200)
+l1 <- lm(y1~x,d)
+l2 <- lm(y2~x,d)
+l3 <- lm(y3~x,d)
+l4 <- lm(y4~x,d)
+l5 <- lm(y5~x,d)
+l6 <- lm(y6~x,d)
+l7 <- lm(y7~x,d)
+
+(a <- merge(l1,l2,l3,l4,l5,l6,l7,subset=2))
+if (requireNamespace("mets",quietly=TRUE)) {
+ p.correct(a)
+}
+as.vector(closed.testing(a))
+
+}
diff --git a/man/colorbar.Rd b/man/colorbar.Rd
new file mode 100644
index 0000000..25080d9
--- /dev/null
+++ b/man/colorbar.Rd
@@ -0,0 +1,52 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/zcolorbar.R
+\name{colorbar}
+\alias{colorbar}
+\title{Add color-bar to plot}
+\usage{
+colorbar(clut = Col(rev(rainbow(11, start = 0, end = 0.69)), alpha),
+ x.range = c(-0.5, 0.5), y.range = c(-0.1, 0.1), values = seq(clut),
+ digits = 2, label.offset, srt = 45, cex = 0.5, border = NA,
+ alpha = 0.5, position = 1, direction = c("horizontal", "vertical"), ...)
+}
+\arguments{
+\item{clut}{Color look-up table}
+
+\item{x.range}{x range}
+
+\item{y.range}{y range}
+
+\item{values}{label values}
+
+\item{digits}{number of digits}
+
+\item{label.offset}{label offset}
+
+\item{srt}{rotation of labels}
+
+\item{cex}{text size}
+
+\item{border}{border of color bar rectangles}
+
+\item{alpha}{Alpha (transparency) level 0-1}
+
+\item{position}{Label position left/bottom (1) or top/right (2) or no text (0)}
+
+\item{direction}{horizontal or vertical color bars}
+
+\item{\dots}{additional low level arguments (i.e. parsed to \code{text})}
+}
+\description{
+Add color-bar to plot
+}
+\examples{
+\dontrun{
+plotNeuro(x,roi=R,mm=-18,range=5)
+colorbar(clut=Col(rev(rainbow(11,start=0,end=0.69)),0.5),
+ x=c(-40,40),y.range=c(84,90),values=c(-5:5))
+
+colorbar(clut=Col(rev(rainbow(11,start=0,end=0.69)),0.5),
+ x=c(-10,10),y.range=c(-100,50),values=c(-5:5),
+ direction="vertical",border=1)
+}
+}
diff --git a/man/commutation.Rd b/man/commutation.Rd
new file mode 100644
index 0000000..58cfe5c
--- /dev/null
+++ b/man/commutation.Rd
@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/commutation.R
+\name{commutation}
+\alias{commutation}
+\title{Finds the unique commutation matrix}
+\usage{
+commutation(m, n = m)
+}
+\arguments{
+\item{m}{rows}
+
+\item{n}{columns}
+}
+\description{
+Finds the unique commutation matrix K:
+\eqn{K vec(A) = vec(A^t)}
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/compare.Rd b/man/compare.Rd
new file mode 100644
index 0000000..5aff70a
--- /dev/null
+++ b/man/compare.Rd
@@ -0,0 +1,50 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/compare.R
+\name{compare}
+\alias{compare}
+\title{Statistical tests}
+\usage{
+compare(object, ...)
+}
+\arguments{
+\item{object}{\code{lvmfit}-object}
+
+\item{\dots}{Additional arguments to low-level functions}
+}
+\value{
+Matrix of test-statistics and p-values
+}
+\description{
+Performs Likelihood-ratio, Wald and score tests
+}
+\examples{
+m <- lvm();
+regression(m) <- c(y1,y2,y3) ~ eta; latent(m) <- ~eta
+regression(m) <- eta ~ x
+m2 <- regression(m, c(y3,eta) ~ x)
+set.seed(1)
+d <- sim(m,1000)
+e <- estimate(m,d)
+e2 <- estimate(m2,d)
+
+compare(e)
+
+compare(e,e2) ## LRT, H0: y3<-x=0
+compare(e,scoretest=y3~x) ## Score-test, H0: y3~x=0
+compare(e2,par=c("y3~x")) ## Wald-test, H0: y3~x=0
+
+B <- diag(2); colnames(B) <- c("y2~eta","y3~eta")
+compare(e2,contrast=B,null=c(1,1))
+
+B <- rep(0,length(coef(e2))); B[1:3] <- 1
+compare(e2,contrast=B)
+
+compare(e,scoretest=list(y3~x,y2~x))
+}
+\seealso{
+\code{\link{modelsearch}}, \code{\link{equivalence}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{htest}
diff --git a/man/complik.Rd b/man/complik.Rd
new file mode 100644
index 0000000..a24d5ad
--- /dev/null
+++ b/man/complik.Rd
@@ -0,0 +1,46 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/complik.R
+\name{complik}
+\alias{complik}
+\title{Composite Likelihood for probit latent variable models}
+\usage{
+complik(x, data, k = 2, type = c("nearest", "all"), pairlist,
+ silent = TRUE, estimator = "normal", ...)
+}
+\arguments{
+\item{x}{\code{lvm}-object}
+
+\item{data}{data.frame}
+
+\item{k}{Size of composite groups}
+
+\item{type}{Determines number of groups. With \code{type="nearest"} (default)
+only neighboring items will be grouped, e.g. for \code{k=2}
+(y1,y2),(y2,y3),... With \code{type="all"} all combinations of size \code{k}
+are included}
+
+\item{pairlist}{A list of indices specifying the composite groups. Optional
+argument which overrides \code{k} and \code{type} but gives complete
+flexibility in the specification of the composite likelihood}
+
+\item{silent}{Turn output messsages on/off}
+
+\item{estimator}{Model (pseudo-likelihood) to use for the pairs/groups}
+
+\item{\dots}{Additional arguments parsed on to lower-level functions}
+}
+\value{
+An object of class \code{clprobit} inheriting methods from \code{lvm}
+}
+\description{
+Estimate parameters in a probit latent variable model via a composite
+likelihood decomposition.
+}
+\seealso{
+estimate
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/confband.Rd b/man/confband.Rd
new file mode 100644
index 0000000..eba5b19
--- /dev/null
+++ b/man/confband.Rd
@@ -0,0 +1,96 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/confband.R
+\name{confband}
+\alias{confband}
+\alias{forestplot}
+\title{Add Confidence limits bar to plot}
+\usage{
+confband(x, lower, upper, center = NULL, line = TRUE, delta = 0.07,
+ centermark = 0.03, pch, blank = TRUE, vert = TRUE, polygon = FALSE,
+ step = FALSE, ...)
+}
+\arguments{
+\item{x}{Position (x-coordinate if vert=TRUE, y-coordinate otherwise)}
+
+\item{lower}{Lower limit (if NULL no limits is added, and only the
+center is drawn (if not NULL))}
+
+\item{upper}{Upper limit}
+
+\item{center}{Center point}
+
+\item{line}{If FALSE do not add line between upper and lower bound}
+
+\item{delta}{Length of limit bars}
+
+\item{centermark}{Length of center bar}
+
+\item{pch}{Center symbol (if missing a line is drawn)}
+
+\item{blank}{If TRUE a white ball is plotted before the center is
+added to the plot}
+
+\item{vert}{If TRUE a vertical bar is plotted. Otherwise a horizontal
+bar is used}
+
+\item{polygon}{If TRUE polygons are added between 'lower' and 'upper'.}
+
+\item{step}{Type of polygon (step-function or piecewise linear)}
+
+\item{...}{Additional low level arguments (e.g. col, lwd, lty,...)}
+}
+\description{
+Add Confidence limits bar to plot
+}
+\examples{
+plot(0,0,type="n",xlab="",ylab="")
+confband(0.5,-0.5,0.5,0,col="darkblue")
+confband(0.8,-0.5,0.5,0,col="darkred",vert=FALSE,pch=1,cex=1.5)
+
+set.seed(1)
+K <- 20
+est <- rnorm(K)
+se <- runif(K,0.2,0.4)
+x <- cbind(est,est-2*se,est+2*se,runif(K,0.5,2))
+x[c(3:4,10:12),] <- NA
+rownames(x) <- unlist(lapply(letters[seq(K)],function(x) paste(rep(x,4),collapse="")))
+rownames(x)[which(is.na(est))] <- ""
+signif <- sign(x[,2])==sign(x[,3])
+forestplot(x,text.right=FALSE)
+forestplot(x[,-4],sep=c(2,15),col=signif+1,box1=TRUE,delta=0.2,pch=16,cex=1.5)
+forestplot(x,vert=TRUE,text=FALSE)
+forestplot(x,vert=TRUE,text=FALSE,pch=NA)
+##forestplot(x,vert=TRUE,text.vert=FALSE)
+##forestplot(val,vert=TRUE,add=TRUE)
+
+z <- seq(10)
+zu <- c(z[-1],10)
+plot(z,type="n")
+confband(z,zu,rep(0,length(z)),col=Col("darkblue"),polygon=TRUE,step=TRUE)
+confband(z,zu,zu-2,col=Col("darkred"),polygon=TRUE,step=TRUE)
+
+z <- seq(0,1,length.out=100)
+plot(z,z,type="n")
+confband(z,z,z^2,polygon="TRUE",col=Col("darkblue"))
+
+set.seed(1)
+k <- 10
+x <- seq(k)
+est <- rnorm(k)
+sd <- runif(k)
+val <- cbind(x,est,est-sd,est+sd)
+par(mfrow=c(1,2))
+plot(0,type="n",xlim=c(0,k+1),ylim=range(val[,-1]),axes=FALSE,xlab="",ylab="")
+axis(2)
+confband(val[,1],val[,3],val[,4],val[,2],pch=16,cex=2)
+plot(0,type="n",ylim=c(0,k+1),xlim=range(val[,-1]),axes=FALSE,xlab="",ylab="")
+axis(1)
+confband(val[,1],val[,3],val[,4],val[,2],pch=16,cex=2,vert=FALSE)
+}
+\seealso{
+\code{confband}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{iplot}
diff --git a/man/confint.lvmfit.Rd b/man/confint.lvmfit.Rd
new file mode 100644
index 0000000..3b14b81
--- /dev/null
+++ b/man/confint.lvmfit.Rd
@@ -0,0 +1,71 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/confint.R
+\name{confint.lvmfit}
+\alias{confint.lvmfit}
+\alias{confint.multigroupfit}
+\title{Calculate confidence limits for parameters}
+\usage{
+\method{confint}{lvmfit}(object, parm = seq_len(length(coef(object))),
+ level = 0.95, profile = FALSE, curve = FALSE, n = 20,
+ interval = NULL, lower = TRUE, upper = TRUE, ...)
+}
+\arguments{
+\item{object}{\code{lvm}-object.}
+
+\item{parm}{Index of which parameters to calculate confidence limits for.}
+
+\item{level}{Confidence level}
+
+\item{profile}{Logical expression defining whether to calculate confidence
+limits via the profile log likelihood}
+
+\item{curve}{if FALSE and profile is TRUE, confidence limits are
+returned. Otherwise, the profile curve is returned.}
+
+\item{n}{Number of points to evaluate profile log-likelihood in
+over the interval defined by \code{interval}}
+
+\item{interval}{Interval over which the profiling is done}
+
+\item{lower}{If FALSE the lower limit will not be estimated (profile intervals only)}
+
+\item{upper}{If FALSE the upper limit will not be estimated (profile intervals only)}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+}
+\value{
+A 2xp matrix with columns of lower and upper confidence limits
+}
+\description{
+Calculate Wald og Likelihood based (profile likelihood) confidence intervals
+}
+\details{
+Calculates either Wald confidence limits: \deqn{\hat{\theta} \pm
+z_{\alpha/2}*\hat\sigma_{\hat\theta}} or profile likelihood confidence
+limits, defined as the set of value \eqn{\tau}:
+\deqn{logLik(\hat\theta_{\tau},\tau)-logLik(\hat\theta)< q_{\alpha}/2}
+
+where \eqn{q_{\alpha}} is the \eqn{\alpha} fractile of the \eqn{\chi^2_1}
+distribution, and \eqn{\hat\theta_{\tau}} are obtained by maximizing the
+log-likelihood with tau being fixed.
+}
+\examples{
+
+m <- lvm(y~x)
+d <- sim(m,100)
+e <- estimate(y~x, d)
+confint(e,3,profile=TRUE)
+confint(e,3)
+\donttest{ ## Reduce Ex.timings
+B <- bootstrap(e,R=50)
+B
+}
+}
+\seealso{
+\code{\link{bootstrap}{lvm}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/confpred.Rd b/man/confpred.Rd
new file mode 100644
index 0000000..cdf78eb
--- /dev/null
+++ b/man/confpred.Rd
@@ -0,0 +1,47 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/confpred.R
+\name{confpred}
+\alias{confpred}
+\title{Conformal prediction}
+\usage{
+confpred(object, data, newdata = data, alpha = 0.05, mad, ...)
+}
+\arguments{
+\item{object}{Model object (lm, glm or similar with predict method) or formula (lm)}
+
+\item{data}{data.frame}
+
+\item{newdata}{New data.frame to make predictions for}
+
+\item{alpha}{Level of prediction interval}
+
+\item{mad}{Conditional model (formula) for the MAD (locally-weighted CP)}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\value{
+data.frame with fitted (fit), lower (lwr) and upper (upr) predictions bands.
+}
+\description{
+Conformal predicions
+}
+\examples{
+set.seed(123)
+n <- 200
+x <- seq(0,6,length.out=n)
+delta <- 3
+ss <- exp(-1+1.5*cos((x-delta)))
+ee <- rnorm(n,sd=ss)
+y <- (x-delta)+3*cos(x+4.5-delta)+ee
+d <- data.frame(y=y,x=x)
+
+newd <- data.frame(x=seq(0,6,length.out=50))
+## cc <- confpred(lm(y~ns(x,knots=c(1,3,5)),d),newdata=newd)
+cc <- confpred(lm(y~poly(x,3),d),data=d,newdata=newd)
+if (interactive()) { ##'
+plot(y~x,pch=16,col=lava::Col("black"),ylim=c(-10,15),xlab="X",ylab="Y")
+with(cc,
+ lava::confband(newd$x,lwr,upr,fit,
+ lwd=3,polygon=TRUE,col=Col("blue"),border=FALSE))
+}
+}
diff --git a/man/constrain-set.Rd b/man/constrain-set.Rd
new file mode 100644
index 0000000..70cb5ab
--- /dev/null
+++ b/man/constrain-set.Rd
@@ -0,0 +1,195 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/constrain.R
+\name{constrain<-}
+\alias{constrain<-}
+\alias{constrain}
+\alias{constrain.default}
+\alias{constrain<-.multigroup}
+\alias{constrain<-.default}
+\alias{constraints}
+\alias{parameter<-}
+\title{Add non-linear constraints to latent variable model}
+\usage{
+\method{constrain}{default}(x,par,args,...) <- value
+
+\method{constrain}{multigroup}(x,par,k=1,...) <- value
+
+constraints(object,data=model.frame(object),vcov=object$vcov,level=0.95,
+ p=pars.default(object),k,idx,...)
+}
+\arguments{
+\item{x}{\code{lvm}-object}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+
+\item{value}{Real function taking args as a vector argument}
+
+\item{par}{Name of new parameter. Alternatively a formula with lhs
+specifying the new parameter and the rhs defining the names of the
+parameters or variable names defining the new parameter (overruling the
+\code{args} argument).}
+
+\item{args}{Vector of variables names or parameter names that are used in
+defining \code{par}}
+
+\item{k}{For multigroup models this argument specifies which group to
+add/extract the constraint}
+
+\item{object}{\code{lvm}-object}
+
+\item{data}{Data-row from which possible non-linear constraints should be
+calculated}
+
+\item{vcov}{Variance matrix of parameter estimates}
+
+\item{level}{Level of confidence limits}
+
+\item{p}{Parameter vector}
+
+\item{idx}{Index indicating which constraints to extract}
+}
+\value{
+A \code{lvm} object.
+}
+\description{
+Add non-linear constraints to latent variable model
+}
+\details{
+Add non-linear parameter constraints as well as non-linear associations
+between covariates and latent or observed variables in the model (non-linear
+regression).
+
+As an example we will specify the follow multiple regression model:
+
+\deqn{E(Y|X_1,X_2) = \alpha + \beta_1 X_1 + \beta_2 X_2} \deqn{V(Y|X_1,X_2)
+= v}
+
+which is defined (with the appropiate parameter labels) as
+
+\code{m <- lvm(y ~ f(x,beta1) + f(x,beta2))}
+
+\code{intercept(m) <- y ~ f(alpha)}
+
+\code{covariance(m) <- y ~ f(v)}
+
+The somewhat strained parameter constraint \deqn{ v =
+\frac{(beta1-beta2)^2}{alpha}}
+
+can then specified as
+
+\code{constrain(m,v ~ beta1 + beta2 + alpha) <- function(x)
+(x[1]-x[2])^2/x[3] }
+
+A subset of the arguments \code{args} can be covariates in the model,
+allowing the specification of non-linear regression models. As an example
+the non-linear regression model \deqn{ E(Y\mid X) = \nu + \Phi(\alpha +
+\beta X)} where \eqn{\Phi} denotes the standard normal cumulative
+distribution function, can be defined as
+
+\code{m <- lvm(y ~ f(x,0)) # No linear effect of x}
+
+Next we add three new parameters using the \code{parameter} assigment
+function:
+
+\code{parameter(m) <- ~nu+alpha+beta}
+
+The intercept of \eqn{Y} is defined as \code{mu}
+
+\code{intercept(m) <- y ~ f(mu)}
+
+And finally the newly added intercept parameter \code{mu} is defined as the
+appropiate non-linear function of \eqn{\alpha}, \eqn{\nu} and \eqn{\beta}:
+
+\code{constrain(m, mu ~ x + alpha + nu) <- function(x)
+pnorm(x[1]*x[2])+x[3]}
+
+The \code{constraints} function can be used to show the estimated non-linear
+parameter constraints of an estimated model object (\code{lvmfit} or
+\code{multigroupfit}). Calling \code{constrain} with no additional arguments
+beyound \code{x} will return a list of the functions and parameter names
+defining the non-linear restrictions.
+
+The gradient function can optionally be added as an attribute \code{grad} to
+the return value of the function defined by \code{value}. In this case the
+analytical derivatives will be calculated via the chain rule when evaluating
+the corresponding score function of the log-likelihood. If the gradient
+attribute is omitted the chain rule will be applied on a numeric
+approximation of the gradient.
+}
+\examples{
+##############################
+### Non-linear parameter constraints 1
+##############################
+m <- lvm(y ~ f(x1,gamma)+f(x2,beta))
+covariance(m) <- y ~ f(v)
+d <- sim(m,100)
+m1 <- m; constrain(m1,beta ~ v) <- function(x) x^2
+## Define slope of x2 to be the square of the residual variance of y
+## Estimate both restricted and unrestricted model
+e <- estimate(m,d,control=list(method="NR"))
+e1 <- estimate(m1,d)
+p1 <- coef(e1)
+p1 <- c(p1[1:2],p1[3]^2,p1[3])
+## Likelihood of unrestricted model evaluated in MLE of restricted model
+logLik(e,p1)
+## Likelihood of restricted model (MLE)
+logLik(e1)
+
+##############################
+### Non-linear regression
+##############################
+
+## Simulate data
+m <- lvm(c(y1,y2)~f(x,0)+f(eta,1))
+latent(m) <- ~eta
+covariance(m,~y1+y2) <- "v"
+intercept(m,~y1+y2) <- "mu"
+covariance(m,~eta) <- "zeta"
+intercept(m,~eta) <- 0
+set.seed(1)
+d <- sim(m,100,p=c(v=0.01,zeta=0.01))[,manifest(m)]
+d <- transform(d,
+ y1=y1+2*pnorm(2*x),
+ y2=y2+2*pnorm(2*x))
+
+## Specify model and estimate parameters
+constrain(m, mu ~ x + alpha + nu + gamma) <- function(x) x[4]*pnorm(x[3]+x[1]*x[2])
+\donttest{ ## Reduce Ex.Timings
+e <- estimate(m,d,control=list(trace=1,constrain=TRUE))
+constraints(e,data=d)
+## Plot model-fit
+plot(y1~x,d,pch=16); points(y2~x,d,pch=16,col="gray")
+x0 <- seq(-4,4,length.out=100)
+lines(x0,coef(e)["nu"] + coef(e)["gamma"]*pnorm(coef(e)["alpha"]*x0))
+}
+
+##############################
+### Multigroup model
+##############################
+### Define two models
+m1 <- lvm(y ~ f(x,beta)+f(z,beta2))
+m2 <- lvm(y ~ f(x,psi) + z)
+### And simulate data from them
+d1 <- sim(m1,500)
+d2 <- sim(m2,500)
+### Add 'non'-linear parameter constraint
+constrain(m2,psi ~ beta2) <- function(x) x
+## Add parameter beta2 to model 2, now beta2 exists in both models
+parameter(m2) <- ~ beta2
+ee <- estimate(list(m1,m2),list(d1,d2),control=list(method="NR"))
+summary(ee)
+
+m3 <- lvm(y ~ f(x,beta)+f(z,beta2))
+m4 <- lvm(y ~ f(x,beta2) + z)
+e2 <- estimate(list(m3,m4),list(d1,d2),control=list(method="NR"))
+e2
+}
+\seealso{
+\code{\link{regression}}, \code{\link{intercept}},
+\code{\link{covariance}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/contr.Rd b/man/contr.Rd
new file mode 100644
index 0000000..ad84b99
--- /dev/null
+++ b/man/contr.Rd
@@ -0,0 +1,31 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/contr.R
+\name{contr}
+\alias{contr}
+\alias{parsedesign}
+\title{Create contrast matrix}
+\usage{
+contr(p, n, diff = TRUE, ...)
+}
+\arguments{
+\item{p}{index of non-zero entries (see example)}
+
+\item{n}{Total number of parameters (if omitted the max number in p will be used)}
+
+\item{diff}{If FALSE all non-zero entries are +1, otherwise the second non-zero element in each row will be -1.}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\description{
+Create contrast matrix typically for use with 'estimate' (Wald tests).
+}
+\examples{
+contr(2,n=5)
+contr(as.list(2:4),n=5)
+contr(list(1,2,4),n=5)
+contr(c(2,3,4),n=5)
+contr(list(c(1,3),c(2,4)),n=5)
+contr(list(c(1,3),c(2,4),5))
+
+parsedesign(c("aa","b","c"),"?","?",diff=c(FALSE,TRUE))
+}
diff --git a/man/correlation.Rd b/man/correlation.Rd
new file mode 100644
index 0000000..177959f
--- /dev/null
+++ b/man/correlation.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/correlation.R
+\name{correlation}
+\alias{correlation}
+\title{Generic method for extracting correlation coefficients of model object}
+\usage{
+correlation(x, ...)
+}
+\arguments{
+\item{x}{Object}
+
+\item{\dots}{Additional arguments}
+}
+\description{
+Generic correlation method
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/covariance.Rd b/man/covariance.Rd
new file mode 100644
index 0000000..3754208
--- /dev/null
+++ b/man/covariance.Rd
@@ -0,0 +1,120 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/covariance.R
+\name{covariance}
+\alias{covariance}
+\alias{covariance<-}
+\alias{covariance.lvm}
+\alias{covariance<-.lvm}
+\alias{covfix<-}
+\alias{covfix}
+\alias{covfix<-.lvm}
+\alias{covfix.lvm}
+\alias{variance}
+\alias{variance<-}
+\alias{variance.lvm}
+\alias{variance<-.lvm}
+\title{Add covariance structure to Latent Variable Model}
+\usage{
+\method{covariance}{lvm}(object, var1=NULL, var2=NULL, constrain=FALSE, pairwise=FALSE,...) <- value
+}
+\arguments{
+\item{object}{\code{lvm}-object}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+
+\item{var1}{Vector of variables names (or formula)}
+
+\item{var2}{Vector of variables names (or formula) defining pairwise
+covariance between \code{var1} and \code{var2})}
+
+\item{constrain}{Define non-linear parameter constraints to ensure positive definite structure}
+
+\item{pairwise}{If TRUE and \code{var2} is omitted then pairwise correlation is added between all variables in \code{var1}}
+
+\item{value}{List of parameter values or (if \code{var1} is unspecified)}
+}
+\value{
+A \code{lvm}-object
+}
+\description{
+Define covariances between residual terms in a \code{lvm}-object.
+}
+\details{
+The \code{covariance} function is used to specify correlation structure
+between residual terms of a latent variable model, using a formula syntax.
+
+For instance, a multivariate model with three response variables,
+
+\deqn{Y_1 = \mu_1 + \epsilon_1}
+
+\deqn{Y_2 = \mu_2 + \epsilon_2}
+
+\deqn{Y_3 = \mu_3 + \epsilon_3}
+
+can be specified as
+
+\code{m <- lvm(~y1+y2+y3)}
+
+Pr. default the two variables are assumed to be independent. To add a
+covariance parameter \eqn{r = cov(\epsilon_1,\epsilon_2)}, we execute the
+following code
+
+\code{covariance(m) <- y1 ~ f(y2,r)}
+
+The special function \code{f} and its second argument could be omitted thus
+assigning an unique parameter the covariance between \code{y1} and
+\code{y2}.
+
+Similarily the marginal variance of the two response variables can be fixed
+to be identical (\eqn{var(Y_i)=v}) via
+
+\code{covariance(m) <- c(y1,y2,y3) ~ f(v)}
+
+To specify a completely unstructured covariance structure, we can call
+
+\code{covariance(m) <- ~y1+y2+y3}
+
+All the parameter values of the linear constraints can be given as the right
+handside expression of the assigment function \code{covariance<-} if the
+first (and possibly second) argument is defined as well. E.g:
+
+\code{covariance(m,y1~y1+y2) <- list("a1","b1")}
+
+\code{covariance(m,~y2+y3) <- list("a2",2)}
+
+Defines
+
+\deqn{var(\epsilon_1) = a1}
+
+\deqn{var(\epsilon_2) = a2}
+
+\deqn{var(\epsilon_3) = 2}
+
+\deqn{cov(\epsilon_1,\epsilon_2) = b1}
+
+Parameter constraints can be cleared by fixing the relevant parameters to
+\code{NA} (see also the \code{regression} method).
+
+The function \code{covariance} (called without additional arguments) can be
+used to inspect the covariance constraints of a \code{lvm}-object.
+}
+\examples{
+
+m <- lvm()
+### Define covariance between residuals terms of y1 and y2
+covariance(m) <- y1~y2
+covariance(m) <- c(y1,y2)~f(v) ## Same marginal variance
+covariance(m) ## Examine covariance structure
+
+
+}
+\seealso{
+\code{\link{regression<-}}, \code{\link{intercept<-}},
+\code{\link{constrain<-}} \code{\link{parameter<-}}, \code{\link{latent<-}},
+\code{\link{cancel<-}}, \code{\link{kill<-}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/csplit.Rd b/man/csplit.Rd
new file mode 100644
index 0000000..2d7cdb3
--- /dev/null
+++ b/man/csplit.Rd
@@ -0,0 +1,34 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/csplit.R
+\name{csplit}
+\alias{csplit}
+\alias{foldr}
+\title{Split data into folds}
+\usage{
+csplit(x, p = NULL, replace = FALSE, return.index = FALSE, k = 2, ...)
+}
+\arguments{
+\item{x}{Data or integer (size)}
+
+\item{p}{Number of folds, or if a number between 0 and 1 is given two folds of size p and (1-p) will be returned}
+
+\item{replace}{With or with-out replacement}
+
+\item{return.index}{If TRUE index of folds are returned otherwise the actual data splits are returned (default)}
+
+\item{k}{(Optional, only used when p=NULL) number of folds without shuffling}
+
+\item{...}{additional arguments to lower level functions}
+}
+\description{
+Split data into folds
+}
+\examples{
+foldr(5,2,rep=2)
+csplit(10,3)
+csplit(iris[1:10,]) ## Split in two sets 1:(n/2) and (n/2+1):n
+csplit(iris[1:10,],0.5)
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/curly.Rd b/man/curly.Rd
new file mode 100644
index 0000000..af45526
--- /dev/null
+++ b/man/curly.Rd
@@ -0,0 +1,51 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/curly.R
+\name{curly}
+\alias{curly}
+\title{Adds curly brackets to plot}
+\usage{
+curly(x, y, len = 1, theta = 0, wid, shape = 1, col = 1, lwd = 1,
+ lty = 1, grid = FALSE, npoints = 50, text = NULL, offset = c(0.05,
+ 0))
+}
+\arguments{
+\item{x}{center of the x axis of the curly brackets (or start end coordinates (x1,x2))}
+
+\item{y}{center of the y axis of the curly brackets (or start end coordinates (y1,y2))}
+
+\item{len}{Length of the curly brackets}
+
+\item{theta}{angle (in radians) of the curly brackets orientation}
+
+\item{wid}{Width of the curly brackets}
+
+\item{shape}{shape (curvature)}
+
+\item{col}{color (passed to lines/grid.lines)}
+
+\item{lwd}{line width (passed to lines/grid.lines)}
+
+\item{lty}{line type (passed to lines/grid.lines)}
+
+\item{grid}{If TRUE use grid graphics (compatability with ggplot2)}
+
+\item{npoints}{Number of points used in curves}
+
+\item{text}{Label}
+
+\item{offset}{Label offset (x,y)}
+}
+\description{
+Adds curly brackets to plot
+}
+\examples{
+if (interactive()) {
+plot(0,0,type="n",axes=FALSE,xlab="",ylab="")
+curly(x=c(1,0),y=c(0,1),lwd=2,text="a")
+curly(x=c(1,0),y=c(0,1),lwd=2,text="b",theta=pi)
+curly(x=-0.5,y=0,shape=1,theta=pi,text="c")
+curly(x=0,y=0,shape=1,theta=0,text="d")
+curly(x=0.5,y=0,len=0.2,theta=pi/2,col="blue",lty=2)
+curly(x=0.5,y=-0.5,len=0.2,theta=-pi/2,col="red",shape=1e3,text="e")
+}
+}
diff --git a/man/cv.Rd b/man/cv.Rd
new file mode 100644
index 0000000..fd175fa
--- /dev/null
+++ b/man/cv.Rd
@@ -0,0 +1,42 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/cv.R
+\name{cv}
+\alias{cv}
+\title{Cross-validation}
+\usage{
+cv(modelList, data, K = 5, rep = 1, perf, seed = NULL, mc.cores = 1,
+ ...)
+}
+\arguments{
+\item{modelList}{List of fitting functions or models}
+
+\item{data}{data.frame}
+
+\item{K}{Number of folds (default 5)}
+
+\item{rep}{Number of repetitions (default 1)}
+
+\item{perf}{Performance measure (default RMSE)}
+
+\item{seed}{Optional random seed}
+
+\item{mc.cores}{Number of cores used for parallel computations}
+
+\item{...}{Additional arguments parsed to models in modelList and perf}
+}
+\description{
+Cross-validation
+}
+\details{
+Generic cross-validation function
+}
+\examples{
+f0 <- function(data,...) lm(...,data)
+f1 <- function(data,...) lm(Sepal.Length~Species,data)
+f2 <- function(data,...) lm(Sepal.Length~Species+Petal.Length,data)
+x <- cv(list(m0=f0,m1=f1,m2=f2),rep=10, data=iris, formula=Sepal.Length~.)
+x2 <- cv(list(f0(iris),f1(iris),f2(iris)),rep=10, data=iris)
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/density.sim.Rd b/man/density.sim.Rd
new file mode 100644
index 0000000..88e7404
--- /dev/null
+++ b/man/density.sim.Rd
@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/sim.default.R
+\name{density.sim}
+\alias{density.sim}
+\alias{plot.sim}
+\title{Plot sim object}
+\usage{
+\method{density}{sim}(x, ..., plot.type = "single")
+}
+\arguments{
+\item{x}{sim object}
+
+\item{...}{Graphical arguments to plot.sim}
+
+\item{plot.type}{Single or multiple plots}
+}
+\description{
+Plot sim object
+}
+\examples{
+n <- 1000
+val <- cbind(est1=rnorm(n,sd=1),est2=rnorm(n,sd=0.2),est3=rnorm(n,1,sd=0.5),
+ sd1=runif(n,0.8,1.2),sd2=runif(n,0.1,0.3),sd3=runif(n,0.25,0.75))
+
+plot.sim(val,estimate=c(1,2),true=c(0,0),se=c(4,5),equal=TRUE)
+plot.sim(val,estimate=c(1,3),true=c(0,1),se=c(4,6),density.xlim=c(-3,3),ylim=c(-3,3))
+plot.sim(val,estimate=c(1,2),true=c(0,0),se=c(4,5),equal=TRUE,plot.type="single")
+plot.sim(val,estimate=c(1),se=c(4,5,6),plot.type="single")
+plot.sim(val,estimate=c(1,2,3),equal=TRUE)
+plot.sim(val,estimate=c(1,2,3),equal=TRUE,byrow=TRUE)
+plot.sim(val,estimate=c(1,2,3),plot.type="single")
+plot.sim(val,estimate=1,se=c(3,4,5),plot.type="single")
+
+density.sim(val,estimate=c(1,2,3),polygon.density=c(0,10,10),polygon.angle=c(0,45,-45))
+}
diff --git a/man/devcoords.Rd b/man/devcoords.Rd
new file mode 100644
index 0000000..0acd294
--- /dev/null
+++ b/man/devcoords.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/devcoords.R
+\name{devcoords}
+\alias{devcoords}
+\title{Returns device-coordinates and plot-region}
+\usage{
+devcoords()
+}
+\value{
+A \code{list} with elements
+ \item{dev.x1}{Device: Left x-coordinate}
+ \item{dev.x2}{Device: Right x-coordinate}
+ \item{dev.y1}{Device Bottom y-coordinate}
+ \item{dev.y2}{Device Top y-coordinate}
+ \item{fig.x1}{Plot: Left x-coordinate}
+ \item{fig.x2}{Plot: Right x-coordinate}
+ \item{fig.y1}{Plot: Bottom y-coordinate}
+ \item{fig.y2}{Plot: Top y-coordinate}
+}
+\description{
+Returns device-coordinates and plot-region
+}
+\author{
+Klaus K. Holst
+}
+\keyword{hplot}
diff --git a/man/diagtest.Rd b/man/diagtest.Rd
new file mode 100644
index 0000000..eb5f571
--- /dev/null
+++ b/man/diagtest.Rd
@@ -0,0 +1,45 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/diagtest.R
+\name{diagtest}
+\alias{diagtest}
+\alias{odds}
+\alias{riskcomp}
+\alias{OR}
+\alias{Ratio}
+\alias{Diff}
+\title{Calculate diagnostic tests for 2x2 table}
+\usage{
+diagtest(table, positive = 2, exact = FALSE, p0 = NA,
+ confint = c("logit", "arcsin", "pseudoscore", "exact"), ...)
+}
+\arguments{
+\item{table}{Table or (matrix/data.frame with two columns)}
+
+\item{positive}{Switch reference}
+
+\item{exact}{If TRUE exact binomial proportions CI/test will be used}
+
+\item{p0}{Optional null hypothesis (test prevalenc, sensitivity, ...)}
+
+\item{confint}{Type of confidence limits}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\description{
+Calculate prevalence, sensitivity, specificity, and positive and
+negative predictive values
+}
+\details{
+Table should be in the format with outcome in columns and
+ test in rows. Data.frame should be with test in the first
+ column and outcome in the second column.
+}
+\examples{
+M <- as.table(matrix(c(42,12,
+ 35,28),ncol=2,byrow=TRUE,
+ dimnames=list(rater=c("no","yes"),gold=c("no","yes"))))
+diagtest(M,exact=TRUE)
+}
+\author{
+Klaus Holst
+}
diff --git a/man/dsep.lvm.Rd b/man/dsep.lvm.Rd
new file mode 100644
index 0000000..eacde9f
--- /dev/null
+++ b/man/dsep.lvm.Rd
@@ -0,0 +1,39 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/dsep.R
+\name{dsep.lvm}
+\alias{dsep.lvm}
+\alias{dsep}
+\title{Check d-separation criterion}
+\usage{
+\method{dsep}{lvm}(object, x, cond = NULL, return.graph = FALSE, ...)
+}
+\arguments{
+\item{object}{lvm object}
+
+\item{x}{Variables for which to check for conditional independence}
+
+\item{cond}{Conditioning set}
+
+\item{return.graph}{If TRUE the moralized ancestral graph with the
+conditioning set removed is returned}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\description{
+Check for conditional independence (d-separation)
+}
+\details{
+The argument 'x' can be given as a formula, e.g. x~y|z+v
+ or ~x+y|z+v With everything on the rhs of the bar defining the
+ variables on which to condition on.
+}
+\examples{
+m <- lvm(x5 ~ x4+x3, x4~x3+x1, x3~x2, x2~x1)
+if (interactive()) {
+plot(m,layoutType='neato')
+}
+dsep(m,x5~x1|x2+x4)
+dsep(m,x5~x1|x3+x4)
+dsep(m,~x1+x2+x3|x4)
+
+}
diff --git a/man/equivalence.Rd b/man/equivalence.Rd
new file mode 100644
index 0000000..1547e79
--- /dev/null
+++ b/man/equivalence.Rd
@@ -0,0 +1,34 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/equivalence.R
+\name{equivalence}
+\alias{equivalence}
+\title{Identify candidates of equivalent models}
+\usage{
+equivalence(x, rel, tol = 0.001, k = 1, omitrel = TRUE, ...)
+}
+\arguments{
+\item{x}{\code{lvmfit}-object}
+
+\item{rel}{Formula or character-vector specifying two variables to omit from
+the model and subsequently search for possible equivalent models}
+
+\item{tol}{Define two models as empirical equivalent if the absolute
+difference in score test is less than \code{tol}}
+
+\item{k}{Number of parameters to test simultaneously. For \code{equivalence}
+the number of additional associations to be added instead of \code{rel}.}
+
+\item{omitrel}{if \code{k} greater than 1, this boolean defines wether to
+omit candidates containing \code{rel} from the output}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+}
+\description{
+Identifies candidates of equivalent models
+}
+\seealso{
+\code{\link{compare}}, \code{\link{modelsearch}}
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/estimate.default.Rd b/man/estimate.default.Rd
new file mode 100644
index 0000000..8c8f0ce
--- /dev/null
+++ b/man/estimate.default.Rd
@@ -0,0 +1,201 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/estimate.default.R
+\name{estimate.default}
+\alias{estimate.default}
+\alias{estimate}
+\alias{estimate.estimate}
+\alias{merge.estimate}
+\title{Estimation of functional of parameters}
+\usage{
+\method{estimate}{default}(x = NULL, f = NULL, ..., data, id, iddata,
+ stack = TRUE, average = FALSE, subset, score.deriv, level = 0.95,
+ iid = TRUE, type = c("robust", "df", "mbn"), keep, use, contrast, null,
+ vcov, coef, robust = TRUE, df = NULL, print = NULL, labels, label.width,
+ only.coef = FALSE, back.transform = NULL, folds = 0, cluster, R = 0,
+ null.sim)
+}
+\arguments{
+\item{x}{model object (\code{glm}, \code{lvmfit}, ...)}
+
+\item{f}{transformation of model parameters and (optionally) data, or contrast matrix (or vector)}
+
+\item{...}{additional arguments to lower level functions}
+
+\item{data}{\code{data.frame}}
+
+\item{id}{(optional) id-variable corresponding to iid decomposition of model parameters.}
+
+\item{iddata}{(optional) id-variable for 'data'}
+
+\item{stack}{if TRUE (default) the i.i.d. decomposition is automatically stacked according to 'id'}
+
+\item{average}{if TRUE averages are calculated}
+
+\item{subset}{(optional) subset of data.frame on which to condition (logical expression or variable name)}
+
+\item{score.deriv}{(optional) derivative of mean score function}
+
+\item{level}{level of confidence limits}
+
+\item{iid}{if TRUE (default) the iid decompositions are also returned (extract with \code{iid} method)}
+
+\item{type}{type of small-sample correction}
+
+\item{keep}{(optional) index of parameters to keep from final result}
+
+\item{use}{(optional) index of parameters to use in calculations}
+
+\item{contrast}{(optional) Contrast matrix for final Wald test}
+
+\item{null}{(optional) null hypothesis to test}
+
+\item{vcov}{(optional) covariance matrix of parameter estimates (e.g. Wald-test)}
+
+\item{coef}{(optional) parameter coefficient}
+
+\item{robust}{if TRUE robust standard errors are calculated. If
+FALSE p-values for linear models are calculated from t-distribution}
+
+\item{df}{degrees of freedom (default obtained from 'df.residual')}
+
+\item{print}{(optional) print function}
+
+\item{labels}{(optional) names of coefficients}
+
+\item{label.width}{(optional) max width of labels}
+
+\item{only.coef}{if TRUE only the coefficient matrix is return}
+
+\item{back.transform}{(optional) transform of parameters and confidence intervals}
+
+\item{folds}{(optional) aggregate influence functions (divide and conquer)}
+
+\item{cluster}{(obsolete) alias for 'id'.}
+
+\item{R}{Number of simulations (simulated p-values)}
+
+\item{null.sim}{Mean under the null for simulations}
+}
+\description{
+Estimation of functional of parameters.
+Wald tests, robust standard errors, cluster robust standard errors,
+LRT (when \code{f} is not a function)...
+}
+\details{
+iid decomposition
+\deqn{\sqrt{n}(\widehat{\theta}-\theta) = \sum_{i=1}^n\epsilon_i + o_p(1)}
+can be extracted with the \code{iid} method.
+}
+\examples{
+
+## Simulation from logistic regression model
+m <- lvm(y~x+z);
+distribution(m,y~x) <- binomial.lvm("logit")
+d <- sim(m,1000)
+g <- glm(y~z+x,data=d,family=binomial())
+g0 <- glm(y~1,data=d,family=binomial())
+
+## LRT
+estimate(g,g0)
+
+## Plain estimates (robust standard errors)
+estimate(g)
+
+## Testing contrasts
+estimate(g,null=0)
+estimate(g,rbind(c(1,1,0),c(1,0,2)))
+estimate(g,rbind(c(1,1,0),c(1,0,2)),null=c(1,2))
+estimate(g,2:3) ## same as cbind(0,1,-1)
+estimate(g,as.list(2:3)) ## same as rbind(c(0,1,0),c(0,0,1))
+## Alternative syntax
+estimate(g,"z","z"-"x",2*"z"-3*"x")
+estimate(g,z,z-x,2*z-3*x)
+estimate(g,"?") ## Wilcards
+estimate(g,"*Int*","z")
+estimate(g,"1","2"-"3",null=c(0,1))
+estimate(g,2,3)
+
+## Usual (non-robust) confidence intervals
+estimate(g,robust=FALSE)
+
+## Transformations
+estimate(g,function(p) p[1]+p[2])
+
+## Multiple parameters
+e <- estimate(g,function(p) c(p[1]+p[2],p[1]*p[2]))
+e
+vcov(e)
+
+## Label new parameters
+estimate(g,function(p) list("a1"=p[1]+p[2],"b1"=p[1]*p[2]))
+##'
+## Multiple group
+m <- lvm(y~x)
+m <- baptize(m)
+d2 <- d1 <- sim(m,50)
+e <- estimate(list(m,m),list(d1,d2))
+estimate(e) ## Wrong
+estimate(e,id=rep(seq(nrow(d1)),2))
+estimate(lm(y~x,d1))
+
+## Marginalize
+f <- function(p,data)
+ list(p0=lava:::expit(p["(Intercept)"] + p["z"]*data[,"z"]),
+ p1=lava:::expit(p["(Intercept)"] + p["x"] + p["z"]*data[,"z"]))
+e <- estimate(g, f, average=TRUE)
+e
+estimate(e,diff)
+estimate(e,cbind(1,1))
+
+## Clusters and subset (conditional marginal effects)
+d$id <- rep(seq(nrow(d)/4),each=4)
+estimate(g,function(p,data)
+ list(p0=lava:::expit(p[1] + p["z"]*data[,"z"])),
+ subset=d$z>0, id=d$id, average=TRUE)
+
+## More examples with clusters:
+m <- lvm(c(y1,y2,y3)~u+x)
+d <- sim(m,10)
+l1 <- glm(y1~x,data=d)
+l2 <- glm(y2~x,data=d)
+l3 <- glm(y3~x,data=d)
+
+## Some random id-numbers
+id1 <- c(1,1,4,1,3,1,2,3,4,5)
+id2 <- c(1,2,3,4,5,6,7,8,1,1)
+id3 <- seq(10)
+
+## Un-stacked and stacked i.i.d. decomposition
+iid(estimate(l1,id=id1,stack=FALSE))
+iid(estimate(l1,id=id1))
+
+## Combined i.i.d. decomposition
+e1 <- estimate(l1,id=id1)
+e2 <- estimate(l2,id=id2)
+e3 <- estimate(l3,id=id3)
+(a2 <- merge(e1,e2,e3))
+
+## If all models were estimated on the same data we could use the
+## syntax:
+## Reduce(merge,estimate(list(l1,l2,l3)))
+
+## Same:
+iid(a1 <- merge(l1,l2,l3,id=list(id1,id2,id3)))
+
+iid(merge(l1,l2,l3,id=TRUE)) # one-to-one (same clusters)
+iid(merge(l1,l2,l3,id=FALSE)) # independence
+
+
+## Monte Carlo approach, simple trend test example
+
+m <- categorical(lvm(),~x,K=5)
+regression(m,additive=TRUE) <- y~x
+d <- simulate(m,100,seed=1,'y~x'=0.1)
+l <- lm(y~-1+factor(x),data=d)
+
+f <- function(x) coef(lm(x~seq_along(x)))[2]
+null <- rep(mean(coef(l)),length(coef(l))) ## just need to make sure we simulate under H0: slope=0
+estimate(l,f,R=1e2,null.sim=null)
+
+estimate(l,f)
+}
diff --git a/man/estimate.lvm.Rd b/man/estimate.lvm.Rd
new file mode 100644
index 0000000..a024890
--- /dev/null
+++ b/man/estimate.lvm.Rd
@@ -0,0 +1,150 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/estimate.lvm.R
+\name{estimate.lvm}
+\alias{estimate.lvm}
+\title{Estimation of parameters in a Latent Variable Model (lvm)}
+\usage{
+\method{estimate}{lvm}(x, data = parent.frame(), estimator = NULL,
+ control = list(), missing = FALSE, weights, weightsname, data2, id, fix,
+ index = !quick, graph = FALSE, silent = lava.options()$silent,
+ quick = FALSE, method, param, cluster, p, ...)
+}
+\arguments{
+\item{x}{\code{lvm}-object}
+
+\item{data}{\code{data.frame}}
+
+\item{estimator}{String defining the estimator (see details below)}
+
+\item{control}{control/optimization parameters (see details below)}
+
+\item{missing}{Logical variable indiciating how to treat missing data.
+Setting to FALSE leads to complete case analysis. In the other case
+likelihood based inference is obtained by integrating out the missing data
+under assumption the assumption that data is missing at random (MAR).}
+
+\item{weights}{Optional weights to used by the chosen estimator.}
+
+\item{weightsname}{Weights names (variable names of the model) in case
+\code{weights} was given as a vector of column names of \code{data}}
+
+\item{data2}{Optional additional dataset used by the chosen
+estimator.}
+
+\item{id}{Vector (or name of column in \code{data}) that identifies
+correlated groups of observations in the data leading to variance estimates
+based on a sandwich estimator}
+
+\item{fix}{Logical variable indicating whether parameter restriction
+automatically should be imposed (e.g. intercepts of latent variables set to
+0 and at least one regression parameter of each measurement model fixed to
+ensure identifiability.)}
+
+\item{index}{For internal use only}
+
+\item{graph}{For internal use only}
+
+\item{silent}{Logical argument indicating whether information should be
+printed during estimation}
+
+\item{quick}{If TRUE the parameter estimates are calculated but all
+additional information such as standard errors are skipped}
+
+\item{method}{Optimization method}
+
+\item{param}{set parametrization (see \code{help(lava.options)})}
+
+\item{cluster}{Obsolete. Alias for 'id'.}
+
+\item{p}{Evaluate model in parameter 'p' (no optimization)}
+
+\item{...}{Additional arguments to be passed to the low level functions}
+}
+\value{
+A \code{lvmfit}-object.
+}
+\description{
+Estimate parameters. MLE, IV or user-defined estimator.
+}
+\details{
+A list of parameters controlling the estimation and optimization procedures
+is parsed via the \code{control} argument. By default Maximum Likelihood is
+used assuming multivariate normal distributed measurement errors. A list
+with one or more of the following elements is expected:
+
+\describe{
+\item{start:}{Starting value. The order of the parameters can be shown by
+calling \code{coef} (with \code{mean=TRUE}) on the \code{lvm}-object or with
+\code{plot(..., labels=TRUE)}. Note that this requires a check that it is
+actual the model being estimated, as \code{estimate} might add additional
+restriction to the model, e.g. through the \code{fix} and \code{exo.fix}
+arguments. The \code{lvm}-object of a fitted model can be extracted with the
+\code{Model}-function.}
+
+\item{starterfun:}{Starter-function with syntax
+\code{function(lvm, S, mu)}. Three builtin functions are available:
+\code{startvalues}, \code{startvalues0}, \code{startvalues1}, ...}
+
+\item{estimator:}{ String defining which estimator to use (Defaults to
+``\code{gaussian}'')}
+
+\item{meanstructure}{Logical variable indicating
+whether to fit model with meanstructure.}
+
+\item{method:}{ String pointing to
+alternative optimizer (e.g. \code{optim} to use simulated annealing).}
+
+\item{control:}{ Parameters passed to the optimizer (default
+\code{stats::nlminb}).}
+
+\item{tol:}{ Tolerance of optimization constraints on lower limit of
+variance parameters. } }
+}
+\examples{
+dd <- read.table(header=TRUE,
+text="x1 x2 x3
+ 0.0 -0.5 -2.5
+-0.5 -2.0 0.0
+ 1.0 1.5 1.0
+ 0.0 0.5 0.0
+-2.5 -1.5 -1.0")
+e <- estimate(lvm(c(x1,x2,x3)~u),dd)
+
+## Simulation example
+m <- lvm(list(y~v1+v2+v3+v4,c(v1,v2,v3,v4)~x))
+covariance(m) <- v1~v2+v3+v4
+dd <- sim(m,10000) ## Simulate 10000 observations from model
+e <- estimate(m, dd) ## Estimate parameters
+e
+
+## Using just sufficient statistics
+n <- nrow(dd)
+e0 <- estimate(m,data=list(S=cov(dd)*(n-1)/n,mu=colMeans(dd),n=n))
+rm(dd)
+
+## Multiple group analysis
+m <- lvm()
+regression(m) <- c(y1,y2,y3)~u
+regression(m) <- u~x
+d1 <- sim(m,100,p=c("u,u"=1,"u~x"=1))
+d2 <- sim(m,100,p=c("u,u"=2,"u~x"=-1))
+
+mm <- baptize(m)
+regression(mm,u~x) <- NA
+covariance(mm,~u) <- NA
+intercept(mm,~u) <- NA
+ee <- estimate(list(mm,mm),list(d1,d2))
+
+## Missing data
+d0 <- makemissing(d1,cols=1:2)
+e0 <- estimate(m,d0,missing=TRUE)
+e0
+}
+\seealso{
+estimate.default score, information
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/eventTime.Rd b/man/eventTime.Rd
new file mode 100644
index 0000000..62011dd
--- /dev/null
+++ b/man/eventTime.Rd
@@ -0,0 +1,143 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/eventTime.R
+\name{eventTime}
+\alias{eventTime}
+\alias{eventTime<-}
+\title{Add an observed event time outcome to a latent variable model.}
+\usage{
+eventTime(object, formula, eventName = "status", ...)
+}
+\arguments{
+\item{object}{Model object}
+
+\item{formula}{Formula (see details)}
+
+\item{eventName}{Event names}
+
+\item{\dots}{Additional arguments to lower levels functions}
+}
+\description{
+For example, if the model 'm' includes latent event time variables
+are called 'T1' and 'T2' and 'C' is the end of follow-up (right censored),
+then one can specify
+}
+\details{
+\code{eventTime(object=m,formula=ObsTime~min(T1=a,T2=b,C=0,"ObsEvent"))}
+
+when data are simulated from the model
+one gets 2 new columns:
+
+- "ObsTime": the smallest of T1, T2 and C
+- "ObsEvent": 'a' if T1 is smallest, 'b' if T2 is smallest and '0' if C is smallest
+
+Note that "ObsEvent" and "ObsTime" are names specified by the user.
+}
+\examples{
+
+# Right censored survival data without covariates
+m0 <- lvm()
+distribution(m0,"eventtime") <- coxWeibull.lvm(scale=1/100,shape=2)
+distribution(m0,"censtime") <- coxExponential.lvm(rate=10)
+m0 <- eventTime(m0,time~min(eventtime=1,censtime=0),"status")
+sim(m0,10)
+
+# Alternative specification of the right censored survival outcome
+## eventTime(m,"Status") <- ~min(eventtime=1,censtime=0)
+
+# Cox regression:
+# lava implements two different parametrizations of the same
+# Weibull regression model. The first specifies
+# the effects of covariates as proportional hazard ratios
+# and works as follows:
+m <- lvm()
+distribution(m,"eventtime") <- coxWeibull.lvm(scale=1/100,shape=2)
+distribution(m,"censtime") <- coxWeibull.lvm(scale=1/100,shape=2)
+m <- eventTime(m,time~min(eventtime=1,censtime=0),"status")
+distribution(m,"sex") <- binomial.lvm(p=0.4)
+distribution(m,"sbp") <- normal.lvm(mean=120,sd=20)
+regression(m,from="sex",to="eventtime") <- 0.4
+regression(m,from="sbp",to="eventtime") <- -0.01
+sim(m,6)
+# The parameters can be recovered using a Cox regression
+# routine or a Weibull regression model. E.g.,
+\dontrun{
+ set.seed(18)
+ d <- sim(m,1000)
+ library(survival)
+ coxph(Surv(time,status)~sex+sbp,data=d)
+
+ sr <- survreg(Surv(time,status)~sex+sbp,data=d)
+ library(SurvRegCensCov)
+ ConvertWeibull(sr)
+
+}
+
+# The second parametrization is an accelerated failure time
+# regression model and uses the function weibull.lvm instead
+# of coxWeibull.lvm to specify the event time distributions.
+# Here is an example:
+
+ma <- lvm()
+distribution(ma,"eventtime") <- weibull.lvm(scale=3,shape=0.7)
+distribution(ma,"censtime") <- weibull.lvm(scale=2,shape=0.7)
+ma <- eventTime(ma,time~min(eventtime=1,censtime=0),"status")
+distribution(ma,"sex") <- binomial.lvm(p=0.4)
+distribution(ma,"sbp") <- normal.lvm(mean=120,sd=20)
+regression(ma,from="sex",to="eventtime") <- 0.7
+regression(ma,from="sbp",to="eventtime") <- -0.008
+set.seed(17)
+sim(ma,6)
+# The regression coefficients of the AFT model
+# can be tranformed into log(hazard ratios):
+# coef.coxWeibull = - coef.weibull / shape.weibull
+\dontrun{
+ set.seed(17)
+ da <- sim(ma,1000)
+ library(survival)
+ fa <- coxph(Surv(time,status)~sex+sbp,data=da)
+ coef(fa)
+ c(0.7,-0.008)/0.7
+}
+
+
+# The Weibull parameters are related as follows:
+# shape.coxWeibull = 1/shape.weibull
+# scale.coxWeibull = exp(-scale.weibull/shape.weibull)
+# scale.AFT = log(scale.coxWeibull) / shape.coxWeibull
+# Thus, the following are equivalent parametrizations
+# which produce exactly the same random numbers:
+
+model.aft <- lvm()
+distribution(model.aft,"eventtime") <- weibull.lvm(scale=-log(1/100)/2,shape=0.5)
+distribution(model.aft,"censtime") <- weibull.lvm(scale=-log(1/100)/2,shape=0.5)
+set.seed(17)
+sim(model.aft,6)
+
+model.cox <- lvm()
+distribution(model.cox,"eventtime") <- coxWeibull.lvm(scale=1/100,shape=2)
+distribution(model.cox,"censtime") <- coxWeibull.lvm(scale=1/100,shape=2)
+set.seed(17)
+sim(model.cox,6)
+
+# The minimum of multiple latent times one of them still
+# being a censoring time, yield
+# right censored competing risks data
+
+mc <- lvm()
+distribution(mc,~X2) <- binomial.lvm()
+regression(mc) <- T1~f(X1,-.5)+f(X2,0.3)
+regression(mc) <- T2~f(X2,0.6)
+distribution(mc,~T1) <- coxWeibull.lvm(scale=1/100)
+distribution(mc,~T2) <- coxWeibull.lvm(scale=1/100)
+distribution(mc,~C) <- coxWeibull.lvm(scale=1/100)
+mc <- eventTime(mc,time~min(T1=1,T2=2,C=0),"event")
+sim(mc,6)
+
+
+}
+\author{
+Thomas A. Gerds, Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
+\keyword{survival}
diff --git a/man/fplot.Rd b/man/fplot.Rd
new file mode 100644
index 0000000..6fa22f8
--- /dev/null
+++ b/man/fplot.Rd
@@ -0,0 +1,37 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fplot.R
+\name{fplot}
+\alias{fplot}
+\title{fplot}
+\usage{
+fplot(x, y, z = NULL, xlab, ylab, ..., z.col = topo.colors(64),
+ data = parent.frame(), add = FALSE)
+}
+\arguments{
+\item{x}{X variable}
+
+\item{y}{Y variable}
+
+\item{z}{Z variable (optional)}
+
+\item{xlab}{x-axis label}
+
+\item{ylab}{y-axis label}
+
+\item{...}{additional arggument to lower level plot functions}
+
+\item{z.col}{Color}
+
+\item{data}{data.frame}
+
+\item{add}{If TRUE use current active device}
+}
+\description{
+Faster plot via RGL
+}
+\examples{
+if (interactive()) {
+data(iris)
+fplot(Sepal.Length ~ Petal.Length+Species, data=iris, size=2, type="s")
+}
+}
diff --git a/man/getMplus.Rd b/man/getMplus.Rd
new file mode 100644
index 0000000..a7d4837
--- /dev/null
+++ b/man/getMplus.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/zgetmplus.R
+\name{getMplus}
+\alias{getMplus}
+\title{Read Mplus output}
+\usage{
+getMplus(infile = "template.out", coef = TRUE, ...)
+}
+\arguments{
+\item{infile}{Mplus output file}
+
+\item{coef}{Coefficients only}
+
+\item{\dots}{additional arguments to lower level functions}
+}
+\description{
+Read Mplus output files
+}
+\seealso{
+getSAS
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/getSAS.Rd b/man/getSAS.Rd
new file mode 100644
index 0000000..8a1b73c
--- /dev/null
+++ b/man/getSAS.Rd
@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/zgetsas.R
+\name{getSAS}
+\alias{getSAS}
+\title{Read SAS output}
+\usage{
+getSAS(infile, entry = "Parameter Estimates", ...)
+}
+\arguments{
+\item{infile}{file (csv file generated by ODS)}
+
+\item{entry}{Name of entry to capture}
+
+\item{\dots}{additional arguments to lower level functions}
+}
+\description{
+Run SAS code like in the following:
+}
+\details{
+ODS CSVALL BODY="myest.csv";
+proc nlmixed data=aj qpoints=2 dampstep=0.5;
+...
+run;
+ODS CSVALL Close;
+
+and read results into R with:
+
+\code{getsas("myest.csv","Parameter Estimates")}
+}
+\seealso{
+getMplus
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/gof.Rd b/man/gof.Rd
new file mode 100644
index 0000000..643ec43
--- /dev/null
+++ b/man/gof.Rd
@@ -0,0 +1,104 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/gof.R
+\name{gof}
+\alias{gof}
+\alias{gof.lvmfit}
+\alias{moments}
+\alias{moments.lvm}
+\alias{information}
+\alias{information.lvmfit}
+\alias{score}
+\alias{score.lvmfit}
+\alias{logLik.lvmfit}
+\title{Extract model summaries and GOF statistics for model object}
+\usage{
+gof(object, ...)
+
+\method{gof}{lvmfit}(object, chisq=FALSE, level=0.90, rmsea.threshold=0.05,all=FALSE,...)
+
+moments(x,...)
+
+\method{moments}{lvm}(x, p, debug=FALSE, conditional=FALSE, data=NULL, latent=FALSE, ...)
+
+\method{logLik}{lvmfit}(object, p=coef(object),
+ data=model.frame(object),
+ model=object$estimator,
+ weights=Weights(object),
+ data2=object$data$data2,
+ ...)
+
+\method{score}{lvmfit}(x, data=model.frame(x), p=pars(x), model=x$estimator,
+ weights=Weights(x), data2=x$data$data2, ...)
+
+\method{information}{lvmfit}(x,p=pars(x),n=x$data$n,data=model.frame(x),
+ model=x$estimator,weights=Weights(x), data2=x$data$data2, ...)
+}
+\arguments{
+\item{object}{Model object}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+
+\item{x}{Model object}
+
+\item{p}{Parameter vector used to calculate statistics}
+
+\item{data}{Data.frame to use}
+
+\item{latent}{If TRUE predictions of latent variables are included in output}
+
+\item{data2}{Optional second data.frame (only for censored observations)}
+
+\item{weights}{Optional weight matrix}
+
+\item{n}{Number of observations}
+
+\item{conditional}{If TRUE the conditional moments given the covariates are
+calculated. Otherwise the joint moments are calculated}
+
+\item{model}{String defining estimator, e.g. "gaussian" (see
+\code{estimate})}
+
+\item{debug}{Debugging only}
+
+\item{chisq}{Boolean indicating whether to calculate chi-squared
+goodness-of-fit (always TRUE for estimator='gaussian')}
+
+\item{level}{Level of confidence limits for RMSEA}
+
+\item{rmsea.threshold}{Which probability to calculate, Pr(RMSEA<rmsea.treshold)}
+
+\item{all}{Calculate all (ad hoc) FIT indices: TLI, CFI, NFI, SRMR, ...}
+}
+\value{
+A \code{htest}-object.
+}
+\description{
+Calculates various GOF statistics for model object including global
+chi-squared test statistic and AIC. Extract model-specific mean and variance
+structure, residuals and various predicitions.
+}
+\examples{
+m <- lvm(list(y~v1+v2+v3+v4,c(v1,v2,v3,v4)~x))
+set.seed(1)
+dd <- sim(m,1000)
+e <- estimate(m, dd)
+gof(e,all=TRUE,rmsea.threshold=0.05,level=0.9)
+
+
+set.seed(1)
+m <- lvm(list(c(y1,y2,y3)~u,y1~x)); latent(m) <- ~u
+regression(m,c(y2,y3)~u) <- "b"
+d <- sim(m,1000)
+e <- estimate(m,d)
+rsq(e)
+##'
+rr <- rsq(e,TRUE)
+rr
+estimate(rr,contrast=rbind(c(1,-1,0),c(1,0,-1),c(0,1,-1)))
+
+}
+\author{
+Klaus K. Holst
+}
+\keyword{methods}
+\keyword{models}
diff --git a/man/hubble.Rd b/man/hubble.Rd
new file mode 100644
index 0000000..642c681
--- /dev/null
+++ b/man/hubble.Rd
@@ -0,0 +1,15 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{hubble}
+\alias{hubble}
+\title{Hubble data}
+\format{data.frame}
+\source{
+Freedman, W. L., et al. 2001, AstroPhysicalJournal, 553, 47.
+}
+\description{
+Velocity (v) and distance (D) measures of 36 Type Ia super-novae from the Hubble
+Space Telescope
+}
+\keyword{datasets}
diff --git a/man/hubble2.Rd b/man/hubble2.Rd
new file mode 100644
index 0000000..823cec4
--- /dev/null
+++ b/man/hubble2.Rd
@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{hubble2}
+\alias{hubble2}
+\title{Hubble data}
+\format{data.frame}
+\description{
+Hubble data
+}
+\seealso{
+hubble
+}
+\keyword{datasets}
diff --git a/man/iid.Rd b/man/iid.Rd
new file mode 100644
index 0000000..52d7073
--- /dev/null
+++ b/man/iid.Rd
@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/iid.R
+\name{iid}
+\alias{iid}
+\alias{iid.default}
+\title{Extract i.i.d. decomposition (influence function) from model object}
+\usage{
+iid(x,...)
+
+\method{iid}{default}(x,bread,id=NULL,folds=0,maxsize=(folds>0)*1e6,...)
+}
+\arguments{
+\item{x}{model object}
+
+\item{...}{additional arguments}
+
+\item{id}{(optional) id/cluster variable}
+
+\item{bread}{(optional) Inverse of derivative of mean score function}
+
+\item{folds}{(optional) Calculate aggregated iid decomposition (0:=disabled)}
+
+\item{maxsize}{(optional) Data is split in groups of size up to 'maxsize' (0:=disabled)}
+}
+\description{
+Extract i.i.d. decomposition (influence function) from model object
+}
+\examples{
+m <- lvm(y~x+z)
+distribution(m, ~y+z) <- binomial.lvm("logit")
+d <- sim(m,1e3)
+g <- glm(y~x+z,data=d,family=binomial)
+crossprod(iid(g))
+
+}
diff --git a/man/images.Rd b/man/images.Rd
new file mode 100644
index 0000000..14a7a2b
--- /dev/null
+++ b/man/images.Rd
@@ -0,0 +1,70 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/img.R
+\name{images}
+\alias{images}
+\title{Organize several image calls (for visualizing categorical data)}
+\usage{
+images(x, group, ncol = 2, byrow = TRUE, colorbar = 1,
+ colorbar.space = 0.1, label.offset = 0.02, order = TRUE,
+ colorbar.border = 0, main, rowcol = FALSE, plotfun = NULL, axis1, axis2,
+ mar, col = list(c("#EFF3FF", "#BDD7E7", "#6BAED6", "#2171B5"), c("#FEE5D9",
+ "#FCAE91", "#FB6A4A", "#CB181D"), c("#EDF8E9", "#BAE4B3", "#74C476",
+ "#238B45"), c("#FEEDDE", "#FDBE85", "#FD8D3C", "#D94701")), ...)
+}
+\arguments{
+\item{x}{data.frame or matrix}
+
+\item{group}{group variable}
+
+\item{ncol}{number of columns in layout}
+
+\item{byrow}{organize by row if TRUE}
+
+\item{colorbar}{Add color bar}
+
+\item{colorbar.space}{Space around color bar}
+
+\item{label.offset}{label offset}
+
+\item{order}{order}
+
+\item{colorbar.border}{Add border around color bar}
+
+\item{main}{Main title}
+
+\item{rowcol}{switch rows and columns}
+
+\item{plotfun}{Alternative plot function (instead of 'image')}
+
+\item{axis1}{Axis 1}
+
+\item{axis2}{Axis 2}
+
+\item{mar}{Margins}
+
+\item{col}{Colours}
+
+\item{...}{Additional arguments to lower level graphics functions}
+}
+\description{
+Visualize categorical by group variable
+}
+\examples{
+X <- matrix(rbinom(400,3,0.5),20)
+group <- rep(1:4,each=5)
+images(X,colorbar=0,zlim=c(0,3))
+images(X,group=group,zlim=c(0,3))
+\dontrun{
+images(X,group=group,col=list(RColorBrewer::brewer.pal(4,"Purples"),
+ RColorBrewer::brewer.pal(4,"Greys"),
+ RColorBrewer::brewer.pal(4,"YlGn"),
+ RColorBrewer::brewer.pal(4,"PuBuGn")),colorbar=2,zlim=c(0,3))
+}
+images(list(X,X,X,X),group=group,zlim=c(0,3))
+images(list(X,X,X,X),ncol=1,group=group,zlim=c(0,3))
+images(list(X,X),group,axis2=c(FALSE,FALSE),axis1=c(FALSE,FALSE),
+ mar=list(c(0,0,0,0),c(0,0,0,0)),yaxs="i",xaxs="i",zlim=c(0,3))
+}
+\author{
+Klaus Holst
+}
diff --git a/man/indoorenv.Rd b/man/indoorenv.Rd
new file mode 100644
index 0000000..3d2f05a
--- /dev/null
+++ b/man/indoorenv.Rd
@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{indoorenv}
+\alias{indoorenv}
+\title{Data}
+\format{data.frame}
+\source{
+Simulated
+}
+\description{
+Description
+}
+\keyword{datasets}
diff --git a/man/intercept.Rd b/man/intercept.Rd
new file mode 100644
index 0000000..e0f932e
--- /dev/null
+++ b/man/intercept.Rd
@@ -0,0 +1,82 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fix.R
+\name{intercept}
+\alias{intercept}
+\alias{intercept<-}
+\alias{intercept.lvm}
+\alias{intercept<-.lvm}
+\alias{intfix}
+\alias{intfix<-}
+\alias{intfix.lvm}
+\alias{intfix<-.lvm}
+\title{Fix mean parameters in 'lvm'-object}
+\usage{
+\method{intercept}{lvm}(object, vars, ...) <- value
+}
+\arguments{
+\item{object}{\code{lvm}-object}
+
+\item{\dots}{Additional arguments}
+
+\item{vars}{character vector of variable names}
+
+\item{value}{Vector (or list) of parameter values or labels (numeric or
+character) or a formula defining the linear constraints (see also the
+\code{regression} or \code{covariance} methods).}
+}
+\value{
+A \code{lvm}-object
+}
+\description{
+Define linear constraints on intercept parameters in a \code{lvm}-object.
+}
+\details{
+The \code{intercept} function is used to specify linear constraints on the
+intercept parameters of a latent variable model. As an example we look at
+the multivariate regression model
+
+\deqn{ E(Y_1|X) = \alpha_1 + \beta_1 X} \deqn{ E(Y_2|X) = \alpha_2 + \beta_2
+X}
+
+defined by the call
+
+\code{m <- lvm(c(y1,y2) ~ x)}
+
+To fix \eqn{\alpha_1=\alpha_2} we call
+
+\code{intercept(m) <- c(y1,y2) ~ f(mu)}
+
+Fixed parameters can be reset by fixing them to \code{NA}. For instance to
+free the parameter restriction of \eqn{Y_1} and at the same time fixing
+\eqn{\alpha_2=2}, we call
+
+\code{intercept(m, ~y1+y2) <- list(NA,2)}
+
+Calling \code{intercept} with no additional arguments will return the
+current intercept restrictions of the \code{lvm}-object.
+}
+\note{
+Variables will be added to the model if not already present.
+}
+\examples{
+
+
+## A multivariate model
+m <- lvm(c(y1,y2) ~ f(x1,beta)+x2)
+regression(m) <- y3 ~ f(x1,beta)
+intercept(m) <- y1 ~ f(mu)
+intercept(m, ~y2+y3) <- list(2,"mu")
+intercept(m) ## Examine intercepts of model (NA translates to free/unique paramete##r)
+
+
+}
+\seealso{
+\code{\link{covariance<-}}, \code{\link{regression<-}},
+\code{\link{constrain<-}}, \code{\link{parameter<-}},
+\code{\link{latent<-}}, \code{\link{cancel<-}}, \code{\link{kill<-}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/internal.Rd b/man/internal.Rd
new file mode 100644
index 0000000..5ba2f6f
--- /dev/null
+++ b/man/internal.Rd
@@ -0,0 +1,80 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\name{startvalues}
+\alias{startvalues}
+\alias{startvalues0}
+\alias{startvalues1}
+\alias{startvalues2}
+\alias{startvalues3}
+\alias{starter.multigroup}
+\alias{addattr}
+\alias{modelPar}
+\alias{modelVar}
+\alias{matrices}
+\alias{pars}
+\alias{pars.lvm}
+\alias{pars.lvmfit}
+\alias{pars.glm}
+\alias{score.glm}
+\alias{procdata.lvmfit}
+\alias{reorderdata}
+\alias{graph2lvm}
+\alias{igraph.lvm}
+\alias{subgraph}
+\alias{finalize}
+\alias{index.lvm}
+\alias{index.lvmfit}
+\alias{index}
+\alias{reindex}
+\alias{index<-}
+\alias{survival}
+\alias{survival<-}
+\alias{ordinal}
+\alias{ordinal<-}
+\alias{rmvn}
+\alias{dmvn}
+\alias{NR}
+\alias{logit}
+\alias{expit}
+\alias{tigol}
+\alias{randomslope}
+\alias{randomslope<-}
+\alias{lisrel}
+\alias{variances}
+\alias{offdiags}
+\alias{describecoef}
+\alias{parlabels}
+\alias{rsq}
+\alias{stdcoef}
+\alias{CoefMat}
+\alias{CoefMat.multigroupfit}
+\alias{deriv}
+\alias{updatelvm}
+\alias{checkmultigroup}
+\alias{profci}
+\alias{estimate.MAR}
+\alias{missingModel}
+\alias{Inverse}
+\alias{gaussian_logLik.lvm}
+\alias{addhook}
+\alias{gethook}
+\alias{multigroup}
+\alias{Weights}
+\alias{fixsome}
+\alias{parfix}
+\alias{parfix<-}
+\alias{merge}
+\alias{IV}
+\alias{parameter}
+\alias{Specials}
+\alias{procformula}
+\alias{getoutcome}
+\alias{decomp.specials}
+\title{For internal use}
+\description{
+For internal use
+}
+\author{
+Klaus K. Holst
+}
+\keyword{utilities}
diff --git a/man/ksmooth2.Rd b/man/ksmooth2.Rd
new file mode 100644
index 0000000..ad3fd53
--- /dev/null
+++ b/man/ksmooth2.Rd
@@ -0,0 +1,55 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/ksmooth.R
+\name{ksmooth2}
+\alias{ksmooth2}
+\alias{surface}
+\title{Plot/estimate surface}
+\usage{
+ksmooth2(x, data, h = NULL, xlab = NULL, ylab = NULL, zlab = "",
+ gridsize = rep(51L, 2), ...)
+}
+\arguments{
+\item{x}{formula or data}
+
+\item{data}{data.frame}
+
+\item{h}{bandwidth}
+
+\item{xlab}{X label}
+
+\item{ylab}{Y label}
+
+\item{zlab}{Z label}
+
+\item{gridsize}{grid size of kernel smoother}
+
+\item{...}{Additional arguments to graphics routine (persp3d or persp)}
+}
+\description{
+Plot/estimate surface
+}
+\examples{
+ksmooth2(rmvn(1e4,sigma=diag(2)*.5+.5),c(-3.5,3.5),h=1,
+ rgl=FALSE,theta=30)
+
+if (interactive()) {
+ ksmooth2(rmvn(1e4,sigma=diag(2)*.5+.5),c(-3.5,3.5),h=1)
+ ksmooth2(function(x,y) x^2+y^2, c(-20,20))
+ ksmooth2(function(x,y) x^2+y^2, xlim=c(-5,5), ylim=c(0,10))
+
+ f <- function(x,y) 1-sqrt(x^2+y^2)
+ surface(f,xlim=c(-1,1),alpha=0.9,aspect=c(1,1,0.75))
+ surface(f,xlim=c(-1,1),clut=heat.colors(128))
+ ##play3d(spin3d(axis=c(0,0,1), rpm=8), duration=5)
+}
+
+if (interactive()) {
+ surface(function(x) dmvn(x,sigma=diag(2)),c(-3,3),lit=FALSE,smooth=FALSE,box=FALSE,alpha=0.8)
+ surface(function(x) dmvn(x,sigma=diag(2)),c(-3,3),box=FALSE,specular="black")##'
+}
+
+if (!inherits(try(find.package("fields"),silent=TRUE),"try-error")) {
+ f <- function(x,y) 1-sqrt(x^2+y^2)
+ ksmooth2(f,c(-1,1),rgl=FALSE,image=fields::image.plot)
+}
+}
diff --git a/man/labels-set.Rd b/man/labels-set.Rd
new file mode 100644
index 0000000..1ce150e
--- /dev/null
+++ b/man/labels-set.Rd
@@ -0,0 +1,80 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/labels.R
+\name{labels<-}
+\alias{labels<-}
+\alias{labels}
+\alias{labels<-.default}
+\alias{labels.lvm}
+\alias{labels.lvmfit}
+\alias{labels.graphNEL}
+\alias{edgelabels}
+\alias{edgelabels<-}
+\alias{edgelabels<-.lvm}
+\alias{nodecolor}
+\alias{nodecolor<-}
+\alias{nodecolor<-.default}
+\title{Define labels of graph}
+\usage{
+\method{labels}{default}(object, ...) <- value
+\method{edgelabels}{lvm}(object, to, ...) <- value
+\method{nodecolor}{default}(object, var=vars(object),
+border, labcol, shape, lwd, ...) <- value
+}
+\arguments{
+\item{object}{\code{lvm}-object.}
+
+\item{\dots}{Additional arguments (\code{lwd}, \code{cex}, \code{col},
+\code{labcol}), \code{border}.}
+
+\item{value}{node label/edge label/color}
+
+\item{to}{Formula specifying outcomes and predictors defining relevant
+edges.}
+
+\item{var}{Formula or character vector specifying the nodes/variables to
+alter.}
+
+\item{border}{Colors of borders}
+
+\item{labcol}{Text label colors}
+
+\item{shape}{Shape of node}
+
+\item{lwd}{Line width of border}
+}
+\description{
+Alters labels of nodes and edges in the graph of a latent variable model
+}
+\examples{
+m <- lvm(c(y,v)~x+z)
+regression(m) <- c(v,x)~z
+labels(m) <- c(y=expression(psi), z=expression(zeta))
+nodecolor(m,~y+z+x,border=c("white","white","black"),
+ labcol="white", lwd=c(1,1,5),
+ lty=c(1,2)) <- c("orange","indianred","lightgreen")
+edgelabels(m,y~z+x, cex=c(2,1.5), col=c("orange","black"),labcol="darkblue",
+ arrowhead=c("tee","dot"),
+ lwd=c(3,1)) <- expression(phi,rho)
+edgelabels(m,c(v,x)~z, labcol="red", cex=0.8,arrowhead="none") <- 2
+if (interactive()) {
+ plot(m,addstyle=FALSE)
+}
+
+m <- lvm(y~x)
+labels(m) <- list(x="multiple\\nlines")
+if (interactive()) {
+op <- par(mfrow=c(1,2))
+plot(m,plain=TRUE)
+plot(m)
+par(op)
+
+d <- sim(m,100)
+e <- estimate(m,d)
+plot(e,type="sd")
+}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{aplot}
+\keyword{graphs}
diff --git a/man/lava-package.Rd b/man/lava-package.Rd
new file mode 100644
index 0000000..fc684f7
--- /dev/null
+++ b/man/lava-package.Rd
@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{package}
+\name{lava-package}
+\alias{lava-package}
+\alias{lava}
+\title{Estimation and simulation of latent variable models}
+\description{
+Framwork for estimating parameters and simulate data from Latent Variable
+Models.
+}
+\examples{
+
+lava()
+
+}
+\author{
+Klaus K. Holst Maintainer: <k.k.holst at biostat.ku.dk>
+}
+\keyword{package}
diff --git a/man/lava.options.Rd b/man/lava.options.Rd
new file mode 100644
index 0000000..f70d504
--- /dev/null
+++ b/man/lava.options.Rd
@@ -0,0 +1,43 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/addhook.R
+\name{lava.options}
+\alias{lava.options}
+\title{Set global options for \code{lava}}
+\usage{
+lava.options(...)
+}
+\arguments{
+\item{\dots}{Arguments}
+}
+\value{
+\code{list} of parameters
+}
+\description{
+Extract and set global parameters of \code{lava}. In particular optimization
+parameters for the \code{estimate} function.
+}
+\details{
+\itemize{
+ \item \code{param}: 'relative' (factor loading and variance of one
+endogenous variables in each measurement model are fixed to one), 'absolute'
+(mean and variance of latent variables are set to 0 and 1, respectively),
+'hybrid' (intercept of latent variables is fixed to 0, and factor loading of
+at least one endogenous variable in each measurement model is fixed to 1),
+'none' (no constraints are added)
+ \item \code{layout}: One of 'dot','fdp','circo','twopi','neato','osage'
+ \item \code{silent}: Set to \code{FALSE} to disable various output messages
+ \item ... }
+
+see \code{control} parameter of the \code{estimate} function.
+}
+\examples{
+
+\dontrun{
+lava.options(iter.max=100,silent=TRUE)
+}
+
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
diff --git a/man/lvm.Rd b/man/lvm.Rd
new file mode 100644
index 0000000..1de2067
--- /dev/null
+++ b/man/lvm.Rd
@@ -0,0 +1,47 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lvm.R
+\name{lvm}
+\alias{lvm}
+\alias{print.lvm}
+\alias{summary.lvm}
+\title{Initialize new latent variable model}
+\usage{
+lvm(x = NULL, ..., latent = NULL, silent = lava.options()$silent)
+}
+\arguments{
+\item{x}{Vector of variable names. Optional but gives control of the
+sequence of appearance of the variables. The argument can be given as a
+character vector or formula, e.g. \code{~y1+y2} is equivalent to
+\code{c("y1","y2")}. Alternatively the argument can be a formula specifying
+a linear model.}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+
+\item{latent}{(optional) Latent variables}
+
+\item{silent}{Logical variable which indicates whether messages are turned
+on/off.}
+}
+\value{
+Returns an object of class \code{lvm}.
+}
+\description{
+Function that constructs a new latent variable model object
+}
+\examples{
+
+m <- lvm() # Empty model
+m1 <- lvm(y~x) # Simple linear regression
+m2 <- lvm(~y1+y2) # Model with two independent variables (argument)
+m3 <- lvm(list(c(y1,y2,y3)~u,u~x+z)) # SEM with three items
+
+}
+\seealso{
+\code{\link{regression}}, \code{\link{covariance}},
+\code{\link{intercept}}, ...
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/makemissing.Rd b/man/makemissing.Rd
new file mode 100644
index 0000000..a42cce6
--- /dev/null
+++ b/man/makemissing.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/makemissing.R
+\name{makemissing}
+\alias{makemissing}
+\title{Create random missing data}
+\usage{
+makemissing(data, p = 0.2, cols = seq_len(ncol(data)), rowwise = FALSE,
+ nafun = function(x) x)
+}
+\arguments{
+\item{data}{data.frame}
+
+\item{p}{Fraction of missing data in each column}
+
+\item{cols}{Which columns (name or index) to alter}
+
+\item{rowwise}{Should missing occur row-wise (either none or all selected columns are missing)}
+
+\item{nafun}{(Optional) function to be applied on data.frame before return (e.g. \code{na.omit} to return complete-cases only)}
+}
+\value{
+data.frame
+}
+\description{
+Generates missing entries in data.frame/matrix
+}
+\author{
+Klaus K. Holst
+}
+\keyword{utilities}
diff --git a/man/measurement.error.Rd b/man/measurement.error.Rd
new file mode 100644
index 0000000..933fa02
--- /dev/null
+++ b/man/measurement.error.Rd
@@ -0,0 +1,58 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/measurement.error.R
+\name{measurement.error}
+\alias{measurement.error}
+\title{Two-stage (non-linear) measurement error}
+\usage{
+measurement.error(model1, formula, data = parent.frame(),
+ predictfun = function(mu, var, data, ...) mu[, 1]^2 + var[1], id1, id2, ...)
+}
+\arguments{
+\item{model1}{Stage 1 model}
+
+\item{formula}{Formula specifying observed covariates in stage 2 model}
+
+\item{data}{data.frame}
+
+\item{predictfun}{Predictions to be used in stage 2}
+
+\item{id1}{Optional id-vector of stage 1}
+
+\item{id2}{Optional id-vector of stage 2}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\description{
+Two-stage measurement error
+}
+\examples{
+m <- lvm(c(y1,y2,y3)~u,c(y3,y4,y5)~v,u~~v,c(u,v)~x)
+transform(m,u2~u) <- function(x) x^2
+transform(m,uv~u+v) <- prod
+regression(m) <- z~u2+u+v+uv+x
+set.seed(1)
+d <- sim(m,1000,p=c("u,u"=1))
+
+## Stage 1
+m1 <- lvm(c(y1[0:s],y2[0:s],y3[0:s])~1*u,c(y3[0:s],y4[0:s],y5[0:s])~1*v,u~b*x,u~~v)
+latent(m1) <- ~u+v
+e1 <- estimate(m1,d)
+
+pp <- function(mu,var,data,...) {
+ cbind(u=mu[,"u"],u2=mu[,"u"]^2+var["u","u"],v=mu[,"v"],uv=mu[,"u"]*mu[,"v"]+var["u","v"])
+}
+(e <- measurement.error(e1, z~1+x, data=d, predictfun=pp))
+
+## uu <- seq(-1,1,length.out=100)
+## pp <- estimate(e,function(p,...) p["(Intercept)"]+p["u"]*uu+p["u2"]*uu^2)$coefmat
+if (interactive()) {
+ plot(e,intercept=TRUE,vline=0)
+
+ f <- function(p) p[1]+p["u"]*u+p["u2"]*u^2
+ u <- seq(-1,1,length.out=100)
+ plot(e, f, data=data.frame(u), ylim=c(-.5,2.5))
+}
+}
+\seealso{
+stack.estimate
+}
diff --git a/man/missingdata.Rd b/man/missingdata.Rd
new file mode 100644
index 0000000..b7a5d7d
--- /dev/null
+++ b/man/missingdata.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{missingdata}
+\alias{missingdata}
+\title{Missing data example}
+\format{list of data.frames}
+\source{
+Simulated
+}
+\description{
+Simulated data generated from model
+\deqn{E(Y_i\mid X) = X, \quad cov(Y_1,Y_2\mid X)=0.5}
+}
+\details{
+The list contains four data sets
+1) Complete data
+2) MCAR
+3) MAR
+4) MNAR (missing mechanism depends on variable V correlated with Y1,Y2)
+}
+\examples{
+data(missingdata)
+e0 <- estimate(lvm(c(y1,y2)~b*x,y1~~y2),missingdata[[1]]) ## No missing
+e1 <- estimate(lvm(c(y1,y2)~b*x,y1~~y2),missingdata[[2]]) ## CC (MCAR)
+e2 <- estimate(lvm(c(y1,y2)~b*x,y1~~y2),missingdata[[2]],missing=TRUE) ## MCAR
+e3 <- estimate(lvm(c(y1,y2)~b*x,y1~~y2),missingdata[[3]]) ## CC (MAR)
+e4 <- estimate(lvm(c(y1,y2)~b*x,y1~~y2),missingdata[[3]],missing=TRUE) ## MAR
+}
+\keyword{datasets}
diff --git a/man/modelsearch.Rd b/man/modelsearch.Rd
new file mode 100644
index 0000000..5d8d112
--- /dev/null
+++ b/man/modelsearch.Rd
@@ -0,0 +1,46 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/modelsearch.R
+\name{modelsearch}
+\alias{modelsearch}
+\title{Model searching}
+\usage{
+modelsearch(x, k = 1, dir = "forward", type = "all", ...)
+}
+\arguments{
+\item{x}{\code{lvmfit}-object}
+
+\item{k}{Number of parameters to test simultaneously. For \code{equivalence}
+the number of additional associations to be added instead of \code{rel}.}
+
+\item{dir}{Direction to do model search. "forward" := add
+associations/arrows to model/graph (score tests), "backward" := remove
+associations/arrows from model/graph (wald test)}
+
+\item{type}{If equal to 'correlation' only consider score tests for covariance parameters. If equal to 'regression' go through direct effects only (default 'all' is to do both)}
+
+\item{...}{Additional arguments to be passed to the low level functions}
+}
+\value{
+Matrix of test-statistics and p-values
+}
+\description{
+Performs Wald or score tests
+}
+\examples{
+
+m <- lvm();
+regression(m) <- c(y1,y2,y3) ~ eta; latent(m) <- ~eta
+regression(m) <- eta ~ x
+m0 <- m; regression(m0) <- y2 ~ x
+dd <- sim(m0,100)[,manifest(m0)]
+e <- estimate(m,dd);
+modelsearch(e,silent=TRUE)
+modelsearch(e,silent=TRUE,type="cor")
+}
+\seealso{
+\code{\link{compare}}, \code{\link{equivalence}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{htest}
diff --git a/man/multinomial.Rd b/man/multinomial.Rd
new file mode 100644
index 0000000..0bb99ad
--- /dev/null
+++ b/man/multinomial.Rd
@@ -0,0 +1,77 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/multinomial.R
+\name{multinomial}
+\alias{multinomial}
+\alias{kappa.multinomial}
+\alias{kappa.table}
+\alias{gkgamma}
+\title{Estimate probabilities in contingency table}
+\usage{
+multinomial(x, data = parent.frame(), marginal = FALSE, transform,
+ vcov = TRUE, iid = TRUE, ...)
+}
+\arguments{
+\item{x}{Formula (or matrix or data.frame with observations, 1 or 2 columns)}
+
+\item{data}{Optional data.frame}
+
+\item{marginal}{If TRUE the marginals are estimated}
+
+\item{transform}{Optional transformation of parameters (e.g., logit)}
+
+\item{vcov}{Calculate asymptotic variance (default TRUE)}
+
+\item{iid}{Return iid decomposition (default TRUE)}
+
+\item{...}{Additional arguments to lower-level functions}
+}
+\description{
+Estimate probabilities in contingency table
+}
+\examples{
+set.seed(1)
+breaks <- c(-Inf,-1,0,Inf)
+m <- lvm(); covariance(m,pairwise=TRUE) <- ~y1+y2+y3+y4
+d <- transform(sim(m,5e2),
+ z1=cut(y1,breaks=breaks),
+ z2=cut(y2,breaks=breaks),
+ z3=cut(y3,breaks=breaks),
+ z4=cut(y4,breaks=breaks))
+
+multinomial(d[,5])
+(a1 <- multinomial(d[,5:6]))
+(K1 <- kappa(a1)) ## Cohen's kappa
+
+K2 <- kappa(d[,7:8])
+## Testing difference K1-K2:
+estimate(merge(K1,K2,id=TRUE),diff)
+
+estimate(merge(K1,K2,id=FALSE),diff) ## Wrong std.err ignoring dependence
+sqrt(vcov(K1)+vcov(K2))
+
+## Average of the two kappas:
+estimate(merge(K1,K2,id=TRUE),function(x) mean(x))
+estimate(merge(K1,K2,id=FALSE),function(x) mean(x)) ## Independence
+##'
+## Goodman-Kruskal's gamma
+m2 <- lvm(); covariance(m2) <- y1~y2
+breaks1 <- c(-Inf,-1,0,Inf)
+breaks2 <- c(-Inf,0,Inf)
+d2 <- transform(sim(m2,5e2),
+ z1=cut(y1,breaks=breaks1),
+ z2=cut(y2,breaks=breaks2))
+
+(g1 <- gkgamma(d2[,3:4]))
+## same as
+\dontrun{
+gkgamma(table(d2[,3:4]))
+gkgamma(multinomial(d2[,3:4]))
+}
+
+##partial gamma
+d2$x <- rbinom(nrow(d2),2,0.5)
+gkgamma(z1~z2|x,data=d2)
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/nldata.Rd b/man/nldata.Rd
new file mode 100644
index 0000000..ca694da
--- /dev/null
+++ b/man/nldata.Rd
@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{nldata}
+\alias{nldata}
+\title{Example data (nonlinear model)}
+\format{data.frame}
+\source{
+Simulated
+}
+\description{
+Example data (nonlinear model)
+}
+\keyword{datasets}
diff --git a/man/nsem.Rd b/man/nsem.Rd
new file mode 100644
index 0000000..a6be68a
--- /dev/null
+++ b/man/nsem.Rd
@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{nsem}
+\alias{nsem}
+\title{Example SEM data (nonlinear)}
+\format{data.frame}
+\source{
+Simulated
+}
+\description{
+Simulated data
+}
+\keyword{datasets}
diff --git a/man/op_concat.Rd b/man/op_concat.Rd
new file mode 100644
index 0000000..2f6507e
--- /dev/null
+++ b/man/op_concat.Rd
@@ -0,0 +1,37 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/operators.R
+\name{\%++\%}
+\alias{\%++\%}
+\title{Concatenation operator}
+\usage{
+x \%++\% y
+}
+\arguments{
+\item{x}{First object}
+
+\item{y}{Second object of same class}
+}
+\description{
+For matrices a block-diagonal matrix is created. For all other
+data types he operator is a wrapper of \code{paste}.
+}
+\details{
+Concatenation operator
+}
+\examples{
+## Block diagonal
+matrix(rnorm(25),5)\%++\%matrix(rnorm(25),5)
+## String concatenation
+"Hello "\%++\%" World"
+## Function composition
+f <- log \%++\% exp
+f(2)
+}
+\seealso{
+\code{blockdiag}, \code{\link{paste}}, \code{\link{cat}},
+}
+\author{
+Klaus K. Holst
+}
+\keyword{misc}
+\keyword{utilities}
diff --git a/man/op_match.Rd b/man/op_match.Rd
new file mode 100644
index 0000000..0a24daf
--- /dev/null
+++ b/man/op_match.Rd
@@ -0,0 +1,32 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/operators.R
+\name{\%ni\%}
+\alias{\%ni\%}
+\title{Matching operator (x not in y) oposed to the \code{\%in\%}-operator (x in y)}
+\usage{
+x \%ni\% y
+}
+\arguments{
+\item{x}{vector}
+
+\item{y}{vector of same type as \code{x}}
+}
+\value{
+A logical vector.
+}
+\description{
+Matching operator
+}
+\examples{
+
+1:10 \%ni\% c(1,5,10)
+
+}
+\seealso{
+\code{\link{match}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{misc}
+\keyword{utilities}
diff --git a/man/ordreg.Rd b/man/ordreg.Rd
new file mode 100644
index 0000000..85ccadf
--- /dev/null
+++ b/man/ordreg.Rd
@@ -0,0 +1,36 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/ordreg.R
+\name{ordreg}
+\alias{ordreg}
+\title{Univariate cumulative link regression models}
+\usage{
+ordreg(formula, data = parent.frame(), offset,
+ family = stats::binomial("probit"), start, fast = FALSE, ...)
+}
+\arguments{
+\item{formula}{formula}
+
+\item{data}{data.frame}
+
+\item{offset}{offset}
+
+\item{family}{family (default proportional odds)}
+
+\item{start}{optional starting values}
+
+\item{fast}{If TRUE standard errors etc. will not be calculated}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\description{
+Ordinal regression models
+}
+\examples{
+m <- lvm(y~x)
+ordinal(m,K=3) <- ~y
+d <- sim(m,100)
+e <- ordreg(y~x,d)
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/parpos.Rd b/man/parpos.Rd
new file mode 100644
index 0000000..18ce64d
--- /dev/null
+++ b/man/parpos.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/parpos.R
+\name{parpos}
+\alias{parpos}
+\title{Generic method for finding indeces of model parameters}
+\usage{
+parpos(x, ...)
+}
+\arguments{
+\item{x}{Model object}
+
+\item{\dots}{Additional arguments}
+}
+\description{
+Generic method for finding indeces of model parameters
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/partialcor.Rd b/man/partialcor.Rd
new file mode 100644
index 0000000..4e5517b
--- /dev/null
+++ b/man/partialcor.Rd
@@ -0,0 +1,38 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/partialcor.R
+\name{partialcor}
+\alias{partialcor}
+\title{Calculate partial correlations}
+\usage{
+partialcor(formula, data, level = 0.95, ...)
+}
+\arguments{
+\item{formula}{formula speciying the covariates and optionally the outcomes
+to calculate partial correlation for}
+
+\item{data}{data.frame}
+
+\item{level}{Level of confidence limits}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\value{
+A coefficient matrix
+}
+\description{
+Calculate partial correlation coefficients and confidence limits via Fishers
+z-transform
+}
+\examples{
+
+m <- lvm(c(y1,y2,y3)~x1+x2)
+covariance(m) <- c(y1,y2,y3)~y1+y2+y3
+d <- sim(m,500)
+partialcor(~x1+x2,d)
+
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/path.Rd b/man/path.Rd
new file mode 100644
index 0000000..8a6a184
--- /dev/null
+++ b/man/path.Rd
@@ -0,0 +1,82 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/path.R
+\name{path}
+\alias{path}
+\alias{effects}
+\alias{path.lvm}
+\alias{effects.lvmfit}
+\alias{totaleffects}
+\title{Extract pathways in model graph}
+\usage{
+\method{path}{lvm} (object, to = NULL, from, all=FALSE, ...)
+\method{effects}{lvmfit} (object, to, from, silent=FALSE, ...)
+}
+\arguments{
+\item{object}{Model object (\code{lvm})}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+
+\item{to}{Outcome variable (string). Alternatively a formula specifying
+response and predictor in which case the argument \code{from} is ignored.}
+
+\item{from}{Response variable (string), not necessarily directly affected by
+\code{to}.}
+
+\item{all}{If TRUE all simple paths (in undirected graph) is returned}
+
+\item{silent}{Logical variable which indicates whether messages are turned
+on/off.}
+}
+\value{
+If \code{object} is of class \code{lvmfit} a list with the following
+elements is returned \item{idx}{ A list where each element defines a
+possible pathway via a integer vector indicating the index of the visited
+nodes. } \item{V }{ A List of covariance matrices for each path. }
+\item{coef }{A list of parameters estimates for each path} \item{path }{A
+list where each element defines a possible pathway via a character vector
+naming the visited nodes in order. } \item{edges }{Description of 'comp2'}
+
+If \code{object} is of class \code{lvm} only the \code{path} element will be
+returned.
+
+The \code{effects} method returns an object of class \code{effects}.
+}
+\description{
+Extract all possible paths from one variable to another connected component
+in a latent variable model. In an estimated model the effect size is
+decomposed into direct, indirect and total effects including approximate
+standard errors.
+}
+\note{
+For a \code{lvmfit}-object the parameters estimates and their
+corresponding covariance matrix are also returned. The
+\code{effects}-function additionally calculates the total and indirect
+effects with approximate standard errors
+}
+\examples{
+
+m <- lvm(c(y1,y2,y3)~eta)
+regression(m) <- y2~x1
+latent(m) <- ~eta
+regression(m) <- eta~x1+x2
+d <- sim(m,500)
+e <- estimate(m,d)
+
+path(Model(e),y2~x1)
+parents(Model(e), ~y2)
+children(Model(e), ~x2)
+children(Model(e), ~x2+eta)
+effects(e,y2~x1)
+## All simple paths (undirected)
+path(m,y1~x1,all=TRUE)
+
+}
+\seealso{
+\code{children}, \code{parents}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{graphs}
+\keyword{methods}
+\keyword{models}
diff --git a/man/pcor.Rd b/man/pcor.Rd
new file mode 100644
index 0000000..6795b8a
--- /dev/null
+++ b/man/pcor.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/pcor.R
+\name{pcor}
+\alias{pcor}
+\title{Polychoric correlation}
+\usage{
+pcor(x, y, X, start, ...)
+}
+\arguments{
+\item{x}{Variable 1}
+
+\item{y}{Variable 2}
+
+\item{X}{Optional covariates}
+
+\item{start}{Optional starting values}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\description{
+Maximum likelhood estimates of polychoric correlations
+}
diff --git a/man/pdfconvert.Rd b/man/pdfconvert.Rd
new file mode 100644
index 0000000..102766f
--- /dev/null
+++ b/man/pdfconvert.Rd
@@ -0,0 +1,39 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/pdfconvert.R
+\name{pdfconvert}
+\alias{pdfconvert}
+\title{Convert pdf to raster format}
+\usage{
+pdfconvert(files, dpi = 300, resolution = 1024, gs, gsopt, resize,
+ format = "png", ...)
+}
+\arguments{
+\item{files}{Vector of (pdf-)filenames to process}
+
+\item{dpi}{DPI}
+
+\item{resolution}{Resolution of raster image file}
+
+\item{gs}{Optional ghostscript command}
+
+\item{gsopt}{Optional ghostscript arguments}
+
+\item{resize}{Optional resize arguments (mogrify)}
+
+\item{format}{Raster format (e.g. png, jpg, tif, ...)}
+
+\item{\dots}{Additional arguments}
+}
+\description{
+Convert PDF file to print quality png (default 300 dpi)
+}
+\details{
+Access to ghostscript program 'gs' is needed
+}
+\seealso{
+\code{dev.copy2pdf}, \code{printdev}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{iplot}
diff --git a/man/plot.lvm.Rd b/man/plot.lvm.Rd
new file mode 100644
index 0000000..cafece1
--- /dev/null
+++ b/man/plot.lvm.Rd
@@ -0,0 +1,104 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/plot.R
+\name{plot.lvm}
+\alias{plot.lvm}
+\alias{plot.lvmfit}
+\title{Plot path diagram}
+\usage{
+\method{plot}{lvm}(x, diag = FALSE, cor = TRUE, labels = FALSE,
+ intercept = FALSE, addcolor = TRUE, plain = FALSE, cex,
+ fontsize1 = 10, noplot = FALSE, graph = list(rankdir = "BT"),
+ attrs = list(graph = graph), unexpr = FALSE, addstyle = TRUE,
+ plot.engine = lava.options()$plot.engine, init = TRUE,
+ layout = lava.options()$layout, edgecolor = lava.options()$edgecolor,
+ graph.proc = lava.options()$graph.proc, ...)
+}
+\arguments{
+\item{x}{Model object}
+
+\item{diag}{Logical argument indicating whether to visualize
+variance parameters (i.e. diagonal of variance matrix)}
+
+\item{cor}{Logical argument indicating whether to visualize
+correlation parameters}
+
+\item{labels}{Logical argument indiciating whether to add labels
+to plot (Unnamed parameters will be labeled p1,p2,...)}
+
+\item{intercept}{Logical argument indiciating whether to add
+intercept labels}
+
+\item{addcolor}{Logical argument indiciating whether to add colors
+to plot (overrides \code{nodecolor} calls)}
+
+\item{plain}{if TRUE strip plot of colors and boxes}
+
+\item{cex}{Fontsize of node labels}
+
+\item{fontsize1}{Fontsize of edge labels}
+
+\item{noplot}{if TRUE then return \code{graphNEL} object only}
+
+\item{graph}{Graph attributes (Rgraphviz)}
+
+\item{attrs}{Attributes (Rgraphviz)}
+
+\item{unexpr}{if TRUE remove expressions from labels}
+
+\item{addstyle}{Logical argument indicating whether additional
+style should automatically be added to the plot (e.g. dashed
+lines to double-headed arrows)}
+
+\item{plot.engine}{default 'Rgraphviz' if available, otherwise
+visNetwork,igraph}
+
+\item{init}{Reinitialize graph (for internal use)}
+
+\item{layout}{Graph layout (see Rgraphviz or igraph manual)}
+
+\item{edgecolor}{if TRUE plot style with colored edges}
+
+\item{graph.proc}{Function that post-process the graph object
+(default: subscripts are automatically added to labels of the
+nodes)}
+
+\item{...}{Additional arguments to be passed to the low level
+functions}
+}
+\description{
+Plot the path diagram of a SEM
+}
+\examples{
+
+if (interactive()) {
+m <- lvm(c(y1,y2) ~ eta)
+regression(m) <- eta ~ z+x2
+regression(m) <- c(eta,z) ~ x1
+latent(m) <- ~eta
+labels(m) <- c(y1=expression(y[scriptscriptstyle(1)]),
+y2=expression(y[scriptscriptstyle(2)]),
+x1=expression(x[scriptscriptstyle(1)]),
+x2=expression(x[scriptscriptstyle(2)]),
+eta=expression(eta))
+edgelabels(m, eta ~ z+x1+x2, cex=2, lwd=3,
+ col=c("orange","lightblue","lightblue")) <- expression(rho,phi,psi)
+nodecolor(m, vars(m), border="white", labcol="darkblue") <- NA
+nodecolor(m, ~y1+y2+z, labcol=c("white","white","black")) <- NA
+plot(m,cex=1.5)
+
+d <- sim(m,100)
+e <- estimate(m,d)
+plot(e)
+
+m <- lvm(c(y1,y2) ~ eta)
+regression(m) <- eta ~ z+x2
+regression(m) <- c(eta,z) ~ x1
+latent(m) <- ~eta
+plot(lava:::beautify(m,edgecol=FALSE))
+}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{hplot}
+\keyword{regression}
diff --git a/man/plotConf.Rd b/man/plotConf.Rd
new file mode 100644
index 0000000..2416db1
--- /dev/null
+++ b/man/plotConf.Rd
@@ -0,0 +1,119 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/plotConf.R
+\name{plotConf}
+\alias{plotConf}
+\title{Plot regression lines}
+\usage{
+plotConf(model, var1 = NULL, var2 = NULL, data = NULL, ci.lty = 0,
+ ci = TRUE, level = 0.95, pch = 16, lty = 1, lwd = 2,
+ npoints = 100, xlim, col = NULL, colpt, alpha = 0.5, cex = 1,
+ delta = 0.07, centermark = 0.03, jitter = 0.2, cidiff = FALSE,
+ mean = TRUE, legend = ifelse(is.null(var1), FALSE, "topright"),
+ trans = function(x) { x }, partres = inherits(model, "lm"),
+ partse = FALSE, labels, vcov, predictfun, plot = TRUE, new = TRUE, ...)
+}
+\arguments{
+\item{model}{Model object (e.g. \code{lm})}
+
+\item{var1}{predictor (Continuous or factor)}
+
+\item{var2}{Factor that interacts with \code{var1}}
+
+\item{data}{data.frame to use for prediction (model.frame is used as default)}
+
+\item{ci.lty}{Line type for confidence limits}
+
+\item{ci}{Boolean indicating wether to draw pointwise 95\% confidence limits}
+
+\item{level}{Level of confidence limits (default 95\%)}
+
+\item{pch}{Point type for partial residuals}
+
+\item{lty}{Line type for estimated regression lines}
+
+\item{lwd}{Line width for regression lines}
+
+\item{npoints}{Number of points used to plot curves}
+
+\item{xlim}{Range of x axis}
+
+\item{col}{Color (for each level in \code{var2})}
+
+\item{colpt}{Color of partial residual points}
+
+\item{alpha}{Alpha level}
+
+\item{cex}{Point size}
+
+\item{delta}{For categorical \code{var1}}
+
+\item{centermark}{For categorical \code{var1}}
+
+\item{jitter}{For categorical \code{var1}}
+
+\item{cidiff}{For categorical \code{var1}}
+
+\item{mean}{For categorical \code{var1}}
+
+\item{legend}{Boolean (add legend)}
+
+\item{trans}{Transform estimates (e.g. exponential)}
+
+\item{partres}{Boolean indicating whether to plot partial residuals}
+
+\item{partse}{.}
+
+\item{labels}{Optional labels of \code{var2}}
+
+\item{vcov}{Optional variance estimates}
+
+\item{predictfun}{Optional predict-function used to calculate confidence limits and predictions}
+
+\item{plot}{If FALSE return only predictions and confidence bands}
+
+\item{new}{If FALSE add to current plot}
+
+\item{\dots}{additional arguments to lower level functions}
+}
+\value{
+list with following members:
+\item{x}{Variable on the x-axis (\code{var1})}
+\item{y}{Variable on the y-axis (partial residuals)}
+\item{predict}{Matrix with confidence limits and predicted values}
+}
+\description{
+Plot regression line (with interactions) and partial residuals.
+}
+\examples{
+n <- 100
+x0 <- rnorm(n)
+x1 <- seq(-3,3, length.out=n)
+x2 <- factor(rep(c(1,2),each=n/2), labels=c("A","B"))
+y <- 5 + 2*x0 + 0.5*x1 + -1*(x2=="B")*x1 + 0.5*(x2=="B") + rnorm(n, sd=0.25)
+dd <- data.frame(y=y, x1=x1, x2=x2)
+lm0 <- lm(y ~ x0 + x1*x2, dd)
+plotConf(lm0, var1="x1", var2="x2")
+abline(a=5,b=0.5,col="red")
+abline(a=5.5,b=-0.5,col="red")
+### points(5+0.5*x1 -1*(x2=="B")*x1 + 0.5*(x2=="B") ~ x1, cex=2)
+
+data(iris)
+l <- lm(Sepal.Length ~ Sepal.Width*Species,iris)
+plotConf(l,var2="Species")
+plotConf(l,var1="Sepal.Width",var2="Species")
+
+\dontrun{
+## lme4 model
+dd$Id <- rbinom(n, size = 3, prob = 0.3)
+lmer0 <- lme4::lmer(y ~ x0 + x1*x2 + (1|Id), dd)
+plotConf(lmer0, var1="x1", var2="x2")
+}
+}
+\seealso{
+\code{termplot}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{hplot,}
+\keyword{regression}
diff --git a/man/predict.lvm.Rd b/man/predict.lvm.Rd
new file mode 100644
index 0000000..38ae97d
--- /dev/null
+++ b/man/predict.lvm.Rd
@@ -0,0 +1,52 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/predict.R
+\name{predict.lvm}
+\alias{predict.lvm}
+\alias{predict.lvmfit}
+\title{Prediction in structural equation models}
+\usage{
+\method{predict}{lvm}(object, x = NULL, y = NULL, residual = FALSE, p,
+ data, path = FALSE, quick = is.null(x) & !(residual | path), ...)
+}
+\arguments{
+\item{object}{Model object}
+
+\item{x}{optional list of (endogenous) variables to condition on}
+
+\item{y}{optional subset of variables to predict}
+
+\item{residual}{If true the residuals are predicted}
+
+\item{p}{Parameter vector}
+
+\item{data}{Data to use in prediction}
+
+\item{path}{Path prediction}
+
+\item{quick}{If TRUE the conditional mean and variance given covariates are returned (and all other calculations skipped)}
+
+\item{\dots}{Additional arguments to lower level function}
+}
+\description{
+Prediction in structural equation models
+}
+\examples{
+m <- lvm(list(c(y1,y2,y3)~u,u~x)); latent(m) <- ~u
+d <- sim(m,100)
+e <- estimate(m,d)
+
+## Conditional mean (and variance as attribute) given covariates
+r <- predict(e)
+## Best linear unbiased predictor (BLUP)
+r <- predict(e,vars(e))
+## Conditional mean of y3 giving covariates and y1,y2
+r <- predict(e,y3~y1+y2)
+## Conditional mean gives covariates and y1
+r <- predict(e,~y1+y2)
+## Predicted residuals (conditional on all observed variables)
+r <- predict(e,vars(e),residual=TRUE)
+
+}
+\seealso{
+predictlvm
+}
diff --git a/man/predictlvm.Rd b/man/predictlvm.Rd
new file mode 100644
index 0000000..ebd511e
--- /dev/null
+++ b/man/predictlvm.Rd
@@ -0,0 +1,39 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/predict.R
+\name{predictlvm}
+\alias{predictlvm}
+\title{Predict function for latent variable models}
+\usage{
+predictlvm(object, formula, p = coef(object), data = model.frame(object),
+ ...)
+}
+\arguments{
+\item{object}{Model object}
+
+\item{formula}{Formula specifying which variables to predict and which to condition on}
+
+\item{p}{Parameter vector}
+
+\item{data}{Data.frame}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\description{
+Predictions of conditinoal mean and variance and calculation of
+jacobian with respect to parameter vector.
+}
+\examples{
+m <- lvm(c(x1,x2,x3)~u1,u1~z,
+ c(y1,y2,y3)~u2,u2~u1+z)
+latent(m) <- ~u1+u2
+d <- simulate(m,10,"u2,u2"=2,"u1,u1"=0.5,seed=123)
+e <- estimate(m,d)
+
+## Conditional mean given covariates
+predictlvm(e,c(x1,x2)~1)$mean
+## Conditional variance of u1,y1 given x1,x2
+predictlvm(e,c(u1,y1)~x1+x2)$var
+}
+\seealso{
+predict.lvm
+}
diff --git a/man/regression-set.Rd b/man/regression-set.Rd
new file mode 100644
index 0000000..b61941a
--- /dev/null
+++ b/man/regression-set.Rd
@@ -0,0 +1,135 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/regression.R
+\name{regression<-}
+\alias{regression<-}
+\alias{regression}
+\alias{regression<-.lvm}
+\alias{regression.lvm}
+\alias{regfix}
+\alias{regfix<-}
+\alias{regfix.lvm}
+\alias{regfix<-.lvm}
+\title{Add regression association to latent variable model}
+\usage{
+\method{regression}{lvm}(object = lvm(), to, from, fn = NA,
+silent = lava.options()$silent, additive=TRUE, y, x, value, ...)
+\method{regression}{lvm}(object, to=NULL, quick=FALSE, ...) <- value
+}
+\arguments{
+\item{object}{\code{lvm}-object.}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+
+\item{value}{A formula specifying the linear constraints or if
+\code{to=NULL} a \code{list} of parameter values.}
+
+\item{to}{Character vector of outcome(s) or formula object.}
+
+\item{from}{Character vector of predictor(s).}
+
+\item{fn}{Real function defining the functional form of predictors (for
+simulation only).}
+
+\item{silent}{Logical variable which indicates whether messages are turned
+on/off.}
+
+\item{additive}{If FALSE and predictor is categorical a non-additive effect is assumed}
+
+\item{y}{Alias for 'to'}
+
+\item{x}{Alias for 'from'}
+
+\item{quick}{Faster implementation without parameter constraints}
+}
+\value{
+A \code{lvm}-object
+}
+\description{
+Define regression association between variables in a \code{lvm}-object and
+define linear constraints between model equations.
+}
+\details{
+The \code{regression} function is used to specify linear associations
+between variables of a latent variable model, and offers formula syntax
+resembling the model specification of e.g. \code{lm}.
+
+For instance, to add the following linear regression model, to the
+\code{lvm}-object, \code{m}:
+\deqn{ E(Y|X_1,X_2) = \beta_1 X_1 + \beta_2 X_2}
+We can write
+
+\code{regression(m) <- y ~ x1 + x2}
+
+Multivariate models can be specified by successive calls with
+\code{regression}, but multivariate formulas are also supported, e.g.
+
+\code{regression(m) <- c(y1,y2) ~ x1 + x2}
+
+defines
+\deqn{ E(Y_i|X_1,X_2) = \beta_{1i} X_1 + \beta_{2i} X_2 }
+
+The special function, \code{f}, can be used in the model specification to
+specify linear constraints. E.g. to fix \eqn{\beta_1=\beta_2}
+, we could write
+
+\code{regression(m) <- y ~ f(x1,beta) + f(x2,beta)}
+
+The second argument of \code{f} can also be a number (e.g. defining an
+offset) or be set to \code{NA} in order to clear any previously defined
+linear constraints.
+
+Alternatively, a more straight forward notation can be used:
+
+\code{regression(m) <- y ~ beta*x1 + beta*x2}
+
+All the parameter values of the linear constraints can be given as the right
+handside expression of the assigment function \code{regression<-} (or
+\code{regfix<-}) if the first (and possibly second) argument is defined as
+well. E.g:
+
+\code{regression(m,y1~x1+x2) <- list("a1","b1")}
+
+defines \eqn{E(Y_1|X_1,X_2) = a1 X_1 + b1 X_2}. The rhs argument can be a
+mixture of character and numeric values (and NA's to remove constraints).
+
+The function \code{regression} (called without additional arguments) can be
+used to inspect the linear constraints of a \code{lvm}-object.
+
+For backward compatibility the "$"-symbol can be used to fix parameters at
+a given value. E.g. to add a linear relationship between \code{y} and
+\code{x} with slope 2 to the model \code{m}, we can write
+\code{regression(m,"y") <- "x$2"}. Similarily we can use the "@"-symbol to
+name parameters. E.g. in a multiple regression we can force the parameters
+to be equal: \code{regression(m,"y") <- c("x1 at b","x2 at b")}. Fixed parameters
+can be reset by fixing (with \$) them to \code{NA}.
+}
+\note{
+Variables will be added to the model if not already present.
+}
+\examples{
+
+m <- lvm() ## Initialize empty lvm-object
+### E(y1|z,v) = beta1*z + beta2*v
+regression(m) <- y1 ~ z + v
+### E(y2|x,z,v) = beta*x + beta*z + 2*v + beta3*u
+regression(m) <- y2 ~ f(x,beta) + f(z,beta) + f(v,2) + u
+### Clear restriction on association between y and
+### fix slope coefficient of u to beta
+regression(m, y2 ~ v+u) <- list(NA,"beta")
+
+regression(m) ## Examine current linear parameter constraints
+
+## ## A multivariate model, E(yi|x1,x2) = beta[1i]*x1 + beta[2i]*x2:
+m2 <- lvm(c(y1,y2) ~ x1+x2)
+
+}
+\seealso{
+\code{\link{intercept<-}}, \code{\link{covariance<-}},
+\code{\link{constrain<-}}, \code{\link{parameter<-}},
+\code{\link{latent<-}}, \code{\link{cancel<-}}, \code{\link{kill<-}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/revdiag.Rd b/man/revdiag.Rd
new file mode 100644
index 0000000..a5657ca
--- /dev/null
+++ b/man/revdiag.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/revdiag.R
+\name{revdiag}
+\alias{revdiag}
+\alias{revdiag<-}
+\alias{offdiag}
+\alias{offdiag<-}
+\title{Create/extract 'reverse'-diagonal matrix or off-diagonal elements}
+\usage{
+revdiag(x,...)
+offdiag(x,type=0,...)
+
+revdiag(x,...) <- value
+offdiag(x,type=0,...) <- value
+}
+\arguments{
+\item{x}{vector}
+
+\item{\dots}{additional arguments to lower level functions}
+
+\item{value}{For the assignment function the values to put in the diagonal}
+
+\item{type}{0: upper and lower triangular, 1: upper triangular, 2: lower triangular, 3: upper triangular + diagonal, 4: lower triangular + diagonal}
+}
+\description{
+Create/extract 'reverse'-diagonal matrix or off-diagonal elements
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/rmvar.Rd b/man/rmvar.Rd
new file mode 100644
index 0000000..c025c52
--- /dev/null
+++ b/man/rmvar.Rd
@@ -0,0 +1,42 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/kill.R
+\name{rmvar}
+\alias{rmvar}
+\alias{rmvar<-}
+\alias{kill}
+\alias{kill<-}
+\title{Remove variables from (model) object.}
+\usage{
+kill(x, ...) <- value
+}
+\arguments{
+\item{x}{Model object}
+
+\item{\dots}{additional arguments to lower level functions}
+
+\item{value}{Vector of variables or formula specifying which nodes to
+remove}
+}
+\description{
+Generic method for removing elements of object
+}
+\examples{
+
+m <- lvm()
+addvar(m) <- ~y1+y2+x
+covariance(m) <- y1~y2
+regression(m) <- c(y1,y2) ~ x
+### Cancel the covariance between the residuals of y1 and y2
+cancel(m) <- y1~y2
+### Remove y2 from the model
+rmvar(m) <- ~y2
+
+}
+\seealso{
+\code{cancel}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/scheffe.Rd b/man/scheffe.Rd
new file mode 100644
index 0000000..e72b428
--- /dev/null
+++ b/man/scheffe.Rd
@@ -0,0 +1,33 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/scheffe.R
+\name{scheffe}
+\alias{scheffe}
+\title{Calculate simultaneous confidence limits by Scheffe's method}
+\usage{
+scheffe(model, newdata = model.frame(model), conf.level = 0.95)
+}
+\arguments{
+\item{model}{Linear model}
+
+\item{newdata}{new data frame}
+
+\item{conf.level}{confidence level (0.95)}
+}
+\description{
+Function to compute the Scheffe corrected confidence
+interval for the regression line
+}
+\examples{
+x <- rnorm(100)
+d <- data.frame(y=rnorm(length(x),x),x=x)
+l <- lm(y~x,d)
+plot(y~x,d)
+abline(l)
+d0 <- data.frame(x=seq(-5,5,length.out=100))
+d1 <- cbind(d0,predict(l,newdata=d0,interval="confidence"))
+d2 <- cbind(d0,scheffe(l,d0))
+lines(lwr~x,d1,lty=2,col="red")
+lines(upr~x,d1,lty=2,col="red")
+lines(lwr~x,d2,lty=2,col="blue")
+lines(upr~x,d2,lty=2,col="blue")
+}
diff --git a/man/semdata.Rd b/man/semdata.Rd
new file mode 100644
index 0000000..05e166a
--- /dev/null
+++ b/man/semdata.Rd
@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{semdata}
+\alias{semdata}
+\title{Example SEM data}
+\format{data.frame}
+\source{
+Simulated
+}
+\description{
+Simulated data
+}
+\keyword{datasets}
diff --git a/man/serotonin.Rd b/man/serotonin.Rd
new file mode 100644
index 0000000..e05c56b
--- /dev/null
+++ b/man/serotonin.Rd
@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{serotonin}
+\alias{serotonin}
+\title{Serotonin data}
+\format{data.frame}
+\source{
+Simulated
+}
+\description{
+This simulated data mimics a PET imaging study where the 5-HT2A
+receptor and serotonin transporter (SERT) binding potential has
+been quantified into 8 different regions. The 5-HT2A
+cortical regions are considered high-binding regions
+measurements. These measurements can be regarded as proxy measures of
+the extra-cellular levels of serotonin in the brain
+\tabular{rll}{
+ day \tab numeric \tab Scan day of the year \cr
+ age \tab numeric \tab Age at baseline scan \cr
+ mem \tab numeric \tab Memory performance score \cr
+ depr \tab numeric \tab Depression (mild) status 500 days after baseline \cr
+ gene1 \tab numeric \tab Gene marker 1 (HTR2A) \cr
+ gene2 \tab numeric \tab Gene marker 2 (HTTTLPR) \cr
+ cau \tab numeric \tab SERT binding, Caudate Nucleus \cr
+ th \tab numeric \tab SERT binding, Thalamus \cr
+ put \tab numeric \tab SERT binding, Putamen \cr
+ mid \tab numeric \tab SERT binding, Midbrain \cr
+ aci \tab numeric \tab 5-HT2A binding, Anterior cingulate gyrus \cr
+ pci \tab numeric \tab 5-HT2A binding, Posterior cingulate gyrus \cr
+ sfc \tab numeric \tab 5-HT2A binding, Superior frontal cortex \cr
+ par \tab numeric \tab 5-HT2A binding, Parietal cortex \cr
+}
+}
+\keyword{datasets}
diff --git a/man/serotonin2.Rd b/man/serotonin2.Rd
new file mode 100644
index 0000000..b36d939
--- /dev/null
+++ b/man/serotonin2.Rd
@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{serotonin2}
+\alias{serotonin2}
+\title{Data}
+\format{data.frame}
+\source{
+Simulated
+}
+\description{
+Description
+}
+\seealso{
+serotonin
+}
+\keyword{datasets}
diff --git a/man/sim.Rd b/man/sim.Rd
new file mode 100644
index 0000000..d3e005d
--- /dev/null
+++ b/man/sim.Rd
@@ -0,0 +1,289 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/sim.lvm.R
+\name{sim}
+\alias{sim}
+\alias{sim.lvmfit}
+\alias{sim.lvm}
+\alias{simulate.lvmfit}
+\alias{simulate.lvm}
+\alias{transform<-}
+\alias{transform<-.lvm}
+\alias{transform.lvm}
+\alias{functional}
+\alias{functional<-}
+\alias{functional.lvm}
+\alias{functional<-.lvm}
+\alias{distribution}
+\alias{distribution<-}
+\alias{distribution.lvm}
+\alias{distribution<-.lvm}
+\alias{heavytail}
+\alias{heavytail<-}
+\alias{weibull.lvm}
+\alias{binomial.lvm}
+\alias{poisson.lvm}
+\alias{uniform.lvm}
+\alias{beta.lvm}
+\alias{normal.lvm}
+\alias{lognormal.lvm}
+\alias{gaussian.lvm}
+\alias{GM2.lvm}
+\alias{GM3.lvm}
+\alias{probit.lvm}
+\alias{logit.lvm}
+\alias{pareto.lvm}
+\alias{student.lvm}
+\alias{chisq.lvm}
+\alias{coxGompertz.lvm}
+\alias{coxWeibull.lvm}
+\alias{coxExponential.lvm}
+\alias{aalenExponential.lvm}
+\alias{Gamma.lvm}
+\alias{gamma.lvm}
+\alias{loggamma.lvm}
+\alias{categorical}
+\alias{categorical<-}
+\alias{threshold.lvm}
+\alias{ones.lvm}
+\alias{sequence.lvm}
+\title{Simulate model}
+\usage{
+\method{sim}{lvm}(x, n = NULL, p = NULL, normal = FALSE, cond = FALSE,
+sigma = 1, rho = 0.5, X = NULL, unlink=FALSE, latent=TRUE,
+use.labels = TRUE, seed=NULL, ...)
+}
+\arguments{
+\item{x}{Model object}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+
+\item{n}{Number of simulated values/individuals}
+
+\item{p}{Parameter value (optional)}
+
+\item{normal}{Logical indicating whether to simulate data from a
+multivariate normal distribution conditional on exogenous variables hence
+ignoring functional/distribution definition}
+
+\item{cond}{for internal use}
+
+\item{sigma}{Default residual variance (1)}
+
+\item{rho}{Default covariance parameter (0.5)}
+
+\item{X}{Optional matrix of covariates}
+
+\item{unlink}{Return Inverse link transformed data}
+
+\item{latent}{Include latent variables (default TRUE)}
+
+\item{use.labels}{convert categorical variables to factors before applying transformation}
+
+\item{seed}{Random seed}
+}
+\description{
+Simulate data from a general SEM model including non-linear effects and
+general link and distribution of variables.
+}
+\examples{
+##################################################
+## Logistic regression
+##################################################
+m <- lvm(y~x+z)
+regression(m) <- x~z
+distribution(m,~y+z) <- binomial.lvm("logit")
+d <- sim(m,1e3)
+head(d)
+e <- estimate(m,d,estimator="glm")
+e
+## Simulate a few observation from estimated model
+sim(e,n=5)
+##################################################
+## Poisson
+##################################################
+distribution(m,~y) <- poisson.lvm()
+d <- sim(m,1e4,p=c(y=-1,"y~x"=2,z=1))
+head(d)
+estimate(m,d,estimator="glm")
+mean(d$z); lava:::expit(1)
+summary(lm(y~x,sim(lvm(y[1:2]~4*x),1e3)))
+##################################################
+### Gamma distribution
+##################################################
+m <- lvm(y~x)
+distribution(m,~y+x) <- list(Gamma.lvm(shape=2),binomial.lvm())
+intercept(m,~y) <- 0.5
+d <- sim(m,1e4)
+summary(g <- glm(y~x,family=Gamma(),data=d))
+\dontrun{MASS::gamma.shape(g)}
+args(lava::Gamma.lvm)
+distribution(m,~y) <- Gamma.lvm(shape=2,log=TRUE)
+sim(m,10,p=c(y=0.5))[,"y"]
+##################################################
+### Beta
+##################################################
+m <- lvm()
+distribution(m,~y) <- beta.lvm(alpha=2,beta=1)
+var(sim(m,100,"y,y"=2))
+distribution(m,~y) <- beta.lvm(alpha=2,beta=1,scale=FALSE)
+var(sim(m,100))
+##################################################
+### Transform
+##################################################
+m <- lvm()
+transform(m,xz~x+z) <- function(x) x[1]*(x[2]>0)
+regression(m) <- y~x+z+xz
+d <- sim(m,1e3)
+summary(lm(y~x+z + x*I(z>0),d))
+##################################################
+### Non-random variables
+##################################################
+m <- lvm()
+distribution(m,~x+z+v+w) <- list(sequence.lvm(0,5),## Seq. 0 to 5 by 1/n
+ ones.lvm(), ## Vector of ones
+ ones.lvm(0.5), ## 0.8n 0, 0.2n 1
+ ones.lvm(interval=list(c(0.3,0.5),c(0.8,1))))
+sim(m,10)
+##################################################
+### Cox model
+### piecewise constant hazard
+################################################
+m <- lvm(t~x)
+rates <- c(1,0.5); cuts <- c(0,5)
+## Constant rate: 1 in [0,5), 0.5 in [5,Inf)
+distribution(m,~t) <- coxExponential.lvm(rate=rates,timecut=cuts)
+\dontrun{
+ d <- sim(m,2e4,p=c("t~x"=0.1)); d$status <- TRUE
+ plot(timereg::aalen(survival::Surv(t,status)~x,data=d,
+ resample.iid=0,robust=0),spec=1)
+ L <- approxfun(c(cuts,max(d$t)),f=1,
+ cumsum(c(0,rates*diff(c(cuts,max(d$t))))),
+ method="linear")
+ curve(L,0,100,add=TRUE,col="blue")
+}
+##################################################
+### Cox model
+### piecewise constant hazard, gamma frailty
+##################################################
+m <- lvm(y~x+z)
+rates <- c(0.3,0.5); cuts <- c(0,5)
+distribution(m,~y+z) <- list(coxExponential.lvm(rate=rates,timecut=cuts),
+ loggamma.lvm(rate=1,shape=1))
+\dontrun{
+ d <- sim(m,2e4,p=c("y~x"=0,"y~z"=0)); d$status <- TRUE
+ plot(timereg::aalen(survival::Surv(y,status)~x,data=d,
+ resample.iid=0,robust=0),spec=1)
+ L <- approxfun(c(cuts,max(d$y)),f=1,
+ cumsum(c(0,rates*diff(c(cuts,max(d$y))))),
+ method="linear")
+ curve(L,0,100,add=TRUE,col="blue")
+}
+## Equivalent via transform (here with Aalens additive hazard model)
+m <- lvm(y~x)
+distribution(m,~y) <- aalenExponential.lvm(rate=rates,timecut=cuts)
+distribution(m,~z) <- Gamma.lvm(rate=1,shape=1)
+transform(m,t~y+z) <- prod
+sim(m,10)
+## Shared frailty
+m <- lvm(c(t1,t2)~x+z)
+rates <- c(1,0.5); cuts <- c(0,5)
+distribution(m,~y) <- aalenExponential.lvm(rate=rates,timecut=cuts)
+distribution(m,~z) <- loggamma.lvm(rate=1,shape=1)
+\dontrun{
+mets::fast.reshape(sim(m,100),varying="t")
+}
+##################################################
+### General multivariate distributions
+##################################################
+\dontrun{
+m <- lvm()
+distribution(m,~y1+y2,oratio=4) <- VGAM::rbiplackcop
+ksmooth2(sim(m,1e4),rgl=FALSE,theta=-20,phi=25)
+m <- lvm()
+distribution(m,~z1+z2,"or1") <- VGAM::rbiplackcop
+distribution(m,~y1+y2,"or2") <- VGAM::rbiplackcop
+sim(m,10,p=c(or1=0.1,or2=4))
+}
+m <- lvm()
+distribution(m,~y1+y2+y3,TRUE) <- function(n,...) rmvn(n,sigma=diag(3)+1)
+var(sim(m,100))
+## Syntax also useful for univariate generators, e.g.
+m <- lvm(y~x+z)
+distribution(m,~y,TRUE) <- function(n) rnorm(n,mean=1000)
+sim(m,5)
+distribution(m,~y,"m1",0) <- rnorm
+sim(m,5)
+sim(m,5,p=c(m1=100))
+##################################################
+### Regression design in other parameters
+##################################################
+## Variance heterogeneity
+m <- lvm(y~x)
+distribution(m,~y) <- function(n,mean,x) rnorm(n,mean,exp(x)^.5)
+if (interactive()) plot(y~x,sim(m,1e3))
+## Alternaively, calculate the standard error directly
+addvar(m) <- ~sd ## If 'sd' should be part of the resulting data.frame
+constrain(m,sd~x) <- function(x) exp(x)^.5
+distribution(m,~y) <- function(n,mean,sd) rnorm(n,mean,sd)
+if (interactive()) plot(y~x,sim(m,1e3))
+## Regression on variance parameter
+m <- lvm()
+regression(m) <- y~x
+regression(m) <- v~x
+##distribution(m,~v) <- 0 # No stochastic term
+## Alternative:
+## regression(m) <- v[NA:0]~x
+distribution(m,~y) <- function(n,mean,v) rnorm(n,mean,exp(v)^.5)
+if (interactive()) plot(y~x,sim(m,1e3))
+## Regression on shape parameter in Weibull model
+m <- lvm()
+regression(m) <- y ~ z+v
+regression(m) <- s ~ exp(0.6*x-0.5*z)
+distribution(m,~x+z) <- binomial.lvm()
+distribution(m,~cens) <- coxWeibull.lvm(scale=1)
+distribution(m,~y) <- coxWeibull.lvm(scale=0.1,shape=~s)
+eventTime(m) <- time ~ min(y=1,cens=0)
+if (interactive()) {
+ d <- sim(m,1e3)
+ require(survival)
+ (cc <- coxph(Surv(time,status)~v+strata(x,z),data=d))
+ plot(survfit(cc) ,col=1:4,mark.time=FALSE)
+}
+##################################################
+### Categorical predictor
+##################################################
+m <- lvm()
+## categorical(m,K=3) <- "v"
+categorical(m,labels=c("A","B","C")) <- "v"
+regression(m,additive=FALSE) <- y~v
+\dontrun{
+plot(y~v,sim(m,1000,p=c("y~v:2"=3)))
+}
+m <- lvm()
+categorical(m,labels=c("A","B","C"),p=c(0.5,0.3)) <- "v"
+regression(m,additive=FALSE,beta=c(0,2,-1)) <- y~v
+## equivalent to:
+## regression(m,y~v,additive=FALSE) <- c(0,2,-1)
+regression(m,additive=FALSE,beta=c(0,4,-1)) <- z~v
+table(sim(m,1e4)$v)
+glm(y~v, data=sim(m,1e4))
+glm(y~v, data=sim(m,1e4,p=c("y~v:1"=3)))
+
+transform(m,v2~v) <- function(x) x=='A'
+sim(m,10)
+
+##################################################
+### Pre-calculate object
+##################################################
+m <- lvm(y~x)
+m2 <- sim(m,'y~x'=2)
+sim(m,10,'y~x'=2)
+sim(m2,10) ## Faster
+
+}
+\author{
+Klaus K. Holst
+}
+\keyword{datagen}
+\keyword{models}
+\keyword{regression}
diff --git a/man/sim.default.Rd b/man/sim.default.Rd
new file mode 100644
index 0000000..996acad
--- /dev/null
+++ b/man/sim.default.Rd
@@ -0,0 +1,84 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/sim.default.R
+\name{sim.default}
+\alias{sim.default}
+\alias{summary.sim}
+\title{Wrapper function for mclapply}
+\usage{
+\method{sim}{default}(x = NULL, R = 100, f = NULL, colnames = NULL,
+ messages = lava.options()$messages, mc.cores, blocksize = 2L * mc.cores,
+ cl, type = 1L, seed = NULL, args = list(), iter = FALSE, ...)
+}
+\arguments{
+\item{x}{function or 'sim' object}
+
+\item{R}{Number of replications or data.frame with parameters}
+
+\item{f}{Optional function (i.e., if x is a matrix)}
+
+\item{colnames}{Optional column names}
+
+\item{messages}{Messages}
+
+\item{mc.cores}{Number of cores to use}
+
+\item{blocksize}{Split computations in blocks}
+
+\item{cl}{(optional) cluster to use for parallelization}
+
+\item{type}{type=0 is an alias for messages=1,mc.cores=1,blocksize=R}
+
+\item{seed}{(optional) Seed (needed with cl=TRUE)}
+
+\item{args}{(optional) list of named arguments passed to (mc)mapply}
+
+\item{iter}{If TRUE the iteration number is passed as first argument to (mc)mapply}
+
+\item{...}{Additional arguments to (mc)mapply}
+}
+\description{
+Wrapper function for mclapply
+}
+\examples{
+m <- lvm(y~x+e)
+distribution(m,~y) <- 0
+distribution(m,~x) <- uniform.lvm(a=-1.1,b=1.1)
+transform(m,e~x) <- function(x) (1*x^4)*rnorm(length(x),sd=1)
+
+onerun <- function(iter=NULL,...,n=2e3,b0=1,idx=2) {
+ d <- sim(m,n,p=c("y~x"=b0))
+ l <- lm(y~x,d)
+ res <- c(coef(summary(l))[idx,1:2],
+ confint(l)[idx,],
+ estimate(l,only.coef=TRUE)[idx,2:4])
+ names(res) <- c("Estimate","Model.se","Model.lo","Model.hi",
+ "Sandwich.se","Sandwich.lo","Sandwich.hi")
+ res
+}
+val <- sim(onerun,R=10,b0=1,messages=0,mc.cores=1)
+val
+
+val <- sim(val,R=40,b0=1,mc.cores=1) ## append results
+summary(val,estimate=c(1,1),confint=c(3,4,6,7),true=c(1,1))
+
+summary(val,estimate=c(1,1),se=c(2,5),names=c("Model","Sandwich"))
+summary(val,estimate=c(1,1),se=c(2,5),true=c(1,1),names=c("Model","Sandwich"),confint=TRUE)
+
+if (interactive()) {
+ plot(val,estimate=1,c(2,5),true=1,names=c("Model","Sandwich"),polygon=FALSE)
+ plot(val,estimate=c(1,1),se=c(2,5),main=NULL,
+ true=c(1,1),names=c("Model","Sandwich"),
+ line.lwd=1,density.col=c("gray20","gray60"),
+ rug=FALSE)
+ plot(val,estimate=c(1,1),se=c(2,5),true=c(1,1),
+ names=c("Model","Sandwich"))
+}
+
+f <- function(a=1,b=1) {
+ rep(a*b,5)
+}
+R <- Expand(a=1:3,b=1:3)
+sim(f,R,type=0)
+sim(function(a,b) f(a,b), 3, args=c(a=5,b=5),type=0)
+sim(function(iter=1,a=5,b=5) iter*f(a,b), type=0, iter=TRUE, R=5)
+}
diff --git a/man/spaghetti.Rd b/man/spaghetti.Rd
new file mode 100644
index 0000000..c170729
--- /dev/null
+++ b/man/spaghetti.Rd
@@ -0,0 +1,94 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/spaghetti.R
+\name{spaghetti}
+\alias{spaghetti}
+\title{Spaghetti plot}
+\usage{
+spaghetti(formula, data, id = "id", group = NULL, type = "o", lty = 1,
+ pch = NA, col = 1:10, alpha = 0.3, lwd = 1, level = 0.95,
+ trend.formula = formula, tau = NULL, trend.lty = 1, trend.join = TRUE,
+ trend.delta = 0.2, trend = !is.null(tau), trend.col = col,
+ trend.alpha = 0.2, trend.lwd = 3, trend.jitter = 0, legend = NULL,
+ by = NULL, xlab = "Time", ylab = "", add = FALSE, ...)
+}
+\arguments{
+\item{formula}{Formula (response ~ time)}
+
+\item{data}{data.frame}
+
+\item{id}{Id variable}
+
+\item{group}{group variable}
+
+\item{type}{Type (line 'l', stair 's', ...)}
+
+\item{lty}{Line type}
+
+\item{pch}{Colour}
+
+\item{col}{Colour}
+
+\item{alpha}{transparency (0-1)}
+
+\item{lwd}{Line width}
+
+\item{level}{Confidence level}
+
+\item{trend.formula}{Formula for trendline}
+
+\item{tau}{Quantile to estimate (trend)}
+
+\item{trend.lty}{Trend line type}
+
+\item{trend.join}{Trend polygon}
+
+\item{trend.delta}{Length of limit bars}
+
+\item{trend}{Add trend line}
+
+\item{trend.col}{Colour of trend line}
+
+\item{trend.alpha}{Transparency}
+
+\item{trend.lwd}{Trend line width}
+
+\item{trend.jitter}{Jitter amount}
+
+\item{legend}{Legend}
+
+\item{by}{make separate plot for each level in 'by' (formula, name of column, or vector)}
+
+\item{xlab}{Label of X-axis}
+
+\item{ylab}{Label of Y-axis}
+
+\item{add}{Add to existing device}
+
+\item{...}{Additional arguments to lower level arguments}
+}
+\description{
+Spaghetti plot for longitudinal data
+}
+\examples{
+if (interactive() & requireNamespace("mets")) {
+K <- 5
+y <- "y"\%++\%seq(K)
+m <- lvm()
+regression(m,y=y,x=~u) <- 1
+regression(m,y=y,x=~s) <- seq(K)-1
+regression(m,y=y,x=~x) <- "b"
+N <- 50
+d <- sim(m,N); d$z <- rbinom(N,1,0.5)
+dd <- mets::fast.reshape(d); dd$num <- dd$num+3
+spaghetti(y~num,dd,id="id",lty=1,col=Col(1,.4),
+ trend.formula=~factor(num),trend=TRUE,trend.col="darkblue")
+dd$num <- dd$num+rnorm(nrow(dd),sd=0.5) ## Unbalance
+spaghetti(y~num,dd,id="id",lty=1,col=Col(1,.4),
+ trend=TRUE,trend.col="darkblue")
+spaghetti(y~num,dd,id="id",lty=1,col=Col(1,.4),
+ trend.formula=~num+I(num^2),trend=TRUE,trend.col="darkblue")
+}
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/stack.estimate.Rd b/man/stack.estimate.Rd
new file mode 100644
index 0000000..f2c9e47
--- /dev/null
+++ b/man/stack.estimate.Rd
@@ -0,0 +1,33 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/stack.R
+\name{stack.estimate}
+\alias{stack.estimate}
+\title{Stack estimating equations}
+\usage{
+\method{stack}{estimate}(x, model2, D1u, inv.D2u, weights, dweights, U, k = 1,
+ keep1 = FALSE, ...)
+}
+\arguments{
+\item{x}{Model 1}
+
+\item{model2}{Model 2}
+
+\item{D1u}{Derivative of score of model 2 w.r.t. parameter vector of model 1}
+
+\item{inv.D2u}{Inverse of deri}
+
+\item{weights}{weights (vector or function)}
+
+\item{dweights}{derivative of weight wrt parameters of model 1}
+
+\item{U}{Optional score function (model 2) as function of all parameters}
+
+\item{k}{Debug argument}
+
+\item{keep1}{If TRUE only parameters of model 2 i s returned}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\description{
+Stack estimating equations
+}
diff --git a/man/subset.lvm.Rd b/man/subset.lvm.Rd
new file mode 100644
index 0000000..db78f9b
--- /dev/null
+++ b/man/subset.lvm.Rd
@@ -0,0 +1,34 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/subset.R
+\name{subset.lvm}
+\alias{subset.lvm}
+\alias{measurement}
+\title{Extract subset of latent variable model}
+\usage{
+\method{subset}{lvm}(x, vars, ...)
+}
+\arguments{
+\item{x}{\code{lvm}-object.}
+
+\item{vars}{Character vector or formula specifying variables to include in
+subset.}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+}
+\value{
+A \code{lvm}-object.
+}
+\description{
+Extract measurement models or user-specified subset of model
+}
+\examples{
+
+m <- lvm(c(y1,y2)~x1+x2)
+subset(m,~y1+x1)
+
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/timedep.Rd b/man/timedep.Rd
new file mode 100644
index 0000000..1e0a6ad
--- /dev/null
+++ b/man/timedep.Rd
@@ -0,0 +1,77 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/timedep.R
+\name{timedep}
+\alias{timedep}
+\alias{timedep<-}
+\title{Time-dependent parameters}
+\usage{
+timedep(object, formula, rate, timecut, type = "coxExponential.lvm", ...)
+}
+\arguments{
+\item{object}{Model}
+
+\item{formula}{Formula with rhs specifying time-varying covariates}
+
+\item{rate}{Optional rate parameters. If given as a vector this
+parameter is interpreted as the raw (baseline-)rates within each
+time interval defined by \code{timecut}. If given as a matrix the
+parameters are interpreted as log-rates (and log-rate-ratios for
+the time-varying covariates defined in the formula).}
+
+\item{timecut}{Time intervals}
+
+\item{type}{Type of model (default piecewise constant intensity)}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\description{
+Add time-varying covariate effects to model
+}
+\examples{
+
+## Piecewise constant hazard
+m <- lvm(y~1)
+m <- timedep(m,y~1,timecut=c(0,5),rate=c(0.5,0.3))
+
+\dontrun{
+d <- sim(m,1e4); d$status <- TRUE
+dd <- mets::lifetable(Surv(y,status)~1,data=d,breaks=c(0,5,10));
+exp(coef(glm(events ~ offset(log(atrisk)) + -1 + interval, dd, family=poisson)))
+}
+
+
+## Piecewise constant hazard and time-varying effect of z1
+m <- lvm(y~1)
+distribution(m,~z1) <- ones.lvm(0.5)
+R <- log(cbind(c(0.2,0.7,0.9),c(0.5,0.3,0.3)))
+m <- timedep(m,y~z1,timecut=c(0,3,5),rate=R)
+
+\dontrun{
+d <- sim(m,1e4); d$status <- TRUE
+dd <- mets::lifetable(Surv(y,status)~z1,data=d,breaks=c(0,3,5,Inf));
+exp(coef(glm(events ~ offset(log(atrisk)) + -1 + interval+z1:interval, dd, family=poisson)))
+}
+
+
+
+## Explicit simulation of time-varying effects
+m <- lvm(y~1)
+distribution(m,~z1) <- ones.lvm(0.5)
+distribution(m,~z2) <- binomial.lvm(p=0.5)
+#variance(m,~m1+m2) <- 0
+#regression(m,m1[m1:0] ~ z1) <- log(0.5)
+#regression(m,m2[m2:0] ~ z1) <- log(0.3)
+regression(m,m1 ~ z1,variance=0) <- log(0.5)
+regression(m,m2 ~ z1,variance=0) <- log(0.3)
+intercept(m,~m1+m2) <- c(-0.5,0)
+m <- timedep(m,y~m1+m2,timecut=c(0,5))
+
+\dontrun{
+d <- sim(m,1e5); d$status <- TRUE
+dd <- mets::lifetable(Surv(y,status)~z1,data=d,breaks=c(0,5,Inf))
+exp(coef(glm(events ~ offset(log(atrisk)) + -1 + interval + interval:z1, dd, family=poisson)))
+}
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/toformula.Rd b/man/toformula.Rd
new file mode 100644
index 0000000..6677b58
--- /dev/null
+++ b/man/toformula.Rd
@@ -0,0 +1,33 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/toformula.R
+\name{toformula}
+\alias{toformula}
+\title{Converts strings to formula}
+\usage{
+toformula(y = ".", x = ".")
+}
+\arguments{
+\item{y}{vector of predictors}
+
+\item{x}{vector of responses}
+}
+\value{
+An object of class \code{formula}
+}
+\description{
+Converts a vector of predictors and a vector of responses (characters) i#nto
+a formula expression.
+}
+\examples{
+
+toformula(c("age","gender"), "weight")
+
+}
+\seealso{
+\code{\link{as.formula}},
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{utilities}
diff --git a/man/tr.Rd b/man/tr.Rd
new file mode 100644
index 0000000..5678729
--- /dev/null
+++ b/man/tr.Rd
@@ -0,0 +1,31 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tr.R
+\name{tr}
+\alias{tr}
+\title{Trace operator}
+\usage{
+tr(x, ...)
+}
+\arguments{
+\item{x}{Square numeric matrix}
+
+\item{\dots}{Additional arguments to lower level functions}
+}
+\value{
+\code{numeric}
+}
+\description{
+Calculates the trace of a square matrix.
+}
+\examples{
+
+tr(diag(1:5))
+}
+\seealso{
+\code{\link{crossprod}}, \code{\link{tcrossprod}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{algebra}
+\keyword{math}
diff --git a/man/trim.Rd b/man/trim.Rd
new file mode 100644
index 0000000..18b328a
--- /dev/null
+++ b/man/trim.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/trim.R
+\name{trim}
+\alias{trim}
+\title{Trim tring of (leading/trailing/all) white spaces}
+\usage{
+trim(x, all = FALSE, ...)
+}
+\arguments{
+\item{x}{String}
+
+\item{all}{Trim all whitespaces?}
+
+\item{\dots}{additional arguments to lower level functions}
+}
+\description{
+Trim tring of (leading/trailing/all) white spaces
+}
+\author{
+Klaus K. Holst
+}
diff --git a/man/twindata.Rd b/man/twindata.Rd
new file mode 100644
index 0000000..21b350c
--- /dev/null
+++ b/man/twindata.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/lava-package.R
+\docType{data}
+\name{twindata}
+\alias{twindata}
+\title{Twin menarche data}
+\format{data.frame}
+\source{
+Simulated
+}
+\description{
+Simulated data
+\tabular{rll}{
+ id \tab numeric \tab Twin-pair id \cr
+ zyg \tab character \tab Zygosity (MZ or DZ) \cr
+ twinnum \tab numeric \tab Twin number (1 or 2) \cr
+ agemena \tab numeric \tab Age at menarche (or censoring) \cr
+ status \tab logical \tab Censoring status (observed:=T,censored:=F) \cr
+ bw \tab numeric \tab Birth weight \cr
+ msmoke \tab numeric \tab Did mother smoke? (yes:=1,no:=0) \cr
+}
+}
+\keyword{datasets}
diff --git a/man/twostage.Rd b/man/twostage.Rd
new file mode 100644
index 0000000..bbac427
--- /dev/null
+++ b/man/twostage.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/twostage.R
+\name{twostage}
+\alias{twostage}
+\title{Two-stage estimator}
+\usage{
+twostage(object, ...)
+}
+\arguments{
+\item{object}{Model object}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\description{
+Generic function.
+}
+\seealso{
+twostage.lvm twostage.lvmfit twostage.lvm.mixture twostage.estimate
+}
diff --git a/man/twostage.lvmfit.Rd b/man/twostage.lvmfit.Rd
new file mode 100644
index 0000000..66fe697
--- /dev/null
+++ b/man/twostage.lvmfit.Rd
@@ -0,0 +1,126 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/twostage.R
+\name{twostage.lvmfit}
+\alias{twostage.lvmfit}
+\alias{twostage.lvm}
+\alias{twostage.lvm.mixture}
+\alias{twostage.estimate}
+\alias{nonlinear}
+\alias{nonlinear<-}
+\title{Two-stage estimator (non-linear SEM)}
+\usage{
+\method{twostage}{lvmfit}(object, model2, data = NULL,
+ predict.fun = function(mu, var, data, ...) cbind(u1 = mu[, 1], u2 = mu[,
+ 1]^2 + var[1]), id1 = NULL, id2 = NULL, all = FALSE, formula = NULL,
+ std.err = TRUE, ...)
+}
+\arguments{
+\item{object}{Stage 1 measurement model}
+
+\item{model2}{Stage 2 SEM}
+
+\item{data}{data.frame}
+
+\item{predict.fun}{Prediction of latent variable}
+
+\item{id1}{Optional id-variable (stage 1 model)}
+
+\item{id2}{Optional id-variable (stage 2 model)}
+
+\item{all}{If TRUE return additional output (naive estimates)}
+
+\item{formula}{optional formula specifying non-linear relation}
+
+\item{std.err}{If FALSE calculations of standard errors will be skipped}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\description{
+Two-stage estimator for non-linear structural equation models
+}
+\examples{
+m <- lvm(c(x1,x2,x3)~f1,f1~z,
+ c(y1,y2,y3)~f2,f2~f1+z)
+latent(m) <- ~f1+f2
+d <- simulate(m,100,p=c("f2,f2"=2,"f1,f1"=0.5),seed=1)
+
+## Full MLE
+ee <- estimate(m,d)
+
+## Manual two-stage
+\dontrun{
+m1 <- lvm(c(x1,x2,x3)~f1,f1~z); latent(m1) <- ~f1
+e1 <- estimate(m1,d)
+pp1 <- predict(e1,f1~x1+x2+x3)
+
+d$u1 <- pp1[,]
+d$u2 <- pp1[,]^2+attr(pp1,"cond.var")[1]
+m2 <- lvm(c(y1,y2,y3)~eta,c(y1,eta)~u1+u2+z); latent(m2) <- ~eta
+e2 <- estimate(m2,d)
+}
+
+## Two-stage
+m1 <- lvm(c(x1,x2,x3)~f1,f1~z); latent(m1) <- ~f1
+m2 <- lvm(c(y1,y2,y3)~eta,c(y1,eta)~u1+u2+z); latent(m2) <- ~eta
+pred <- function(mu,var,data,...)
+ cbind("u1"=mu[,1],"u2"=mu[,1]^2+var[1])
+(mm <- twostage(m1,model2=m2,data=d,predict.fun=pred))
+
+if (interactive()) {
+ pf <- function(p) p["eta"]+p["eta~u1"]*u + p["eta~u2"]*u^2
+ plot(mm,f=pf,data=data.frame(u=seq(-2,2,length.out=100)),lwd=2)
+}
+
+## Splines
+f <- function(x) cos(2*x)+x+-0.25*x^2
+m <- lvm(x1+x2+x3~eta1, y1+y2+y3~eta2, latent=~eta1+eta2)
+functional(m, eta2~eta1) <- f
+d <- sim(m,500,seed=1,latent=TRUE)
+m1 <- lvm(x1+x2+x3~eta1,latent=~eta1)
+m2 <- lvm(y1+y2+y3~eta2,latent=~eta2)
+mm <- twostage(m1,m2,formula=eta2~eta1,type="spline")
+if (interactive()) plot(mm)
+
+nonlinear(m2,type="quadratic") <- eta2~eta1
+a <- twostage(m1,m2,data=d)
+if (interactive()) plot(a)
+
+kn <- c(-1,0,1)
+nonlinear(m2,type="spline",knots=kn) <- eta2~eta1
+a <- twostage(m1,m2,data=d)
+x <- seq(-3,3,by=0.1)
+y <- predict(a, newdata=data.frame(eta1=x))
+
+if (interactive()) {
+ plot(eta2~eta1, data=d)
+ lines(x,y, col="red", lwd=5)
+
+ p <- estimate(a,f=function(p) predict(a,p=p,newdata=x))$coefmat
+ plot(eta2~eta1, data=d)
+ lines(x,p[,1], col="red", lwd=5)
+ confband(x,lower=p[,3],upper=p[,4],center=p[,1], polygon=TRUE, col=Col(2,0.2))
+
+ l1 <- lm(eta2~splines::ns(eta1,knots=kn),data=d)
+ p1 <- predict(l1,newdata=data.frame(eta1=x),interval="confidence")
+ lines(x,p1[,1],col="green",lwd=5)
+ confband(x,lower=p1[,2],upper=p1[,3],center=p1[,1], polygon=TRUE, col=Col(3,0.2))
+}
+
+\dontrun{ ## Reduce timing
+ ## Cross-validation example
+ ma <- lvm(c(x1,x2,x3)~u,latent=~u)
+ ms <- functional(ma, y~u, f=function(x) -.4*x^2)
+ d <- sim(ms,500)#,seed=1)
+ ea <- estimate(ma,d)
+
+ mb <- lvm()
+ mb1 <- nonlinear(mb,type="linear",y~u)
+ mb2 <- nonlinear(mb,type="quadratic",y~u)
+ mb3 <- nonlinear(mb,type="spline",knots=c(-3,-1,0,1,3),y~u)
+ mb4 <- nonlinear(mb,type="spline",knots=c(-3,-2,-1,0,1,2,3),y~u)
+ ff <- lapply(list(mb1,mb2,mb3,mb4),
+ function(m) function(data,...) twostage(ma,m,data=data,st.derr=FALSE))
+ a <- cv(ff,data=d,rep=1,mc.cores=1)
+ a
+}
+}
diff --git a/man/vars.Rd b/man/vars.Rd
new file mode 100644
index 0000000..30d9440
--- /dev/null
+++ b/man/vars.Rd
@@ -0,0 +1,106 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/vars.R
+\name{vars}
+\alias{vars}
+\alias{vars.lvm}
+\alias{vars.lvmfit}
+\alias{latent}
+\alias{latent<-}
+\alias{latent.lvm}
+\alias{latent<-.lvm}
+\alias{latent.lvmfit}
+\alias{latent.multigroup}
+\alias{manifest}
+\alias{manifest.lvm}
+\alias{manifest.lvmfit}
+\alias{manifest.multigroup}
+\alias{exogenous}
+\alias{exogenous<-}
+\alias{exogenous.lvm}
+\alias{exogenous<-.lvm}
+\alias{exogenous.lvmfit}
+\alias{exogenous.multigroup}
+\alias{endogenous}
+\alias{endogenous.lvm}
+\alias{endogenous.lvmfit}
+\alias{endogenous.multigroup}
+\title{Extract variable names from latent variable model}
+\usage{
+vars(x,...)
+
+endogenous(x,...)
+
+exogenous(x,...)
+
+manifest(x,...)
+
+latent(x,...)
+
+\method{exogenous}{lvm}(x,silent = FALSE, xfree = TRUE,...) <- value
+
+\method{exogenous}{lvm}(x,latent=FALSE,index=TRUE,...)
+
+\method{latent}{lvm}(x,clear=FALSE,...) <- value
+}
+\arguments{
+\item{x}{\code{lvm}-object}
+
+\item{\dots}{Additional arguments to be passed to the low level functions}
+
+\item{latent}{Logical defining whether latent variables without parents
+should be included in the result}
+
+\item{index}{For internal use only}
+
+\item{clear}{Logical indicating whether to add or remove latent variable
+status}
+
+\item{silent}{Suppress messages}
+
+\item{xfree}{For internal use only}
+
+\item{value}{Formula or character vector of variable names.}
+}
+\value{
+Vector of variable names.
+}
+\description{
+Extract exogenous variables (predictors), endogenous variables (outcomes),
+latent variables (random effects), manifest (observed) variables from a
+\code{lvm} object.
+}
+\details{
+\code{vars} returns all variables of the \code{lvm}-object including
+manifest and latent variables. Similarily \code{manifest} and \code{latent}
+returns the observered resp. latent variables of the model.
+\code{exogenous} returns all manifest variables without parents, e.g.
+covariates in the model, however the argument \code{latent=TRUE} can be used
+to also include latent variables without parents in the result. Pr. default
+\code{lava} will not include the parameters of the exogenous variables in
+the optimisation routine during estimation (likelihood of the remaining
+observered variables conditional on the covariates), however this behaviour
+can be altered via the assignment function \code{exogenous<-} telling
+\code{lava} which subset of (valid) variables to condition on. Finally
+\code{latent} returns a vector with the names of the latent variables in
+\code{x}. The assigment function \code{latent<-} can be used to change the
+latent status of variables in the model.
+}
+\examples{
+
+g <- lvm(eta1 ~ x1+x2)
+regression(g) <- c(y1,y2,y3) ~ eta1
+latent(g) <- ~eta1
+endogenous(g)
+exogenous(g)
+identical(latent(g), setdiff(vars(g),manifest(g)))
+
+}
+\seealso{
+\code{\link{endogenous}}, \code{\link{manifest}},
+\code{\link{latent}}, \code{\link{exogenous}}, \code{\link{vars}}
+}
+\author{
+Klaus K. Holst
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/vec.Rd b/man/vec.Rd
new file mode 100644
index 0000000..aa05ea8
--- /dev/null
+++ b/man/vec.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/vec.R
+\name{vec}
+\alias{vec}
+\title{vec operator}
+\usage{
+vec(x, matrix = FALSE, sep = ".", ...)
+}
+\arguments{
+\item{x}{Array}
+
+\item{matrix}{If TRUE a row vector (matrix) is returned}
+
+\item{sep}{Seperator}
+
+\item{...}{Additional arguments}
+}
+\description{
+vec operator
+}
+\details{
+Convert array into vector
+}
+\author{
+Klaus Holst
+}
diff --git a/man/wrapvec.Rd b/man/wrapvec.Rd
new file mode 100644
index 0000000..1fb9d30
--- /dev/null
+++ b/man/wrapvec.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/wrapvec.R
+\name{wrapvec}
+\alias{wrapvec}
+\title{Wrap vector}
+\usage{
+wrapvec(x, delta = 0L, ...)
+}
+\arguments{
+\item{x}{Vector or integer}
+
+\item{delta}{Shift}
+
+\item{...}{Additional parameters}
+}
+\description{
+Wrap vector
+}
+\examples{
+wrapvec(5,2)
+}
diff --git a/man/zibreg.Rd b/man/zibreg.Rd
new file mode 100644
index 0000000..862c16d
--- /dev/null
+++ b/man/zibreg.Rd
@@ -0,0 +1,74 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/zib.R
+\name{zibreg}
+\alias{zibreg}
+\title{Regression model for binomial data with unkown group of immortals}
+\usage{
+zibreg(formula, formula.p = ~1, data, family = stats::binomial(),
+ offset = NULL, start, var = "hessian", ...)
+}
+\arguments{
+\item{formula}{Formula specifying}
+
+\item{formula.p}{Formula for model of disease prevalence}
+
+\item{data}{data frame}
+
+\item{family}{Distribution family (see the help page \code{family})}
+
+\item{offset}{Optional offset}
+
+\item{start}{Optional starting values}
+
+\item{var}{Type of variance (robust, expected, hessian, outer)}
+
+\item{...}{Additional arguments to lower level functions}
+}
+\description{
+Regression model for binomial data with unkown group of immortals (zero-inflated binomial regression)
+}
+\examples{
+
+## Simulation
+n <- 2e3
+x <- runif(n,0,20)
+age <- runif(n,10,30)
+z0 <- rnorm(n,mean=-1+0.05*age)
+z <- cut(z0,breaks=c(-Inf,-1,0,1,Inf))
+p0 <- lava:::expit(model.matrix(~z+age) \%*\% c(-.4, -.4, 0.2, 2, -0.05))
+y <- (runif(n)<lava:::tigol(-1+0.25*x-0*age))*1
+u <- runif(n)<p0
+y[u==0] <- 0
+d <- data.frame(y=y,x=x,u=u*1,z=z,age=age)
+head(d)
+
+## Estimation
+e0 <- zibreg(y~x*z,~1+z+age,data=d)
+e <- zibreg(y~x,~1+z+age,data=d)
+compare(e,e0)
+e
+PD(e0,intercept=c(1,3),slope=c(2,6))
+
+B <- rbind(c(1,0,0,0,20),
+ c(1,1,0,0,20),
+ c(1,0,1,0,20),
+ c(1,0,0,1,20))
+prev <- summary(e,pr.contrast=B)$prevalence
+
+x <- seq(0,100,length.out=100)
+newdata <- expand.grid(x=x,age=20,z=levels(d$z))
+fit <- predict(e,newdata=newdata)
+plot(0,0,type="n",xlim=c(0,101),ylim=c(0,1),xlab="x",ylab="Probability(Event)")
+count <- 0
+for (i in levels(newdata$z)) {
+ count <- count+1
+ lines(x,fit[which(newdata$z==i)],col="darkblue",lty=count)
+}
+abline(h=prev[3:4,1],lty=3:4,col="gray")
+abline(h=prev[3:4,2],lty=3:4,col="lightgray")
+abline(h=prev[3:4,3],lty=3:4,col="lightgray")
+legend("topleft",levels(d$z),col="darkblue",lty=seq_len(length(levels(d$z))))
+}
+\author{
+Klaus K. Holst
+}
diff --git a/tests/test-all.R b/tests/test-all.R
new file mode 100644
index 0000000..b8d9b89
--- /dev/null
+++ b/tests/test-all.R
@@ -0,0 +1,4 @@
+#library("lava")
+suppressPackageStartupMessages(library("testthat"))
+test_check("lava")
+
diff --git a/tests/testthat/test-constrain.R b/tests/testthat/test-constrain.R
new file mode 100644
index 0000000..e12220c
--- /dev/null
+++ b/tests/testthat/test-constrain.R
@@ -0,0 +1,133 @@
+context("Constraints")
+
+test_that("Simple linear constraint",{
+ m1 <- lvm(y[m:v] ~ f(x,beta)+f(z,beta2))
+ constrain(m1,beta2~psi) <- function(x) 2*x
+ expect_output(summary(m1),"Non-linear constraints:")
+
+ lava:::matrices.lvm(m1,1:2,0,3)
+ d1 <- sim(m1,100)
+ e1 <- estimate(m1,d1)
+ expect_output(print(e1),"y~x")
+ expect_warning(e1,NA)
+
+ expect_true((constraints(e1)[1]-coef(lm(y~x+z,d1))["z"])^2<1e-9)
+ s <- summary(e1)
+ expect_output(print(s),"Non-linear constraints:")
+
+ expect_equivalent(dim(coef(s)), c(length(coef(e1))+1,4))
+ expect_equivalent(dim(coef(e1,2)), c(length(coef(e1)),4))
+})
+
+
+test_that("constrain (Fishers z-transform)",{
+ set.seed(1)
+ m <- lvm(c(y1[m1:v1],y2[m2:v2])~x)
+ covariance(m,y1~y2) <- "C"
+ d <- sim(m,100)
+ e <- estimate(m,d)
+ constrain(e,rho~C+v1+v2) <-
+ function(x) x[1]/(x[2]*x[3])^0.5
+ cc1 <- coef(summary(correlation(e)))
+ cc2 <- constraints(e)
+ expect_equivalent(cc2["rho",1],cc1["y1~y2",1])
+ constrain(e,z~C+v1+v2) <- function(x) {
+ f <- function(p) p[1]/sqrt(p[2]*p[3])
+ res <- atanh(f(x))
+ df <- function(p) c(1/sqrt(p[2]*p[3]), -f(p)/(2*p[2]), -f(p)/(2*p[3]))
+ datanh <- function(r) 1/(1-r^2)
+ attributes(res)$grad <- function(p) datanh(f(p))*df(p)
+ attributes(res)$inv <- tanh
+ return(res)
+ }
+ cc2 <- constraints(e)
+ expect_equal(cc2["z",2],0.1)
+ expect_equivalent(cc2["inv(z)",1],cc1["y1~y2",1])
+})
+
+
+test_that("Non-linear in exogenous variables", {
+ d <- data.frame(x=1:5,y=c(0.5,1.5,2,3,3.5))
+ m <- lvm(y[m] ~ 1)
+ addvar(m) <- ~x
+ parameter(m) <- ~a+b
+ constrain(m,m~a+b+x) <- function(z) z[1]+z[2]*z[3]
+ e <- estimate(m,d,control=list(method="NR"))
+ expect_true(mean(coef(lm(y~x,d))-coef(e)[c("a","b")])^2<1e-3)
+})
+
+
+test_that("Probit constraints", {
+ if (!requireNamespace("mets",quietly=TRUE)) {
+ if (as.numeric(strsplit(sessionInfo()$otherPkgs$mets$Version,".",fixed=TRUE)[[1]][1])>0) { ## At least major version 1
+ x <- transform(data.frame(lava:::rmvn(1000,sigma=0.5*diag(2)+0.5)),
+ X1=as.numeric(cut(X1,breaks=3))-1,X2=as.numeric(cut(X2,breaks=3))-1)
+ m <- covariance(lvm(),X1~X2)
+ ordinal(m,K=3,constrain=list("t1","t2")) <- ~X1
+ ordinal(m,K=3,constrain=list("t1","t2")) <- ~X2
+ ## e <- estimate(m,x)
+ e <- estimate(list(m,m),list(x[1:500,],x[501:1000,]),estimator="normal")
+ estimate(e)
+ }
+ }
+})
+
+
+test_that("Multiple group constraints I", {
+ m1 <- lvm(y[m:v] ~ f(x,beta)+f(z,beta2))
+ d1 <- sim(m1,500,seed=1); d2 <- sim(m1,500,seed=2)
+ ##coef(estimate(m1,d1))
+ constrain(m1,beta2~psi) <- function(x) 2*x
+ m2 <- lvm(y[m:v] ~ f(x,beta2) + z)
+ constrain(m2,beta2~psi) <- function(x) 2*x
+ mg <- multigroup(list(m1,m2),list(d1,d2))
+ ee <- estimate(mg)
+ expect_true(length(coef(ee))==5)
+ expect_equivalent(constraints(ee)[1],2*coef(ee)["1 at psi"]) # Est
+ expect_equivalent(constraints(ee)[2],2*coef(ee,2)[[1]]["psi",2]) # Std.Err
+})
+
+test_that("Multiple group constraints II", {
+ data("twindata",package="lava")
+ twinwide <- reshape(twindata,direction="wide",
+ idvar="id",timevar="twinnum")
+ l <- lvm(~bw.1+bw.2)
+ covariance(l) <- bw.1 ~ bw.2
+ e <- estimate(l,subset(twinwide,zyg.1=="MZ"),control=list(method="NR"))
+ B <- cbind(1,-1); colnames(B) <- c("bw.1,bw.1","bw.2,bw.2")
+ colnames(B) <- gsub(",",lava.options()$symbols[2],colnames(B))
+ lava::compare(e,contrast=B)
+ B2 <- rbind(c(1,-1,0,0),c(0,0,1,-1))
+ colnames(B2) <- c("bw.1","bw.2","bw.1,bw.1","bw.2,bw.2")
+ colnames(B2) <- gsub(",",lava.options()$symbols[2],colnames(B2))
+
+ lava::compare(e,contrast=B2)
+
+ l <- lvm(~bw.1+bw.2)
+ covariance(l) <- bw.1 ~ bw.2
+ intercept(l,~bw.1+bw.2) <- "m"
+ covariance(l,~bw.1+bw.2) <- "s"
+ covariance(l,bw.1~bw.2) <- "r1"
+ l2 <- l
+ covariance(l2,bw.1~bw.2) <- "r2"
+
+ DZ <- subset(twinwide,zyg.1=="MZ")
+ MZ <- subset(twinwide,zyg.1=="DZ")
+ ## e <- estimate(l,MZ)
+ ## e2 <- estimate(l2,DZ)
+
+ parameter(l) <- ~r2
+ parameter(l2) <- ~r1
+ ee <- estimate(list(MZ=l,DZ=l2),list(MZ,DZ),control=list(method="NR",tol=1e-9,constrain=FALSE))
+ expect_true(mean(score(ee)^2)<1e-9)
+
+ constrain(ee,h~r2+r1) <- function(x) 2*(x[1]-x[2])
+ ce <- constraints(ee)
+ expect_equivalent(constraints(ee)[1],2*diff(coef(ee)[3:4]))
+ expect_true(length(coef(ee))==4)
+ expect_true(nrow(ce)==1)
+ expect_true(all(!is.na(ce)))
+})
+
+
+
diff --git a/tests/testthat/test-estimate_default.R b/tests/testthat/test-estimate_default.R
new file mode 100644
index 0000000..b958073
--- /dev/null
+++ b/tests/testthat/test-estimate_default.R
@@ -0,0 +1,55 @@
+context("Inference")
+
+test_that("estimate.default", {
+ m <- lvm(c(y1,y2)~x+z,y1~~y2)
+## set.seed(1)
+ d <- sim(m,20)
+ dd <- mets::fast.reshape(d)
+
+ l1 <- lm(y1~x+z,d)
+ l2 <- lm(y2~x+z,d)
+ ll <- merge(l1,l2)
+ expect_equivalent(ll$coefmat[,1],c(coef(l1),coef(l2)))
+
+ e1 <- estimate(l1)
+ f1 <- estimate(l1,function(x) x^2, use=2)
+ expect_true(coef(l1)["x"]^2==f1$coefmat[1])
+
+ e1b <- estimate(NULL,coef=coef(l1),vcov=vcov(estimate(l1)))
+ e1c <- estimate(NULL,coef=coef(l1),iid=iid(l1))
+ expect_equivalent(vcov(e1b),vcov(e1c))
+ expect_equivalent(crossprod(iid(e1)),vcov(e1b))
+
+ f1b <- estimate(e1b,function(x) x^2)
+ expect_equivalent(f1b$coefmat[2,,drop=FALSE],f1$coefmat)
+
+ h1 <- estimate(l1,cbind(0,1,0))
+ expect_true(h1$coefmat[,5]==e1$coefmat["x",5])
+
+ ## GEE
+ if (requireNamespace("geepack",quietly=TRUE)) {
+ l <- lm(y~x+z,dd)
+ g1 <- estimate(l,id=dd$id)
+ g2 <- geepack::geeglm(y~x+z,id=dd$id,data=dd)
+ expect_equivalent(g1$coefmat[,c(1,2,5)],
+ as.matrix(summary(g2)$coef[,c(1,2,4)]))
+ }
+
+ ## Several parameters
+ e1d <- estimate(l1, function(x) list("X"=x[2],"Z"=x[3]))
+ expect_equivalent(e1d$coefmat,e1$coefmat[-1,])
+
+ expect_true(rownames(estimate(l1, function(x) list("X"=x[2],"Z"=x[3]),keep="X")$coefmat)=="X")
+ expect_true(rownames(estimate(l1, labels=c("a"), function(x) list("X"=x[2],"Z"=x[3]),keep="X")$coefmat)=="a")
+
+
+ a0 <- estimate(l1,function(p,data) p[1]+p[2]*data[,"x"], average=TRUE)
+ a1 <- estimate(l1,function(p,data) p[1]+p[2]*data[,"x"]+p[3], average=TRUE)
+ a <- merge(a0,a1,labels=c("a0","a1"))
+ estimate(a,diff)
+ expect_equivalent(estimate(a,diff)$coefmat,e1$coefmat[3,,drop=FALSE])
+
+
+ stack
+
+})
diff --git a/tests/testthat/test-graph.R b/tests/testthat/test-graph.R
new file mode 100644
index 0000000..0ebce71
--- /dev/null
+++ b/tests/testthat/test-graph.R
@@ -0,0 +1,15 @@
+context("Inference")
+
+test_that("d-separation",{
+ m <- lvm(x5 ~ x4+x3, x4~x3+x1, x3~x2, x2~x1)
+ expect_true(dsep(m,x5~x1|x3+x4))
+ expect_false(dsep(m,x5~x1|x2+x4))
+ expect_true(dsep(m,x5~x1|x2+x3+x4))
+ expect_false(dsep(m,~x1+x2+x3|x4))
+
+ expect_true(setequal(ancestors(m,~x5),setdiff(vars(m),"x5")))
+ expect_true(setequal(ancestors(m,~x1),NULL))
+ expect_true(setequal(descendants(m,~x5),NULL))
+ expect_true(setequal(descendants(m,~x1),setdiff(vars(m),"x1")))
+})
+
diff --git a/tests/testthat/test-inference.R b/tests/testthat/test-inference.R
new file mode 100644
index 0000000..8d85b44
--- /dev/null
+++ b/tests/testthat/test-inference.R
@@ -0,0 +1,514 @@
+context("Inference")
+
+test_that("Effects",{
+ m <- lvm()
+ regression(m) <- c(y1,y2,y3)~u; latent(m) <- ~u
+ regression(m) <- c(z1,z2,z3)~v; latent(m) <- ~v
+ regression(m) <- u~v
+ regression(m) <- c(u,v,z3,y1)~x
+ d <- sim(m,100,seed=1)
+ start <- c(rep(0,6),rep(1,17))
+ suppressWarnings(e <- estimate(m,d,control=list(iter.max=0,start=start)))
+ f <- summary(ef <- effects(e,y1~x))$coef
+ expect_true(all(f[,2]>0)) ## Std.err
+ expect_equal(f["Total",1],3)
+ expect_equal(f["Direct",1],1)
+ f2 <- summary(effects(e,u~v))$coef
+ expect_equal(f2["Total",1],1)
+ expect_equal(f2["Direct",1],1)
+ expect_equal(f2["Indirect",1],0)
+
+ expect_output(print(ef),"Mediation proportion")
+ expect_equivalent(confint(ef)["Direct",],
+ confint(e)["y1~x",])
+
+ expect_equivalent(totaleffects(e,y1~x)[,1:4],f["Total",])
+
+ g <- graph::updateGraph(plot(m,noplot=TRUE))
+ expect_equivalent(path(g,y1~x),path(m,y1~x))
+})
+
+test_that("Profile confidence limits", {
+ m <- lvm(y~b*x)
+ constrain(m,b~psi) <- identity
+ set.seed(1)
+ d <- sim(m,100,seed=1)
+ e <- estimate(m, d)
+ ci0 <- confint(e,3)
+ ci <- confint(e,3,profile=TRUE)
+ expect_true(mean((ci0-ci)^2)<0.1)
+})
+
+test_that("IV-estimator", {
+ m <- lvm(c(y1,y2,y3)~u); latent(m) <- ~u
+ set.seed(1)
+ d <- sim(m,100,seed=1)
+ e0 <- estimate(m,d)
+ e <- estimate(m,d,estimator="iv") ## := MLE
+ expect_true(mean((coef(e)-coef(e0))^2)<1e-9)
+})
+
+test_that("glm-estimator", {
+ m <- lvm(y~x+z)
+ regression(m) <- x~z
+ distribution(m,~y+z) <- binomial.lvm("logit")
+ set.seed(1)
+ d <- sim(m,1e3,seed=1)
+ head(d)
+ e <- estimate(m,d,estimator="glm")
+ c1 <- coef(e,2)[c("y","y~x","y~z"),1:2]
+ c2 <- estimate(glm(y~x+z,d,family=binomial))$coefmat[,1:2]
+ expect_equivalent(c1,c2)
+})
+
+
+test_that("gaussian", {
+ m <- lvm(y~x)
+ d <- simulate(m,100,seed=1)
+ S <- cov(d[,vars(m),drop=FALSE])
+ mu <- colMeans(d[,vars(m),drop=FALSE])
+ f <- function(p) lava:::gaussian_objective.lvm(p,x=m,S=S,mu=mu,n=nrow(d))
+ g <- function(p) lava:::gaussian_score.lvm(p,x=m,n=nrow(d),data=d,indiv=TRUE)
+ s1 <- numDeriv::grad(f,c(0,1,1))
+ s2 <- g(c(0,1,1))
+ expect_equal(s1,-colSums(s2),tolerance=0.1)
+})
+
+
+test_that("Association measures", {
+ P <- matrix(c(0.25,0.25,0.25,0.25),2)
+ a1 <- lava:::assoc(P)
+ expect_equivalent(-log(0.25),a1$H)
+ expect_true(with(a1, all(c(kappa,gamma,MI,U.sym)==0)))
+
+ p <- lava:::prob.normal(sigma=diag(nrow=2),breaks=c(-Inf,0),breaks2=c(-Inf,0))[1]
+ expect_equal(p[1],0.25)
+ ## q <- qnorm(0.75)
+ ## m <- ordinal(lvm(y~x),~y, K=3)#, breaks=c(-q,q))
+ ## normal.threshold(m,p=c(0,1,2))
+})
+
+
+test_that("equivalence", {
+ m <- lvm(c(y1,y2,y3)~u,u~x,y1~x)
+ latent(m) <- ~u
+ d <- sim(m,100,seed=1)
+ cancel(m) <- y1~x
+ regression(m) <- y2~x
+ e <- estimate(m,d)
+ ##eq <- equivalence(e,y1~x,k=1)
+ dm <- capture.output(eq <- equivalence(e,y2~x,k=1))
+ expect_output(print(eq),paste0("y1",lava.options()$symbol[2],"y3"))
+ expect_true(all(c("y1","y3")%in%eq$equiv[[1]][1,]))
+})
+
+test_that("multiple testing", {
+ expect_equivalent(lava:::holm(c(0.05/3,0.025,0.05)),rep(0.05,3))
+
+ ci1 <- scheffe(l <- lm(1:5~c(0.5,0.7,1,1.3,1.5)))
+ ci2 <- predict(l,interval="confidence")
+ expect_equivalent(ci1[,1],ci2[,1])
+ expect_true(all(ci1[,2]<ci2[,2]))
+ expect_true(all(ci1[,3]>ci2[,3]))
+})
+
+
+test_that("modelsearch and GoF", {
+ m <- lvm(c(y1,y2)~x)
+ d <- sim(m,100,seed=1)
+ e <- estimate(lvm(c(y1,y2)~1,y1~x),d)
+ e0 <- estimate(lvm(c(y1,y2)~x,y1~~y2),d)
+
+ s1 <- modelsearch(e,silent=TRUE,type="correlation")
+ expect_true(nrow(s1$res)==2)
+ s1b <- modelsearch(e,silent=TRUE,type="regression")
+ expect_true(nrow(s1b$res)==4)
+ s2 <- modelsearch(e0,silent=TRUE,dir="backward")
+ expect_true(nrow(s2$res)==3)
+ e00 <- estimate(e0,vcov=vcov(e0))$coefmat
+ ii <- match(s2$res[,"Index"],rownames(e00))
+ expect_equivalent(e00[ii,5],s2$test[,2])
+
+ s3 <- modelsearch(e0,dir="backward",k=3)
+ expect_true(nrow(s3$res)==1)
+
+ ee <- modelsearch(e0,dir="backstep",messages=FALSE)
+ expect_true(inherits(ee,"lvm"))
+
+ ## TODO
+ gof(e,all=TRUE)
+ r <- rsq(e)[[1]]
+ expect_true(abs(summary(lm(y1~x,d))$r.square-r["y1"])<1e-5)
+
+})
+
+test_that("Bootstrap", {
+ y <- rep(c(0,1),each=5)
+ x <- 1:10
+ e <- estimate(y~x)
+ B1 <- bootstrap(e,R=2,silent=TRUE,mc.cores=1,sd=TRUE)
+ B2 <- bootstrap(e,R=2,silent=TRUE,bollenstine=TRUE,mc.cores=1)
+ expect_false(B1$bollenstine)
+ expect_true(B2$bollenstine)
+ expect_true(nrow(B1$coef)==2)
+ expect_output(print(B1),"Standard errors:")
+ dm <- capture.output(B3 <- bootstrap(e,R=2,fun=function(x) coef(x)[2]^2+10))
+ expect_true(all(mean(B3$coef)>10))
+
+ y <- rep(c(0,1),each=5)
+ x <- 1:10
+ m <- lvm(y~b*x)
+ constrain(m,alpha~b) <- function(x) x^2
+ e <- estimate(m,data.frame(y=y,x=x))
+ b <- bootstrap(e,R=1,silent=TRUE)
+ expect_output(print(b),"alpha")
+})
+
+
+test_that("Survreg", {
+ m <- lvm(y0~x)
+ transform(m,y~y0) <- function(x) pmin(x[,1],2)
+ transform(m,status~y0) <- function(x) x<2
+ d <- simulate(m,100,seed=1)
+ require('survival')
+ m <- survreg(Surv(y,status)~x,data=d,dist='gaussian')
+ s <- score(m)
+ expect_true(length(pars(m))==length(coef(m))+1)
+ expect_true(abs(attr(score(m,pars(m)),'logLik')-logLik(m))<1e-9)
+ expect_true(mean(colSums(s)^2)<1e-6)
+ expect_equivalent(vcov(m),attr(s,'bread'))
+})
+
+
+
+test_that("Combine", { ## Combine model output
+ data(serotonin)
+ m1 <- lm(cau ~ age*gene1 + age*gene2,data=serotonin)
+ m2 <- lm(cau ~ age + gene1,data=serotonin)
+
+ cc <- Combine(list('model A'=m1,'model B'=m2),fun=function(x) c(R2=format(summary(x)$r.squared,digits=2)))
+ expect_true(nrow(cc)==length(coef(m1))+1)
+ expect_equivalent(colnames(cc),c('model A','model B'))
+ expect_equivalent(cc['R2',2],format(summary(m2)$r.squared,digits=2))
+
+})
+
+
+
+test_that("zero-inflated binomial regression (zib)", {
+ set.seed(1)
+ n <- 1e3
+ x <- runif(n,0,20)
+ age <- runif(n,10,30)
+ z0 <- rnorm(n,mean=-1+0.05*age)
+ z <- cut(z0,breaks=c(-Inf,-1,0,1,Inf))
+ p0 <- lava::expit(model.matrix(~z+age) %*% c(-.4, -.4, 0.2, 2, -0.05))
+ y <- (runif(n)<lava:::tigol(-1+0.25*x-0*age))*1
+ u <- runif(n)<p0
+ y[u==0] <- 0
+ d <- data.frame(y=y,x=x,u=u*1,z=z,age=age)
+
+ ## Estimation
+ e0 <- zibreg(y~x*z,~1+z+age,data=d)
+ e <- zibreg(y~x,~1+z+age,data=d)
+ compare(e,e0)
+ expect_equivalent(score(e,data=d),
+ colSums(score(e,indiv=TRUE)))
+ expect_equivalent(logLik(e,data=d),
+ logLik(e))
+ expect_equivalent(vcov(e), Inverse(information(e,type="obs",data=d)))
+
+ expect_output(print(e), "Prevalence probabilities:")
+
+ PD(e0,intercept=c(1,3),slope=c(2,6))
+
+ B <- rbind(c(1,0,0,0,20),
+ c(1,1,0,0,20),
+ c(1,0,1,0,20),
+ c(1,0,0,1,20))
+ prev <- summary(e,pr.contrast=B)$prevalence
+
+ x <- seq(0,100,length.out=100)
+ newdata <- expand.grid(x=x,age=20,z=levels(d$z))
+ fit <- predict(e,newdata=newdata)
+})
+
+test_that("Optimization", {
+ m <- lvm(y~x+z)
+ d <- simulate(m,20,seed=1)
+ e1 <- estimate(m,d,control=list(method="nlminb0"))
+ e2 <- estimate(m,d,control=list(method="NR"))
+ expect_equivalent(round(coef(e1),3),round(coef(e2),3))
+
+ f <- function(x) x^2*log(x) # x>0
+ df <- function(x) 2*x*log(x) + x
+ df2 <- function(x) 2*log(x) + 3
+ op <- NR(5,f,df,df2,control=list(tol=1e-40)) ## Find root
+ expect_equivalent(round(op$par,digits=7),.6065307)
+ op2 <- estfun0(5,gradient=df)
+ op3 <- estfun(5,gradient=df,hessian=df2,control=list(tol=1e-40))
+ expect_equivalent(op$par,op2$par)
+ expect_equivalent(op$par,op3$par)
+})
+
+
+test_that("Prediction with missing data, random intercept", {
+ ## Random intercept model
+ m <- lvm(c(y1,y2,y3)~u[0])
+ latent(m) <- ~u
+ regression(m) <- y1~x1
+ regression(m) <- y2~x2
+ regression(m) <- y3~x3
+
+ d <- simulate(m,1e3,seed=1)
+ dd <- reshape(d,varying=list(c('y1','y2','y3'),c('x1','x2','x3')),direction='long',v.names=c('y','x'))
+
+ ##system.time(l <- lme4::lmer(y~x+(1|id), data=dd, REML=FALSE))
+ system.time(l <- nlme::lme(y~x,random=~1|id, data=dd, method="ML"))
+ m0 <- lvm(c(y1[m:v],y2[m:v],y3[m:v])~1*u[0])
+ latent(m0) <- ~u
+ regression(m0,y=c('y1','y2','y3'),x=c('x1','x2','x3')) <- rep('b',3)
+ system.time(e <- estimate(m0,d))
+
+ mytol <- 1e-6
+ mse <- function(x,y=0) mean(na.omit(as.matrix(x)-as.matrix(y))^2)
+ expect_true(mse(logLik(e),logLik(l))<mytol)
+ expect_true(mse(nlme::fixef(l),coef(e)[1:2])<mytol)
+ u1 <- nlme::ranef(l)##[[1]][,1]
+ u2 <- predict(e,endogenous(e))
+ expect_true(mse(u1,u2)<1e-9)
+
+ ## Missing data
+ idx <- sample(seq(nrow(dd)),nrow(dd)*0.5)
+ dd0 <- dd[idx,,drop=FALSE]
+ d0 <- mets::fast.reshape(subset(dd0,select=-u),id='id',num='time')
+
+ system.time(e0 <- estimate(m0,d0,missing=TRUE))
+ ##system.time(l0 <- lme4::lmer(y~x+(1|id), data=dd0, REML=FALSE))
+ system.time(l0 <- nlme::lme(y~x,random=~1|id, data=dd0, method="ML"))
+ expect_true(mse(logLik(e0),logLik(l0))<mytol)
+ expect_true(mse(nlme::fixef(l0),coef(e0)[1:2])<mytol)
+ u01 <- nlme::ranef(l0)##[[1]][,1]
+ u02 <- predict(e0,endogenous(e0))
+ expect_true(mse(u01,u02)<1e-9)
+
+ s <- summary(e0)
+ expect_output(print(s),paste0("data=",nrow(d0)))
+ expect_true(inherits(e0$estimate,"multigroupfit"))
+ expect_output(print(e0$estimate),"Group 1")
+ expect_output(print(summary(e0$estimate)),paste0("observations = ",nrow(d0)))
+
+})
+
+
+
+test_that("Random slope model", {
+
+ set.seed(1)
+ m <- lvm()
+ regression(m) <- y1 ~ 1*u+1*s
+ regression(m) <- y2 ~ 1*u+2*s
+ regression(m) <- y3 ~ 1*u+3*s
+ latent(m) <- ~u+s
+ dw <- sim(m,20)
+
+ dd <- mets::fast.reshape(dw)
+ dd$num <- dd$num+runif(nrow(dd),0,0.2)
+ dd0 <- dd[-c(1:2*3),]
+ library(lme4)
+ l <- lmer(y~ 1+num +(1+num|id),dd,REML=FALSE)
+ sl <- lava:::varcomp(l,profile=FALSE)
+
+ d <- mets::fast.reshape(dd,id="id")
+ d0 <- mets::fast.reshape(dd0,id="id")
+
+ m0 <- lvm(c(y1[0:v],y2[0:v],y3[0:v])~1*u)
+ addvar(m0) <- ~num1+num2+num3
+ covariance(m0) <- u~s
+ latent(m0) <- ~s+u
+ regression(m0) <- y1 ~ num1*s
+ regression(m0) <- y2 ~ num2*s
+ regression(m0) <- y3 ~ num3*s
+ system.time(e <- estimate(m0,d,param="none",control=list(trace=0,constrain=FALSE)))
+
+ expect_true(mean(sl$coef-coef(e)[c("u","s")])^2<1e-5)
+ expect_true((logLik(l)-logLik(e))^2<1e-5)
+ varcomp.nam <- c(paste0("u",lava.options()$symbol[2],"u"),
+ paste0("s",lava.options()$symbol[2],"s"))
+ expect_true(mean(diag(sl$varcomp)-coef(e)[varcomp.nam])^2<1e-5)
+
+ ## missing
+ expect_output(e0 <- estimate(m0,d0,missing=TRUE,param="none",control=list(method="NR",constrain=FALSE,start=coef(e),trace=1)),
+ "Iter=")
+ l0 <- lmer(y~ 1+num +(1+num|id),dd0,REML=FALSE)
+ expect_true((logLik(l0)-logLik(e0))^2<1e-5)
+
+ m1 <- lvm(c(y1[0:v],y2[0:v],y3[0:v])~1*u)
+ addvar(m1) <- ~num1+num2+num3
+ covariance(m1) <- u~s
+ latent(m1) <- ~s+u
+ regression(m1) <- y1 ~ b1*s
+ regression(m1) <- y2 ~ b2*s
+ regression(m1) <- y3 ~ b3*s
+ constrain(m1,b1~num1) <- function(x) x
+ constrain(m1,b2~num2) <- function(x) x
+ constrain(m1,b3~num3) <- function(x) x
+ system.time(e1 <- estimate(m1,d,param="none",p=coef(e)))
+ expect_true((logLik(e1)-logLik(e))^2<1e-5)
+
+ ## TODO
+ ## missing
+ ## system.time(e10 <- estimate(m1,d0,missing=TRUE,param="none",
+ ## control=list(trace=coef(e0))))
+
+})
+
+
+test_that("Predictions, jacobians", {
+ m <- lvm(c(x1,x2,x3)~u1,u1~z,
+ c(y1,y2,y3)~u2,u2~u1+z)
+ latent(m) <- ~u1+u2
+
+ p <- c("u2,u2"=2,"u1,u1"=0.5)
+ names(p) <- gsub(",",lava.options()$symbols[2],names(p))
+ d <- simulate(m,50,p=p,seed=123)
+ e <- estimate(m,d)
+
+ object <- e
+ f <- function(p,x=vars(object)) predict(object,x,p=p)
+ expect_true(sum(abs(numDeriv::jacobian(f,coef(object))-predictlvm(object)$mean.jacobian))
+ <1e-6)
+ expect_true(sum(abs(numDeriv::jacobian(function(p) predictlvm(object,p=p)$var,coef(object))-predictlvm(object)$var.jacobian))
+ <1e-6)
+
+ expect_true(sum(abs(numDeriv::jacobian(function(p) f(p,x1~1),coef(object))-
+ predictlvm(object,x1~1)$mean.jacobian))
+ <1e-6)
+
+ expect_true(sum(abs(numDeriv::jacobian(function(p) f(p,u1~x1+x2+x3),coef(object))-
+ predictlvm(object,u1~x1+x2+x3)$mean.jacobian))
+ <1e-6)
+})
+
+
+test_that("multinomial", {
+ set.seed(1)
+ breaks <- c(-Inf,-1,0,Inf)
+ m <- lvm(); covariance(m,pairwise=TRUE) <- ~y1+y2+y3+y4
+ d <- transform(sim(m,5e2),
+ z1=cut(y1,breaks=breaks),
+ z2=cut(y2,breaks=breaks),
+ z3=cut(y3,breaks=breaks),
+ z4=cut(y4,breaks=breaks))
+
+ m <- multinomial(d[,5])
+ lev <- levels(d[,5])
+ e <- estimate(l <- lm(d[,5]==lev[1]~1))
+ expect_true(abs(vcov(e)[1]-vcov(m)[1])<1e-9)
+
+ (a1 <- multinomial(d[,5:6],marginal=TRUE))
+ K1 <- kappa(a1) ## Cohen's kappa
+ P <- a1$P
+ marg1 <- rowSums(P)
+ marg2 <- colSums(P)
+ expect_equivalent(K1$coef,sum(diag(P)-marg1*marg2)/(1-sum(marg1*marg2)))
+
+ K2 <- kappa(d[,7:8])
+ ## Testing difference K1-K2:
+ e1 <- estimate(merge(K1,K2,id=TRUE),diff)
+ e2 <- estimate(merge(K1,K2,id=NULL),diff)
+ expect_true(vcov(e1)!=vcov(e2))
+ expect_equivalent(vcov(e2),(vcov(K1)+vcov(K2)))
+
+ g1 <- gkgamma(d[,5:6])
+ g2 <- gkgamma(table(d[,5:6]))
+ g3 <- gkgamma(multinomial(d[,5:6]))
+ expect_equivalent(g1$coefmat,g2$coefmat)
+ expect_equivalent(g3$coefmat,g2$coefmat)
+
+
+ ## TODO
+ lava:::independence(d[,5:6])
+ information(d[,5:6])
+ ## pcor
+
+ if (requireNamespace("polycor",quietly=TRUE)) {
+ require('mvtnorm')
+ system.time(rho <- pcor(d[,5],d[,6]))
+ rho2 <- polycor::polychor(d[,5],d[,6],ML=TRUE,std.err=TRUE)
+ expect_true(abs(rho$coef[1]-rho2$rho)^2<1e-5)
+ expect_true(abs(rho$vcov[1]-rho2$var[1])^2<1e-5)
+ expect_true(mean(score(rho))^2<1e-5)
+ }
+})
+
+
+test_that("predict,residuals", {
+ m <- lvm(c(y1,y2,y3)~u,u~x)
+ latent(m) <- ~u
+ set.seed(1)
+ d <- sim(m,100,'y1~u'=1,'y3~u'=3)
+ e <- estimate(m,d)
+
+ l <- lm(y3~x,data=d)
+ e3 <- estimate(y3~x,d)
+ expect_true(mean((residuals(l)-residuals(e3))^2)<1e-12)
+ expect_true(mean(var(residuals(e3,std=TRUE))[1]*99/100-1)<1e-3)
+
+ r <- residuals(e)
+ expect_true(ncol(r)==3)
+})
+
+
+test_that("partialcor", {
+ m <- lvm(c(y1,y2,y3)~x1+x2)
+ covariance(m) <- c(y1,y2,y3)~y1+y2+y3
+ set.seed(1)
+ d <- sim(m,500)
+ c1 <- partialcor(~x1+x2,d)
+ e <- estimate(m,d)
+ c2 <- coef(summary(correlation(e)))
+ expect_true(mean(c1[,1]-c2[,1])^2<1e-9)
+ ## CI, note difference var(z)=1/(n-k-3) vs var(z)=1/(n-3)
+ expect_true(mean(c1[,4]-c2[,3])^2<1e-3)
+ expect_true(mean(c1[,5]-c2[,4])^2<1e-3)
+
+})
+
+test_that("partialgamma", {
+
+})
+
+test_that("multipletesting", {
+ ## TODO
+})
+
+
+test_that("Weighted",{
+ m <- lvm(y~x)
+ set.seed(1)
+ d <- sim(m,10)
+ d$w <- runif(nrow(d),0.1,1)
+ e <- estimate(m,data=d)
+ l <- lm(y~x,data=d)
+ expect_true(mean((coef(e)[1:2]-coef(l))^2)<1e-12)
+
+ w <- estimate(m,data=d,weights=d$w,estimator="normal",control=list(trace=1))
+ lw <- lm(y~x,data=d, weights=d$w)
+ expect_true(mean((coef(e)[1:2]-coef(l))^2)<1e-12)
+})
+
+
+test_that("Tobit",{
+ if (versioncheck("lava.tobit",c(0,5))) {
+ m0 <- lvm(t~x)
+ distribution(m0,~w) <- uniform.lvm(0.1,1)
+ d <- sim(m0,10,seed=1)
+ d$status <- rep(c(TRUE,FALSE),each=nrow(d)/2)
+ d$s <- with(d, Surv(t,status))
+ s <- survreg(s~x,data=d,dist="gaussian",weights=d$w)
+ m <- lvm(s~x)
+ e <- estimate(m,data=d,estimator="normal",weights="w")
+ expect_true(mean((coef(e)[1:2]-coef(s))^2)<1e-9)
+ }
+})
diff --git a/tests/testthat/test-misc.R b/tests/testthat/test-misc.R
new file mode 100644
index 0000000..e1bf149
--- /dev/null
+++ b/tests/testthat/test-misc.R
@@ -0,0 +1,125 @@
+context("Utility functions")
+
+test_that("By", {
+ b1 <- By(datasets::CO2,~Treatment+Type,colMeans,~conc)
+ b2 <- By(datasets::CO2,c('Treatment','Type'),colMeans,'conc')
+ expect_equivalent(b1,b2)
+ ## require('data.table')
+ ## t1 <- as.data.frame(data.table(datasets::CO2)[,mean(uptake),by=.(Treatment,Type,conc>500)])
+ d0 <- transform(datasets::CO2,conc500=conc>500)
+ t1 <- by(d0[,"uptake"],d0[,c("Treatment","Type","conc500")],mean)
+ t2 <- By(datasets::CO2,~Treatment+Type+I(conc>500),colMeans,~uptake)
+ expect_true(inherits(t2,"array"))
+ expect_equivalent(sort(t2),sort(t1))
+})
+
+
+test_that("Expand", {
+ dd <- Expand(iris, Sepal.Length=2:8, Species=c("virginica","setosa"))
+ expect_identical(levels(iris$Species),levels(dd$Species))
+ expect_true(nrow(dd)==14)
+
+ d0 <- datasets::warpbreaks[,c("wool","tension")]
+ T <- table(d0)
+ d1 <- Expand(T)
+ expect_identical(dim(d0),dim(d1))
+ expect_identical(table(d1),T)
+
+ expect_identical(expand.grid(1:2,1:2),Expand(1:2,1:2))
+ expect_identical(expand.grid(a=1:2,b=1:2),Expand(a=1:2,b=1:2))
+})
+
+
+test_that("formulas", {
+ f <- toformula(c('y1','y2'),'x'%++%1:5)
+ ff <- getoutcome(f)
+ expect_equivalent(trim(ff,all=TRUE),"c(y1,y2)")
+ expect_true(length(attr(ff,'x'))==5)
+})
+
+test_that("trim", {
+ expect_true(length(grep(" ",trim(" test ")))==0)
+ expect_true(length(gregexpr(" ",trim(" t e s t "))[[1]])==3)
+ expect_true(length(grep(" ",trim(" t e s t ",all=TRUE)))==0)
+})
+
+
+test_that("Matrix operations:", {
+ ## vec operator
+ expect_equivalent(vec(diag(3)),c(1,0,0,0,1,0,0,0,1))
+ expect_true(nrow(vec(diag(3),matrix=TRUE))==9)
+
+ ## commutaion matrix
+ A <- matrix(1:16 ,ncol=4)
+ K <- commutation(A)
+ expect_equivalent(K%*%as.vector(A),vec(t(A),matrix=TRUE))
+
+ ## Block diagonal
+ A <- diag(3)+1
+ B <- blockdiag(A,A,A,pad=NA)
+ expect_equivalent(dim(B),c(9,9))
+ expect_true(sum(is.na(B))==81-27)
+})
+
+
+test_that("plotConf", {
+ m <- lvm(y~x+g)
+ distribution(m,~g) <- binomial.lvm()
+ d <- sim(m,50)
+ l <- lm(y~x+g,d)
+ g1 <- plotConf(l,var2="g",plot=FALSE)
+ g2 <- plotConf(l,var1=NULL,var2="g",plot=FALSE)
+})
+
+
+test_that("wrapvev", {
+ expect_equivalent(wrapvec(5,2),c(3,4,5,1,2))
+ expect_equivalent(wrapvec(seq(1:5),-1),c(5,1,2,3,4))
+})
+
+
+test_that("matrix functions", {
+ A <- revdiag(1:3)
+ expect_equivalent(A,matrix(c(0,0,1,0,2,0,3,0,0),3))
+ expect_equivalent(1:3,revdiag(A))
+ revdiag(A) <- 4
+ expect_equivalent(rep(4,3),revdiag(A))
+ diag(A) <- 0
+ offdiag(A) <- 5
+ expect_true(sum(offdiag(A))==6*5)
+
+
+ A <- matrix(0,3,3)
+ offdiag(A,type=3) <- 1:6
+ B <- crossprod(A)
+
+ expect_equivalent(solve(A),Inverse(A))
+ expect_equivalent(det(B),attr(Inverse(B,chol=TRUE),"det"))
+})
+
+
+test_that("getmplus", {
+})
+test_that("getsas", {
+})
+
+
+
+test_that("All the rest", {
+ expect_false(lava:::versioncheck(NULL))
+ expect_true(lava:::versioncheck("lava",c(1,4,1)))
+
+ op <- lava.options(debug=TRUE)
+ expect_true(lava.options()$debug)
+ lava.options(op)
+
+ A <- diag(2); colnames(A) <- c("a","b")
+ expect_output(printmany(A,A,2,rownames=c("A","B"),bothrows=FALSE),"a b")
+ expect_output(printmany(A,A[1,,drop=FALSE],2,rownames=c("A","B"),bothrows=FALSE),"a b")
+ expect_output(printmany(A,A,2,rownames=c("A","B"),name1="no.1",name2="no.2",
+ bothrows=TRUE),"no.1")
+
+ ##printmany(A,A,2,name1="no.1",name2="no.2",bothrows=T)
+})
+
+
diff --git a/tests/testthat/test-model.R b/tests/testthat/test-model.R
new file mode 100644
index 0000000..f4ed3a2
--- /dev/null
+++ b/tests/testthat/test-model.R
@@ -0,0 +1,123 @@
+context("Model specification")
+
+test_that("Basic model building blocks", {
+ m <- lvm(y[m]~x)
+ covariance(m) <- y~z
+ expect_true(covariance(m)$rel["z","y"]==1)
+ expect_true(regression(m)$rel["x","y"]==1)
+
+ ## Children parent,nodes
+ expect_match(children(m,~x),"y")
+ expect_match(parents(m,~y),"x")
+ expect_equivalent(parents(m),vars(m))
+ expect_equivalent(children(m),vars(m))
+
+ ## Remove association
+ cancel(m) <- y~z+x
+ expect_true(covariance(m)$rel["z","y"]==0)
+ expect_true(regression(m)$rel["x","y"]==0)
+
+ ## Remove variable
+ kill(m) <- ~x
+ expect_equivalent(vars(m),c("y","z"))
+ expect_true(intercept(m)["y"]=="m")
+
+ m <- lvm(c(y1,y2,y3)~x)
+ d <- sim(m,50)
+ e <- estimate(m,d)
+ ## Equivalence
+ ##equivalence(e,silent=TRUE)
+
+
+ ## formula
+ f <- formula(m,all=TRUE)
+ expect_true(length(f)==length(vars(m)))
+ expect_true(all(unlist(lapply(f,function(x) inherits(x,"formula")))))
+
+ ## Parametrization
+ m <- lvm(c(y1,y2,y3)~u)
+ latent(m) <- ~u
+ m2 <- fixsome(m,param=NULL)
+ expect_true(all(is.na(regression(m2)$values)))
+ m2 <- fixsome(m,param="relative")
+ expect_true(regression(m2)$values["u","y1"]==1)
+ expect_true(intercept(m2)[["y1"]]==0)
+ m2 <- fixsome(m,param="hybrid")
+ expect_true(regression(m2)$values["u","y1"]==1)
+ expect_true(intercept(m2)[["u"]]==0)
+ m2 <- fixsome(m,param="absolute")
+ expect_true(all(is.na(regression(m2)$values)))
+ expect_true(intercept(m2)[["u"]]==0)
+ expect_true(covariance(m2)$values["u","u"]==1)
+
+ ## Merge
+ m1 <- lvm(c(y1,y2,y3)~1*u1[m1:v1])
+ latent(m1) <- ~u1
+ m2 <- lvm(c(y1,y2,y3)~2*u2[m2:v2])
+ latent(m2) <- ~u2
+ mm <- m1%++%m2
+
+ expect_true(covariance(mm)$labels["u1","u1"]=="v1")
+ expect_true(intercept(mm)[["u2"]]=="m2")
+
+ ## LISREL
+ mm <- fixsome(mm)
+ L <- lisrel(mm,rep(1,length(coef(mm))))
+ expect_equivalent(L$B,matrix(0,2,2))
+ expect_equivalent(L$Theta,diag(3))
+ expect_equivalent(L$Psi,diag(2))
+
+})
+
+
+test_that("Linear constraints", {
+ m <- lvm(c(y[m:v]~b*x))
+ constrain(m,b~a) <- base::identity
+})
+
+
+test_that("Graph attributes", {
+ require("graph")
+ m <- lvm(y~x)
+ g1 <- graph::updateGraph(plot(m,noplot=TRUE))
+ m1 <- graph2lvm(g1)
+ expect_equivalent(m1$M,m$M)
+
+ col <- "blue"; v <- "y"
+ g1 <- lava::addattr(g1,"fill",v,col)
+ expect_match(col,graph::nodeRenderInfo(g1)$fill[v])
+ nodecolor(m,v) <- "blue"
+ g2 <- Graph(m,add=TRUE)
+ expect_true(inherits(g2,"graph"))
+ expect_match(col,graph::nodeRenderInfo(g2)$fill[v])
+ expect_match(addattr(g2,"fill")["y"],"blue")
+ graph::graphRenderInfo(g2)$rankdir <- "LR"
+ Graph(m) <- g2
+ expect_true(graph::graphRenderInfo(Graph(m))$rankdir=="LR")
+
+ ## Labels
+ labels(m) <- c(y="Y")
+ addattr(Graph(m,add=TRUE),"label")
+ expect_true(addattr(finalize(m),"label")[["y"]]=="Y")
+ labels(g2) <- c(y="Y")
+ expect_true(!is.null(graph::nodeRenderInfo(g2)$label["y"]))
+
+ edgelabels(m,y~x) <- "a"
+ expect_true(!is.null(edgelabels(finalize(m))))
+})
+
+
+test_that("Categorical variables", {
+ m <- lvm()
+ categorical(m,K=3,p=c(0.1,0.5)) <- ~x
+ d1 <- simulate(m,10,seed=1)
+ categorical(m,K=3) <- ~x
+ d2 <- simulate(m,10,seed=1)
+ expect_false(identical(d1,d2))
+
+ regression(m,additive=FALSE,y~x) <- c(0,-5,5)
+ d <- simulate(m,100,seed=1)
+ l <- lm(y~factor(x),d)
+ expect_true(sign(coef(l))[2]==-sign(coef(l))[3])
+
+})
diff --git a/tests/testthat/test-multigroup.R b/tests/testthat/test-multigroup.R
new file mode 100644
index 0000000..aa779a7
--- /dev/null
+++ b/tests/testthat/test-multigroup.R
@@ -0,0 +1,95 @@
+context("Multiple Group")
+
+test_that("Multiple group I", {
+ m <- lvm(y~x)
+ set.seed(1)
+ d <- sim(m,100)
+ ## Just a stratified analysis
+ e <- estimate(list("Group A"=m,"Group B"=m),list(d,d))
+ expect_true(mean((coef(e)[c(1,3)]-coef(lm(y~x,d)))^2)<1e-9)
+ expect_true(mean((coef(e)[c(2,5)]-coef(lm(y~x,d)))^2)<1e-9)
+})
+
+test_that("Multiple group II", {
+ m <- baptize(lvm(y~x))
+ set.seed(1)
+ d <- sim(m,100)
+ ## Just a standard linear regression (single group)
+ e <- estimate(list(m,m),list(d,d))
+ expect_identical(coef(e,level=2)[[1]],coef(e,level=2)[[2]])
+ expect_true(mean((coef(e,level=2)[[1]][1:2,1]-coef(lm(y~x,cbind(d,d))))^2)<1e-9)
+})
+
+context("Missing data")
+
+test_that("Missing data analysis", {
+ ## Random intercept model
+ m <- lvm(c(y1,y2,y3)~x+u); latent(m) <- ~u
+ set.seed(1)
+ ## Missing on first two outcomes
+ d <- makemissing(sim(m,200),p=0.3,cols=c("y1","y2"))
+ e <- estimate(m,d,missing=TRUE)
+ expect_true("lvm.missing"%in%class(e))
+ expect_true(sum(unlist(lapply(e$estimate$model$data,nrow)))==200)
+ ## Convergence:
+ g <- gof(e)
+ expect_true(mean(score(e))<1e-3)
+ expect_true(g$rankV==length(pars(e)))
+})
+
+test_that("Multiple group, missing data analysis", {
+ m <- lvm(list(c(y1,y2,y3)~u,u~x)); latent(m) <- ~u
+ m <- baptize(fixsome(m))
+ regression(m,u~x) <- NA
+ covariance(m,~u) <- NA
+ set.seed(1)
+ ## Missing on all outcomes
+ d1 <- makemissing(sim(m,500),cols=c("y1","y2"),p=0.3)
+ d2 <- makemissing(sim(m,500),cols=c("y1","y2"),p=0.3)
+ e <- estimate(list(m,m),list(d1,d2),missing=TRUE)
+ g <- gof(e)
+ expect_true(g$n==1000)
+ expect_true(mean(score(e))<1e-3)
+ expect_true(g$rankV==length(pars(e)))
+})
+
+
+test_that("Multiple group, constraints", {
+ m1 <- lvm(y ~ f(x,beta)+f(z,beta2))
+ m2 <- lvm(y ~ f(x,psi) + z)
+ ## And simulate data from them
+ set.seed(1)
+ d1 <- sim(m1,100)
+ d2 <- sim(m2,100)
+ ## Add 'non'-linear parameter constraint
+ constrain(m2,psi ~ beta2) <- function(x) x
+ ## Add parameter beta2 to model 2, now beta2 exists in both models
+ parameter(m2) <- ~ beta2
+ ee <- estimate(list(m1,m2),list(d1,d2))
+
+ m <- lvm(y1 ~ x1 + beta2*z1)
+ regression(m) <- y2 ~ beta2*x2 + z2
+ d <- cbind(d1,d2); names(d) <- c(paste0(names(d1),1),paste0(names(d1),2))
+ e <- estimate(m,d)
+
+ b1 <- coef(e,2,labels=TRUE)["beta2",1]
+ b2 <- constraints(ee)[1]
+ expect_true(mean((b1-b2)^2)<1e-5)
+
+ ## "Multiple group, constraints (non-linear in x)
+ m <- lvm(y[m:v] ~ 1)
+ addvar(m) <- ~x
+ parameter(m) <- ~a+b
+ constrain(m,m~a+b+x) <- function(z) z[1]+z[2]*z[3]
+ ee <- estimate(list(m,m),list(d1[1:5,],d1[6:10,]))
+ b1 <- coef(lm(y~x,d1[1:10,]))
+ b2 <- coef(ee)[c("1 at a","1 at b")]
+ expect_true(mean(b1-b2)^2<1e-4)
+
+})
+
+
+
+
+
+
diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R
new file mode 100644
index 0000000..e5b461d
--- /dev/null
+++ b/tests/testthat/test-plot.R
@@ -0,0 +1,192 @@
+context("Graphics functions")
+
+test_that("attr", {
+ m <- lvm(y~x)
+ d <- sim(m,10)
+ e <- estimate(m,d)
+
+
+
+})
+
+
+test_that("color", {
+ cur <- palette()
+ old <- lava:::mypal()
+ expect_equivalent(col2rgb(cur),col2rgb(old))
+ expect_equivalent(col2rgb(palette()),col2rgb(lava:::mypal(set=FALSE)))
+
+ expect_equivalent(Col("red",0.5),rgb(1,0,0,0.5))
+ expect_equivalent(Col(c("red","blue"),0.5),rgb(c(1,0),c(0,0),c(0,1),0.5))
+ expect_equivalent(Col(c("red","blue"),c(0.2,0.5)),rgb(c(1,0),c(0,0),c(0,1),c(0.2,0.5)))
+ expect_equivalent(Col(rgb(1,0,0),0.5),rgb(1,0,0,0.5))
+
+ plot(0,xlim=c(0,1),ylim=c(0,1),type="n",ann=FALSE,axes=FALSE)
+ devc1 <- devcoords()
+ par(mar=c(0,0,0,0))
+ plot(0,xlim=c(0,1),ylim=c(0,1),type="n",ann=FALSE,axes=FALSE)
+ devc2 <- devcoords()
+ figx <- c("fig.x1","fig.x2","fig.y1","fig.y2")
+ devx <- c("dev.x1","dev.x2","dev.y1","dev.y2")
+ expect_equivalent(devc1[figx],devc2[devx])
+
+})
+
+if (requireNamespace("visualTest",quietly=TRUE) && requireNamespace("png",quietly=TRUE)) {
+
+ gropen <- function(resolution=200,...) {
+ tmpfile <- tempfile(fileext=".png")
+ png(file=tmpfile,width=200,height=200)
+ res <- dev.cur()
+ return(structure(tmpfile,dev=res))
+ }
+ grcompare <- function(file1,file2,...) {
+ res <- visualTest::isSimilar(file1,file2,...)
+ unlink(c(file1,file2))
+ return(res)
+ }
+
+
+ test_that("plotConf", {
+ set.seed(1)
+ x <- rnorm(50)
+ y <- rnorm(50,x)
+ z <- rbinom(50,1,0.5)
+ d <- data.frame(y,z,x)
+ l <- lm(y~x*z)
+
+ d1 <- gropen()
+ par(mar=c(0,0,0,0))
+ plotConf(l,var1="x",var2="z",col=c("black","blue"),alpha=0.5,legend=FALSE)
+ dev.off()
+
+ newd <- data.frame(x=seq(min(x),max(x),length.out=100))
+ l0 <- lm(y~x,subset(d,z==0))
+ ci0 <- predict(l0,newdata=newd,interval="confidence")
+ l1 <- lm(y~x,subset(d,z==1))
+ ci1 <- predict(l1,newdata=newd,interval="confidence")
+
+ d2 <- gropen()
+ par(mar=c(0,0,0,0))
+ plot(y~x,col=c("black","blue")[z+1],pch=16,ylim=c(min(ci0,ci1,y),max(ci0,ci1,y)))
+ lines(newd$x,ci0[,1],col="black",lwd=2)
+ lines(newd$x,ci1[,1],col="blue",lwd=2)
+ confband(newd$x,lower=ci0[,2],upper=ci0[,3],polygon=TRUE,col=Col("black",0.5),border=FALSE)
+ confband(newd$x,lower=ci1[,2],upper=ci1[,3],polygon=TRUE,col=Col("blue",0.5),border=FALSE)
+ points(y~x,col=c("black","blue")[z+1],pch=16)
+ dev.off()
+
+ expect_true(grcompare(d1,d2,threshold=5))
+
+
+ d1 <- gropen()
+ par(mar=c(0,0,0,0))
+ l <- lm(y~z)
+ plotConf(l,var2="z",var1=NULL,jitter=0,col="black",alpha=0.5,xlim=c(.5,2.5),ylim=range(y))
+ dev.off()
+
+ d2 <- gropen()
+ par(mar=c(0,0,0,0))
+ plot(y~I(z+1),ylim=range(y),xlim=c(0.5,2.5),pch=16,col=Col("black",0.5))
+ l0 <- lm(y~-1+factor(z))
+ confband(1:2,lower=confint(l0)[,1],upper=confint(l0)[,2],lwd=3,
+ center=coef(l0))
+ dev.off()
+
+ expect_true(grcompare(d1,d2,threshold=10))
+
+ })
+
+
+ test_that("forestplot", {
+ set.seed(1)
+ K <- 20
+ est <- rnorm(K); est[c(3:4,10:12)] <- NA
+ se <- runif(K,0.2,0.4)
+ x <- cbind(est,est-2*se,est+2*se,runif(K,0.5,2))
+ rownames(x) <- unlist(lapply(letters[seq(K)],function(x) paste(rep(x,4),collapse="")))
+ rownames(x)[which(is.na(est))] <- ""
+ signif <- sign(x[,2])==sign(x[,3])
+ forestplot(x)
+ ## TODO
+ })
+
+ test_that("plot.sim", {
+ onerun2 <- function(a,b,...) {
+ return(cbind(a=a,b=b,c=a-1,d=a+1))
+ }
+ R <- data.frame(a=1:2,b=3:4)
+ val2 <- sim(onerun2,R=R,type=0)
+ plot(val2)
+ plot(val2,plot.type="single")
+ density(val2)
+ ## TODO
+ })
+
+ test_that("spaghetti", {
+ K <- 5
+ y <- "y"%++%seq(K)
+ m <- lvm()
+ regression(m,y=y,x=~u) <- 1
+ regression(m,y=y,x=~s) <- seq(K)-1
+ regression(m,y=y,x=~x) <- "b"
+ d <- sim(m,5)
+ dd <- mets::fast.reshape(d);
+ dd$num <- dd$num+rnorm(nrow(dd),sd=0.5) ## Unbalance
+ spaghetti(y~num,dd,id="id",lty=1,col=Col(1,.4),trend=TRUE,trend.col="darkblue")
+ ## TODO
+ })
+
+ test_that("ksmooth", {
+ ## TODO
+ })
+
+ test_that("plot.lvm", {
+ ## TODO
+ m <- lvm(y~1*u[0:1],u~1*x)
+ latent(m) <- ~u
+ plot(m)
+ d <- sim(m,20,seed=1)
+ e <- estimate(m,d)
+ plot(e)
+ plot(lava:::beautify(m))
+ g <- igraph.lvm(m)
+ expect_true(inherits(g,"igraph"))
+ })
+
+ test_that("images", {
+ ## TODO
+ })
+
+ test_that("labels,edgelabels", {
+ ## TODO
+ })
+
+ test_that("colorbar", {
+ ## TODO
+ })
+
+ test_that("fplot", {
+ ## TODO
+ })
+
+ test_that("interactive", {
+ ## TODO
+ })
+
+ test_that("pdfconvert", {
+ ## TODO
+ })
+
+ test_that("plot.estimate", {
+ ## TODO
+ })
+
+ test_that("logo", {
+ lava(seed=1)
+ })
+
+
+
+
+}
diff --git a/tests/testthat/test-sim.R b/tests/testthat/test-sim.R
new file mode 100644
index 0000000..7f8552b
--- /dev/null
+++ b/tests/testthat/test-sim.R
@@ -0,0 +1,183 @@
+context("Simulation")
+
+test_that("Constrain, transform I", {
+ m <- lvm(,~y+x)
+ distribution(m,~x) <- sequence.lvm()
+ transform(m,y~x) <- function(x) x
+ with(sim(m,10),expect_equivalent(y,x))
+
+ m <- lvm(y~1,~x)
+ distribution(m,~x) <- sequence.lvm()
+ intercept(m,~y) <- "ym"
+ covariance(m,~y) <- 0.001
+ constrain(m,ym~x) <- function(x) x
+ d <- simulate(m,200)
+ expect_true(mean((d$y-d$x)^2)<0.1)
+
+
+})
+
+
+test_that("Missing", {
+ m <- lvm(y~1)
+ m <- Missing(m,y~1,r~x)
+ set.seed(1)
+ d <- simulate(m,1e3,seed=1)
+ expect_equal(sum(d$r),sum(!is.na(d$y0)))
+
+ g <- glm(r~x,data=d,family=binomial)
+ expect_true(all.equal(coef(g),c(0,1),tolerance=0.2,check.attributes=FALSE))
+})
+
+
+test_that("sim.default I", {
+ m <- lvm(y~x+e)
+ distribution(m,~y) <- 0
+ distribution(m,~x) <- uniform.lvm(a=-1.1,b=1.1)
+ transform(m,e~x) <- function(x) (1*x^4)*rnorm(length(x),sd=1)
+
+ onerun <- function(iter=NULL,...,n=2e3,b0=1,idx=2) {
+ d <- sim(m,n,p=c("y~x"=b0))
+ l <- lm(y~x,d)
+ res <- c(coef(summary(l))[idx,1:2],
+ confint(l)[idx,],
+ estimate(l,only.coef=TRUE)[idx,2:4])
+ names(res) <- c("Estimate","Model.se","Model.lo","Model.hi",
+ "Sandwich.se","Sandwich.lo","Sandwich.hi")
+ res
+ }
+
+ val <- sim(onerun,R=2,b0=1,n=10,messages=0,mc.cores=1)
+ expect_true(nrow(val)==2)
+ val <- sim(val,R=2,b0=1,n=10,type=0) ## append results
+ expect_true(nrow(val)==4)
+
+ s1 <- summary(val,estimate=c(1,1),confint=c(3,4,6,7),true=c(1,1),names=c("Model","Sandwich"))
+ expect_true(length(grep("Coverage",rownames(s1)))>0)
+ expect_equivalent(colnames(s1),c("Model","Sandwich"))
+
+ val <- sim(onerun,R=2,cl=TRUE,seed=1,messages=0,mc.cores=2)
+ expect_true(val[1,1]!=val[1,2])
+
+ onerun2 <- function(a,b,...) {
+ return(cbind(a=a,b=b,c=a-1,d=a+1))
+ }
+ R <- data.frame(a=1:2,b=3:4)
+ dm <- capture.output(val2 <- sim(onerun2,R=R,messages=1,mc.cores=2))
+ expect_true(all(R-val2[,1:2]==0))
+ res <- summary(val2)
+ expect_equivalent(res["Mean",],c(1.5,3.5,0.5,2.5))
+
+ expect_output(print(val2[1,]),"a b c d")
+ expect_output(print(val2[1,]),"1 3 0 2")
+
+ res <- summary(val2,estimate="a",se="b",true=1.5,confint=c("c","d"))
+ expect_true(res["Coverage",]==1)
+ expect_true(res["SE/SD",]==mean(val2[,"b"])/sd(val2[,"a"]))
+
+})
+
+
+test_that("distributions", {
+ m <- lvm(y1~x)
+ distribution(m,~y1) <- binomial.lvm("probit")
+ distribution(m,~y2) <- poisson.lvm()
+ distribution(m,~y3) <- normal.lvm(mean=1,sd=2)
+ distribution(m,~y3) <- lognormal.lvm()
+ distribution(m,~y3) <- pareto.lvm()
+ distribution(m,~y3) <- loggamma.lvm()
+ distribution(m,~y3) <- weibull.lvm()
+ distribution(m,~y3) <- chisq.lvm()
+ distribution(m,~y3) <- student.lvm(mu=1,sigma=1)
+
+ expect_output(print(distribution(m)$y2),"Family: poisson")
+ expect_output(print(distribution(m)$y1),"Family: binomial")
+ latent(m) <- ~u
+ expect_output(print(m),"binomial\\(probit\\)")
+ expect_output(print(m),"poisson\\(log\\)")
+
+ ## Generator:
+ m <- lvm()
+ distribution(m,~y,TRUE) <- function(n,...) {
+ res <- exp(rnorm(n)); res[seq(min(n,5))] <- 0
+ return(res)
+ }
+ d <- sim(m,10)
+ expect_true(all(d[1:5,1]==0))
+ expect_true(all(d[6:10,1]!=0))
+
+ m <- lvm()
+ distribution(m,~y,parname="a",init=2) <- function(n,a,...) {
+ rep(1,n)*a
+ }
+ expect_true(all(sim(m,2)==2))
+ expect_true(all(sim(m,2,p=c(a=10))==10))
+ expect_equivalent(sim(m,2,p=c(a=10)),sim(m,2,a=10))
+
+ ## Multivariate distribution
+ m <- lvm()
+ rmr <- function(n,rho,...) rmvn(n,sigma=diag(2)*(1-rho)+rho)
+ distribution(m,~y1+y2,rho=0.9) <- rmr
+ expect_equivalent(c("y1","y2"),colnames(d <- sim(m,5)))
+
+ ## Special 'distributions'
+ m <- lvm()
+ distribution(m,~x1) <- sequence.lvm(int=TRUE)
+ distribution(m,~x2) <- sequence.lvm(a=1,b=2)
+ distribution(m,~x3) <- sequence.lvm(a=NULL,b=2)
+ distribution(m,~x4) <- sequence.lvm(a=2,b=NULL)
+ ex <- sim(m,5)
+ expect_equivalent(ex$x1,1:5)
+ expect_equivalent(ex$x2,seq(1,2,length.out=5))
+ expect_equivalent(ex$x3,seq(-2,2))
+ expect_equivalent(ex$x4,seq(2,6))
+
+ m <- lvm()
+ distribution(m,~x1) <- ones.lvm()
+ distribution(m,~x2) <- ones.lvm(p=0.5)
+ distribution(m,~x3) <- ones.lvm(interval=c(0.4,0.6))
+ ex <- sim(m,10)
+ expect_equivalent(ex$x1,rep(1,10))
+ expect_equivalent(ex$x2,c(rep(0,5),rep(1,5)))
+ expect_equivalent(ex$x3,c(0,0,0,1,1,1,0,0,0,0))
+
+ m <- lvm()
+ expect_error(distribution(m,~y) <- threshold.lvm(p=c(0.5,.75)))
+ distribution(m,~y) <- threshold.lvm(p=c(0.25,.25))
+ set.seed(1)
+ expect_equivalent(1:3,sort(unique(sim(m,200))[,1]))
+
+ ## distribution(m,~y) <- threshold.lvm(p=c(0.25,.25),labels=letters[1:3])
+ ## expect_equivalent(c("a","b","c"),sort(unique(sim(m,200))[,1]))
+
+})
+
+
+test_that("eventTime", {
+ m <- lvm(eventtime~x)
+ distribution(m,~eventtime) <- coxExponential.lvm(1/100)
+ distribution(m,~censtime) <- coxWeibull.lvm(1/500)
+ eventTime(m) <- time~min(eventtime=1,censtime=0)
+
+ set.seed(1)
+ d <- sim(m,100)
+ expect_equivalent((d$time<d$cens)*1L,d$status)
+
+ ## TODO
+ plot(m)
+ expect_output(print(m),"Event History Model")
+
+ ## Time varying effect
+ m <- lvm(y~1)
+ distribution(m,~z1) <- ones.lvm(0.5)
+ R <- log(cbind(c(0.2,0.7,0.9),c(0.5,0.3,0.3)))
+ m <- timedep(m,y~z1,timecut=c(0,3,5),rate=R)
+
+ ## sim(m,100)
+ ## d <- sim(m,1e4); d$status <- TRUE
+ ## dd <- mets::lifetable(survival::Surv(y,status)~z1,data=d,breaks=c(0,3,5,Inf));
+ ## exp(coef(glm(events ~ offset(log(atrisk)) + -1 + interval+z1:interval, dd, family=poisson)))
+
+})
+
+
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/r-cran-lava.git
More information about the debian-science-commits
mailing list