#+STARTUP: showall
#+OPTIONS: ^:{}
#+OPTIONS: title:nil author:nil
#+PROPERTY: header-args :exports both :eval yes :results output :tangle yes
#+PROPERTY: header-args:R :session *R*
#+PROPERTY: header-args:R+ :colnames yes :rownames no :hlines yes
# +OPTIONS: timestamp:t title:t date:t author:t creator:nil toc:nil
# +OPTIONS: h:4 num:t tags:nil d:t toc:t

#+BEGIN_EXPORT yaml
title: Non-linear latent variable models and error-in-variable models
author: Klaus Kähler Holst
date: "`r Sys.Date()`"
output:
  knitr:::html_vignette:
    fig_caption: yes
vignette: >
  %\VignetteIndexEntry{Non-linear latent variable models and error-in-variable models}
  %\VignetteEngine{knitr::rmarkdown}
  %\VignetteEncoding{UTF-8}
#+END_EXPORT


#+BEGIN_EXPORT markdown
<!-- nonlinear.Rmd is generated from nonlinear.org. Please edit that file -->
#+END_EXPORT

#+BEGIN_SRC R :ravel include=FALSE
  knitr::opts_chunk$set(
    collapse = TRUE,
    comment = "#>"
  )
  mets <- lava:::versioncheck('mets', 1)
  fullVignette <- Sys.getenv("_R_FULL_VIGNETTE_") %in% c("1","TRUE")
#+END_SRC

#+RESULTS:


#+NAME: load
#+BEGIN_SRC R :exports code :ravel results="hide",message=FALSE,warning=FALSE
library('lava')
#+END_SRC

#+RESULTS: load

We consider the measurement models given by

\[X_{j} = \eta_{1} + \epsilon_{j}^{x}, \quad j=1,2,3\]
\[Y_{j} = \eta_{2} + \epsilon_{j}^{y}, \quad j=1,2,3\]
and with a structural model given by
\[\eta_{2} = f(\eta_{1}) + Z + \zeta_{2}\label{ex:eta2}\]
\[\eta_{1} = Z + \zeta_{1}\label{ex:eta1}\]
with iid measurement errors
\(\epsilon_{j}^{x},\epsilon_{j}^{y},\zeta_{1},\zeta_{2}\sim\mathcal{N}(0,1),
j=1,2,3.\) and standard normal distributed covariate \(Z\).  To
simulate from this model we use the following syntax:

#+NAME: sim
#+BEGIN_SRC R :exports code
  f <- function(x) cos(1.25*x) + x - 0.25*x^2
  m <- lvm(x1+x2+x3 ~ eta1, y1+y2+y3 ~ eta2, latent=~eta1+eta2)
  regression(m) <- eta1+eta2 ~ z
  functional(m, eta2~eta1) <- f

  d <- sim(m, n=200, seed=42) # Default is all parameters are 1
#+END_SRC

#+RESULTS: sim

#+BEGIN_SRC R
plot(m)
#+END_SRC

#+RESULTS:


We refer to cite:holstjoergensen_lava for details on the syntax for
model specification.

** Estimation

To estimate the parameters using the two-stage estimator described in cite:lava_nlin,  the first step is now to specify the measurement models
#+NAME: specifymodels
#+BEGIN_SRC R :exports code
m1 <- lvm(x1+x2+x3 ~ eta1, eta1 ~ z, latent=~eta1)
m2 <- lvm(y1+y2+y3 ~ eta2, eta2 ~ z, latent=~eta2)
#+END_SRC

#+RESULTS: specifymodels

Next, we specify a quadratic relationship between the two latent variables
#+BEGIN_SRC R :exports code
nonlinear(m2, type="quadratic") <- eta2 ~ eta1
#+END_SRC

#+RESULTS:

and the model can then be estimated using the two-stage estimator
#+NAME: twostage1
#+BEGIN_SRC R :exports both
e1 <- twostage(m1, m2, data=d)
e1
#+END_SRC

#+RESULTS: twostage1
#+begin_example
                    Estimate Std. Error  Z-value   P-value
Measurements:
   y2~eta2           0.97686    0.03451 28.30865    <1e-12
   y3~eta2           1.04485    0.03485 29.98153    <1e-12
Regressions:
   eta2~z            0.88513    0.20778  4.25997 2.045e-05
   eta2~eta1_1       1.14072    0.17410  6.55194 5.679e-11
   eta2~eta1_2      -0.45055    0.07161 -6.29199 3.134e-10
Intercepts:
   y2               -0.12198    0.10915 -1.11749    0.2638
   y3               -0.09879    0.10545 -0.93680    0.3489
   eta2              0.67814    0.17363  3.90567 9.397e-05
Residual Variances:
   y1                1.30730    0.17743  7.36790
   y2                1.11056    0.14478  7.67064
   y3                0.80961    0.13203  6.13219
   eta2              2.08483    0.28985  7.19274
#+end_example

We see a clear statistically significant effect of the second order
term (=eta2~eta1_2=). For comparison we can also estimate the full MLE
of the linear model:
#+NAME: linear_mle
#+BEGIN_SRC R :exports both
e0 <- estimate(regression(m1%++%m2, eta2~eta1), d)
estimate(e0,keep="^eta2~[a-z]",regex=TRUE) ## Extract coef. matching reg.ex.
#+END_SRC

#+RESULTS: linear_mle
:           Estimate Std.Err    2.5% 97.5%   P-value
: eta2~eta1   1.4140  0.2261 0.97083 1.857 4.014e-10
: eta2~z      0.6374  0.2778 0.09291 1.182 2.177e-02

Next, we calculate predictions from the quadratic model using the estimated parameter coefficients
\[
\mathbb{E}_{\widehat{\theta}_{2}}(\eta_{2} \mid \eta_{1}, Z=0),
\]
#+NAME: pred1
#+ATTR_LaTeX: :options morekeywords={Col,head},deletekeywords={data,by,col},otherkeywords={<-,\$}
#+BEGIN_SRC R :exports both :results output
  newd <- expand.grid(eta1=seq(-4, 4, by=0.1), z=0)
  pred1 <- predict(e1, newdata=newd, x=TRUE)
  head(pred1)
#+END_SRC

#+RESULTS: pred1
:              y1         y2         y3       eta2
: [1,] -11.093569 -10.958869 -11.689950 -11.093569
: [2,] -10.623561 -10.499736 -11.198861 -10.623561
: [3,] -10.162565 -10.049406 -10.717187 -10.162565
: [4,]  -9.710579  -9.607878 -10.244928  -9.710579
: [5,]  -9.267605  -9.175153  -9.782084  -9.267605
: [6,]  -8.833641  -8.751230  -9.328656  -8.833641

To obtain a potential better fit we next proceed with a natural cubic spline
#+NAME: spline_twostage
#+BEGIN_SRC R :exports both
  kn <- seq(-3,3,length.out=5)
  nonlinear(m2, type="spline", knots=kn) <- eta2 ~ eta1
  e2 <- twostage(m1, m2, data=d)
  e2
#+END_SRC

#+RESULTS: spline_twostage
#+begin_example
                    Estimate Std. Error  Z-value   P-value
Measurements:
   y2~eta2           0.97752    0.03455 28.29248    <1e-12
   y3~eta2           1.04508    0.03488 29.96248    <1e-12
Regressions:
   eta2~z            0.86729    0.20273  4.27795 1.886e-05
   eta2~eta1_1       2.86231    0.67270  4.25495 2.091e-05
   eta2~eta1_2       0.00344    0.10097  0.03409    0.9728
   eta2~eta1_3      -0.26270    0.29398 -0.89360    0.3715
   eta2~eta1_4       0.50778    0.35191  1.44293     0.149
Intercepts:
   y2               -0.12185    0.10922 -1.11563    0.2646
   y3               -0.09874    0.10545 -0.93638    0.3491
   eta2              1.83814    1.66416  1.10454    0.2694
Residual Variances:
   y1                1.31286    0.17750  7.39647
   y2                1.10412    0.14455  7.63850
   y3                0.81124    0.13185  6.15286
   eta2              1.99404    0.27004  7.38416
#+end_example

Confidence limits can be obtained via the Delta method using the =estimate= method:
#+NAME: spline_ci
#+BEGIN_SRC R :exports both :results output
    p <- cbind(eta1=newd$eta1,
	      estimate(e2,f=function(p) predict(e2,p=p,newdata=newd))$coefmat)
    head(p)
#+END_SRC

#+RESULTS: spline_ci
:    eta1  Estimate   Std.Err      2.5%     97.5%      P-value
: p1 -4.0 -9.611119 1.2650975 -12.09066 -7.131573 3.027543e-14
: p2 -3.9 -9.324887 1.2054915 -11.68761 -6.962167 1.031268e-14
: p3 -3.8 -9.038656 1.1467339 -11.28621 -6.791099 3.219580e-15
: p4 -3.7 -8.752425 1.0889618 -10.88675 -6.618099 9.176275e-16
: p5 -3.6 -8.466193 1.0323409 -10.48954 -6.442842 2.384613e-16
: p6 -3.5 -8.179962 0.9770711 -10.09499 -6.264938 5.668675e-17


The fitted function can be obtained with the following code:
#+NAME: fig:pred2
#+BEGIN_SRC R :exports both
  plot(I(eta2-z) ~ eta1, data=d, col=Col("black",0.5), pch=16,
       xlab=expression(eta[1]), ylab=expression(eta[2]), xlim=c(-4,4))
  lines(Estimate ~ eta1, data=as.data.frame(p), col="darkblue", lwd=5)
  confband(p[,1], lower=p[,4], upper=p[,5], polygon=TRUE,
	   border=NA, col=Col("darkblue",0.2))
#+END_SRC

#+RESULTS: fig:pred2

** Cross-validation

A more formal comparison of the different models can be obtained by
cross-validation. Here we specify linear, quadratic and cubic spline
models with 4 and 9 degrees of freedom.
#+NAME: spline_several
#+BEGIN_SRC R :exports code
  m2a <- nonlinear(m2, type="linear", eta2~eta1)
  m2b <- nonlinear(m2, type="quadratic", eta2~eta1)
  kn1 <- seq(-3,3,length.out=5)
  kn2 <- seq(-3,3,length.out=8)
  m2c <- nonlinear(m2, type="spline", knots=kn1, eta2~eta1)
  m2d <- nonlinear(m2, type="spline", knots=kn2, eta2~eta1)
#+END_SRC

#+RESULTS: spline_several

To assess the model fit average RMSE is estimated with 5-fold
cross-validation repeated two times
#+NAME: cv_fit
#+BEGIN_SRC R :cache yes :exports both :ravel cache=TRUE, eval=fullVignette
  ## Scale models in stage 2 to allow for a fair RMSE comparison
  d0 <- d
  for (i in endogenous(m2))
      d0[,i] <- scale(d0[,i],center=TRUE,scale=TRUE)
  ## Repeated 5-fold cross-validation:
  ff <- lapply(list(linear=m2a,quadratic=m2b,spline4=m2c,spline6=m2d),
	      function(m) function(data,...) twostage(m1,m,data=data,stderr=FALSE,control=list(start=coef(e0),contrain=TRUE)))
  fit.cv <- cv(ff,data=d,K=5,rep=2,mc.cores=parallel::detectCores(),seed=1)
#+END_SRC

#+RESULTS[1729f3f75b55a5ad5d4eddbafe8f1f1bdf32fbb8]: cv_fit

#+BEGIN_SRC R :ravel results="hide", echo=FALSE
  ## To save time building the vignettes on CRAN, we cache time consuming computations
  if (fullVignette) {
    fit.cv$fit <- NULL
    saveRDS(fit.cv, "nonlinear_fitcv.rds", version=2)
  } else {
    fit.cv <- readRDS("nonlinear_fitcv.rds")
  }
#+END_SRC

#+RESULTS:

#+BEGIN_SRC R
summary(fit.cv)
#+END_SRC

#+RESULTS:
:               RMSE
: linear    4.616861
: quadratic 3.283140
: spline4   3.067121
: spline6   3.119909

Here the RMSE is in favour of the splines model with 4 degrees of freedom:
#+NAME: multifit
#+BEGIN_SRC R :exports both
  fit <- lapply(list(m2a,m2b,m2c,m2d),
	       function(x) {
		   e <- twostage(m1,x,data=d)
		   pr <- cbind(eta1=newd$eta1,predict(e,newdata=newd$eta1,x=TRUE))
		   return(list(estimate=e,predict=as.data.frame(pr)))
	       })

  plot(I(eta2-z) ~ eta1, data=d, col=Col("black",0.5), pch=16,
       xlab=expression(eta[1]), ylab=expression(eta[2]), xlim=c(-4,4))
  col <- c("orange","darkred","darkgreen","darkblue")
  lty <- c(3,4,1,5)
  for (i in seq_along(fit)) {
      with(fit[[i]]$pr, lines(eta2 ~ eta1, col=col[i], lwd=4, lty=lty[i]))
  }
  legend("bottomright",
	c("linear","quadratic","spline(df=4)","spline(df=6)"),
	col=col, lty=lty, lwd=3)
#+END_SRC

#+RESULTS: multifit


For convenience, the function =twostageCV= can be used to do the
cross-validation (also for choosing the mixture distribution via the ``nmix`` argument, see the section
below). For example,
#+NAME: twostageCV
#+BEGIN_SRC R :exports code :ravel cache=TRUE, eval=fullVignette
  selmod <- twostageCV(m1, m2, data=d, df=2:4, nmix=1:2,
	      nfolds=2, rep=1, mc.cores=parallel::detectCores())
#+END_SRC

#+RESULTS: twostageCV

#+BEGIN_SRC R :ravel results="hide", echo=FALSE
  ## To save time building the vignettes on CRAN, we cache time consuming computations
  if (fullVignette) {
    saveRDS(summary(selmod), "nonlinear_selmod.rds", version=2)
  } else {
    selmod <- readRDS("nonlinear_selmod.rds")
  }
#+END_SRC

#+RESULTS:


applies cross-validation (here just 2 folds for simplicity) to select the best splines with
degrees of freedom varying from from 1-3 (the linear model is
automatically included)

#+BEGIN_SRC R :exports both
selmod
#+END_SRC

#+RESULTS:
#+begin_example
______________________________________________________________________
Selected mixture model: 2 components
      AIC1
1 1961.839
2 1958.803
______________________________________________________________________
Selected spline model degrees of freedom: 3
Knots: -3.958 -1.305 1.348 4.001

     RMSE(nfolds=, rep=)
df:1            4.733689
df:2            4.148374
df:3            4.028920
df:4            4.059291
______________________________________________________________________

                    Estimate Std. Error Z-value  P-value   std.xy
Measurements:
   y1~eta2           1.00000                                0.93527
   y2~eta2           0.97784  0.03460   28.25978   <1e-12   0.94267
   y3~eta2           1.04516  0.03472   30.10240   <1e-12   0.96181
Regressions:
   eta2~z            1.02615  0.22371    4.58699 4.497e-06  0.34656
   eta2~eta1_1       3.54900  0.63734    5.56849 2.57e-08   1.54239
   eta2~eta1_2      -0.06054  0.02462   -2.45885 0.01394   -1.34652
   eta2~eta1_3       0.05952  0.07251    0.82092 0.4117     0.27144
Intercepts:
   y1                0.00000                                0.00000
   y2               -0.12178  0.10922   -1.11502 0.2648    -0.03874
   y3               -0.09873  0.10547   -0.93606 0.3492    -0.02998
   eta2              4.32762  1.45956    2.96501 0.003027   1.42794
Residual Variances:
   y1                1.31538  0.17614    7.46772            0.12527
   y2                1.10068  0.14566    7.55650            0.11137
   y3                0.81251  0.13272    6.12200            0.07491
   eta2              2.02944  0.29264    6.93490            0.22095
#+end_example

** Specification of general functional forms

Next, we show how to specify a general functional relation of
multiple different latent or exogenous variables. This is achieved via
the =predict.fun= argument. To illustrate this we include interactions
between the latent variable \(\eta_{1}\) and a dichotomized version of
the covariate \(z\)
#+BEGIN_SRC R :exports both
  d$g <- (d$z<0)*1 ## Group variable
  mm1 <- regression(m1, ~g)  # Add grouping variable as exogenous variable (effect specified via 'predict.fun')
  mm2 <- regression(m2, eta2~ u1+u2+u1:g+u2:g+z)
  pred <- function(mu,var,data,...) {
      cbind("u1"=mu[,1],"u2"=mu[,1]^2+var[1],
	    "u1:g"=mu[,1]*data[,"g"],"u2:g"=(mu[,1]^2+var[1])*data[,"g"])
  }
  ee1 <- twostage(mm1, model2=mm2, data=d, predict.fun=pred)
  estimate(ee1,keep="eta2~u",regex=TRUE)
#+END_SRC

#+RESULTS:
:           Estimate Std.Err    2.5%   97.5%  P-value
: eta2~u1     0.9891  0.3020  0.3971  1.5810 0.001057
: eta2~u2    -0.3962  0.1443 -0.6791 -0.1133 0.006047
: eta2~u1:g   0.4487  0.4620 -0.4568  1.3543 0.331409
: eta2~u2:g   0.0441  0.2166 -0.3804  0.4686 0.838667


A formal test show no statistically significant effect of this interaction
#+BEGIN_SRC R :exports both
summary(estimate(ee1,keep="(:g)", regex=TRUE))
#+END_SRC

#+RESULTS:
#+begin_example
Call: estimate.default(x = ee1, keep = "(:g)", regex = TRUE)
__________________________________________________
          Estimate Std.Err    2.5%  97.5% P-value
eta2~u1:g   0.4487  0.4620 -0.4568 1.3543  0.3314
eta2~u2:g   0.0441  0.2166 -0.3804 0.4686  0.8387

 Null Hypothesis:
  [eta2~u1:g] = 0
  [eta2~u2:g] = 0

chisq = 0.9441, df = 2, p-value = 0.6237
#+end_example


** Mixture models

Lastly, we demonstrate how the distributional assumptions of stage 1
model can be relaxed by letting the conditional distribution of the
latent variable given covariates follow a Gaussian mixture
distribution. The following code explictly defines the parameter
constraints of the model by setting the intercept of the first
indicator variable, \(x_{1}\), to zero and the factor loading
parameter of the same variable to one.
#+BEGIN_SRC R :exports both
  m1 <- baptize(m1)  ## Label all parameters
  intercept(m1, ~x1+eta1) <- list(0,NA) ## Set intercept of x1 to zero. Remove the label of eta1
  regression(m1,x1~eta1) <- 1 ## Factor loading fixed to 1
#+END_SRC

#+RESULTS:

The mixture model may then be estimated using the =mixture= method
(note, this requires the =mets= package to be installed), where the
Parameter names shared across the different mixture components given
in the =list= will be constrained to be identical in the mixture
model. Thus, only the intercept of \(\eta_{1}\) is allowed to vary
between the mixtures.

#+NAME: mixture1
#+BEGIN_SRC R :ravel cache=TRUE, eval=fullVignette
  set.seed(1)
  em0 <- mixture(m1, k=2, data=d)
#+END_SRC

To decrease the risk of using a local maximizer of the likelihood we
can rerun the estimation with different random starting values
#+NAME: estmixture
#+BEGIN_SRC R :cache t :exports code :ravel cache=TRUE,warnings=FALSE,messages=FALSE,eval=FALSE
  em0 <- NULL
  ll <- c()
  for (i in 1:5) {
      set.seed(i)
      em <- mixture(m1, k=2, data=d, control=list(trace=0))
      ll <- c(ll,logLik(em))
      if (is.null(em0) || logLik(em0)<tail(ll,1))
	  em0 <- em
  }
#+END_SRC

#+RESULTS: estmixture

#+BEGIN_SRC R :ravel results="hide", echo=FALSE
  ## To save time building the vignettes on CRAN, we cache time consuming computations
  if (fullVignette) {
    saveRDS(em0, "nonlinear_em0.rds", version=2)
  } else {
    em0 <- readRDS("nonlinear_em0.rds")
  }
#+END_SRC

#+RESULTS:


#+BEGIN_SRC R :exports both
summary(em0)
#+END_SRC

#+RESULTS:
#+begin_example
Cluster 1 (n=162, Prior=0.776):
--------------------------------------------------
                    Estimate Std. Error Z value  Pr(>|z|)
Measurements:
   x1~eta1           1.00000
   x2~eta1           0.99581  0.07940   12.54099   <1e-12
   x3~eta1           1.06345  0.08436   12.60541   <1e-12
Regressions:
   eta1~z            1.06675  0.08527   12.50989   <1e-12
Intercepts:
   x1                0.00000
   x2                0.03845  0.09890    0.38883 0.6974
   x3               -0.02549  0.10333   -0.24667 0.8052
   eta1              0.20925  0.13162    1.58984 0.1119
Residual Variances:
   x1                0.98540  0.13316    7.40025
   x2                0.97180  0.13156    7.38695
   x3                1.01316  0.14294    7.08815
   eta1              0.29046  0.11129    2.61004

Cluster 2 (n=38, Prior=0.224):
--------------------------------------------------
                    Estimate Std. Error Z value  Pr(>|z|)
Measurements:
   x1~eta1           1.00000
   x2~eta1           0.99581  0.07940   12.54099   <1e-12
   x3~eta1           1.06345  0.08436   12.60541   <1e-12
Regressions:
   eta1~z            1.06675  0.08527   12.50989   <1e-12
Intercepts:
   x1                0.00000
   x2                0.03845  0.09890    0.38883 0.6974
   x3               -0.02549  0.10333   -0.24667 0.8052
   eta1             -1.44290  0.25867   -5.57812 2.431e-08
Residual Variances:
   x1                0.98540  0.13316    7.40025
   x2                0.97180  0.13156    7.38695
   x3                1.01316  0.14294    7.08815
   eta1              0.29046  0.11129    2.61004
--------------------------------------------------
#+end_example

Measured by AIC there is a slight improvement in the model fit using the mixture model
#+BEGIN_SRC R :exports both :ravel eval=mets
e0 <- estimate(m1,data=d)
AIC(e0,em0)
#+END_SRC

#+RESULTS:
:     df      AIC
: e0  10 1961.839
: em0 12 1958.803

The spline model may then be estimated as before with the =two-stage= method
#+BEGIN_SRC R :exports both :ravel eval=mets
em2 <- twostage(em0,m2,data=d)
em2
#+END_SRC


In this example the results are very similar to the Gaussian model:
#+NAME: mixturefit
#+BEGIN_SRC R :exports both :ravel eval=mets
  plot(I(eta2-z) ~ eta1, data=d, col=Col("black",0.5), pch=16,
       xlab=expression(eta[1]), ylab=expression(eta[2]))

  lines(Estimate ~ eta1, data=as.data.frame(p), col="darkblue", lwd=5)
  confband(p[,1], lower=p[,4], upper=p[,5], polygon=TRUE,
	   border=NA, col=Col("darkblue",0.2))

  pm <- cbind(eta1=newd$eta1,
	      estimate(em2, f=function(p) predict(e2,p=p,newdata=newd))$coefmat)
  lines(Estimate ~ eta1, data=as.data.frame(pm), col="darkred", lwd=5)
  confband(pm[,1], lower=pm[,4], upper=pm[,5], polygon=TRUE,
	   border=NA, col=Col("darkred",0.2))
  legend("bottomright", c("Gaussian","Mixture"),
	 col=c("darkblue","darkred"), lwd=2, bty="n")
#+END_SRC

#+RESULTS: mixturefit


bibliographystyle:unsrtnat
bibliography:ref.bib


* COMMENT Local Variables                                           :ARCHIVE:
# Local Variables:
# coding: utf-8
# eval: (add-hook 'after-save-hook
#        '(lambda () (org-ravel-export-to-file 'ravel-markdown)) nil t)
# my-org-buffer-local-mode: t
# eval: (defun myknit() (interactive) (save-buffer)
#        (let ((cmd (concat "R-devel --slave -e 'rmarkdown::render(\"" (replace-regexp-in-string "org$" "Rmd" (buffer-file-name)) "\")'")))
# 	   (shell-command-to-string cmd)))
# eval: (define-key my-org-buffer-local-mode-map (kbd "<f10>") 'myknit)
# End:
