[Gmm-commits] r150 - in pkg/gmm4: R man vignettes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Nov 4 23:30:09 CET 2019
Author: chaussep
Date: 2019-11-04 23:30:08 +0100 (Mon, 04 Nov 2019)
New Revision: 150
Modified:
pkg/gmm4/R/gel.R
pkg/gmm4/R/gelModels-methods.R
pkg/gmm4/man/gmmToGel-methods.Rd
pkg/gmm4/man/lambdaAlgo.Rd
pkg/gmm4/vignettes/empir.bib
pkg/gmm4/vignettes/gelS4.Rnw
pkg/gmm4/vignettes/gelS4.pdf
Log:
worked on the vignettes and fixed a few bugs
Modified: pkg/gmm4/R/gel.R
===================================================================
--- pkg/gmm4/R/gel.R 2019-11-04 16:56:21 UTC (rev 149)
+++ pkg/gmm4/R/gel.R 2019-11-04 22:30:08 UTC (rev 150)
@@ -70,16 +70,14 @@
obj = res$obj)
}
-REEL_lam <- function(gmat, k=1, control=list())
+REEL_lam <- function(gmat, tol=NULL, maxiter=50, k=1)
{
gmat <- as.matrix(gmat)
n <- nrow(gmat)
q <- ncol(gmat)
- maxit <- ifelse("maxit" %in% names(control),
- control$maxit, 50)
res <- try(.Fortran(F_lamcuep, as.double(gmat),
as.integer(n), as.integer(q), as.double(k),
- as.integer(maxit),conv=integer(1),
+ as.integer(maxiter),conv=integer(1),
lam=double(q),pt=double(n),
obj=double(1)
), silent=TRUE)
@@ -94,22 +92,28 @@
{
q <- qr(gmat)
n <- nrow(gmat)
- l0 <- -qr.coef(q, rep(1,n))
+ lambda0 <- -qr.coef(q, rep(1,n))
conv <- list(convergence=0)
- list(lambda = l0, convergence = conv, obj =
- mean(rhoEEL(gmat,l0,0,k)))
+ list(lambda = lambda0, convergence = conv, obj =
+ mean(rhoEEL(gmat,lambda0,0,k)))
}
-getLambda <- function (gmat, l0=NULL, gelType, rhoFct=NULL,
+getLambda <- function (gmat, lambda0=NULL, gelType=NULL, rhoFct=NULL,
tol = 1e-07, maxiter = 100, k = 1, method="BFGS",
algo = c("nlminb", "optim", "Wu"), control = list())
{
algo <- match.arg(algo)
gmat <- as.matrix(gmat)
- if (is.null(l0))
- l0 <- rep(0, ncol(gmat))
+ if (is.null(lambda0))
+ lambda0 <- rep(0, ncol(gmat))
if (is.null(rhoFct))
- rhoFct <- get(paste("rho",gelType,sep=""))
+ {
+ if (is.null(gelType))
+ stop("Without rhoFct, gelType must be given")
+ rhoFct <- get(paste("rho",gelType,sep=""))
+ } else {
+ gelType <- "Other"
+ }
if (algo == "Wu" & gelType != "EL")
stop("Wu (2005) algo to compute Lambda is for EL only")
if (algo == "Wu")
@@ -117,7 +121,7 @@
if (gelType == "EEL")
return(EEL_lam(gmat, k))
if (gelType == "REEL")
- return(REEL_lam(gmat, k, control))
+ return(REEL_lam(gmat, NULL, maxiter, k))
fct <- function(l, X, rhoFct, k) {
r0 <- rhoFct(X, l, derive = 0, k = k)
@@ -135,21 +139,21 @@
if (gelType == "EL")
{
ci <- -rep(1, nrow(gmat))
- res <- constrOptim(l0, fct, Dfct, -gmat, ci, control = control,
+ res <- constrOptim(lambda0, fct, Dfct, -gmat, ci, control = control,
X = gmat, rhoFct = rhoFct, k = k)
} else if (gelType == "HD") {
ci <- -rep(1, nrow(gmat))
- res <- constrOptim(l0, fct, Dfct, -gmat, ci, control = control,
+ res <- constrOptim(lambda0, fct, Dfct, -gmat, ci, control = control,
X = gmat, rhoFct = rhoFct, k = k)
} else {
- res <- optim(l0, fct, gr = Dfct, X = gmat, rhoFct = rhoFct,
+ res <- optim(lambda0, fct, gr = Dfct, X = gmat, rhoFct = rhoFct,
k = k, method = method, control = control)
}
} else {
- res <- nlminb(l0, fct, gradient = Dfct, hessian = DDfct,
+ res <- nlminb(lambda0, fct, gradient = Dfct, hessian = DDfct,
X = gmat, rhoFct = rhoFct, k = k, control = control)
}
- l0 <- res$par
+ lambda0 <- res$par
if (algo == "optim")
conv <- list(convergence = res$convergence, counts = res$counts,
message = res$message)
@@ -156,7 +160,8 @@
else
conv <- list(convergence = res$convergence, counts = res$evaluations,
message = res$message)
- return(list(lambda = l0, convergence = conv, obj= mean(rhoFct(gmat,l0,0,k))))
+ return(list(lambda = lambda0, convergence = conv,
+ obj= mean(rhoFct(gmat,lambda0,0,k))))
}
smoothGel <- function (object, theta=NULL)
Modified: pkg/gmm4/R/gelModels-methods.R
===================================================================
--- pkg/gmm4/R/gelModels-methods.R 2019-11-04 16:56:21 UTC (rev 149)
+++ pkg/gmm4/R/gelModels-methods.R 2019-11-04 22:30:08 UTC (rev 150)
@@ -116,7 +116,7 @@
gt <- evalMoment(model, theta)
gelt <- model at gelType
k <- model at wSpec$k
- args <- c(list(gmat=gt, l0=lambda0, gelType=gelt$name,
+ args <- c(list(gmat=gt, lambda0=lambda0, gelType=gelt$name,
rhoFct=gelt$fct), lcont, k=k[1]/k[2])
res <- do.call(slv, args)
if (returnL)
@@ -266,6 +266,14 @@
gmmToGel(object, gelType, rhoFct)
})
+## gmmToGel
+setMethod("gmmToGel", signature("gelModels"),
+ function(object, gelType, rhoFct=NULL){
+ gmmToGel(as(object, "gmmModels"), gelType, rhoFct)
+ })
+
+
+
Modified: pkg/gmm4/man/gmmToGel-methods.Rd
===================================================================
--- pkg/gmm4/man/gmmToGel-methods.Rd 2019-11-04 16:56:21 UTC (rev 149)
+++ pkg/gmm4/man/gmmToGel-methods.Rd 2019-11-04 22:30:08 UTC (rev 150)
@@ -3,6 +3,7 @@
\alias{gmmToGel}
\alias{gmmToGel-methods}
\alias{gmmToGel,gmmModels-method}
+\alias{gmmToGel,gelModels-method}
\alias{gmmToGel,rgmmModels-method}
\title{ ~~ Methods for Function \code{gmmToGel} in Package \pkg{gmm4} ~~}
\description{
@@ -30,6 +31,11 @@
The object it converted to \code{"gelModels"}.
}
+\item{\code{signature(object = "gelModels")}}{
+It applies the transformation to the \code{"gmmModels"} contained in the
+\code{"gelModels"} object.
+}
+
\item{\code{signature(object = "rgmmModels")}}{
The object it converted to \code{"rgelModels"}.
}
Modified: pkg/gmm4/man/lambdaAlgo.Rd
===================================================================
--- pkg/gmm4/man/lambdaAlgo.Rd 2019-11-04 16:56:21 UTC (rev 149)
+++ pkg/gmm4/man/lambdaAlgo.Rd 2019-11-04 22:30:08 UTC (rev 150)
@@ -12,13 +12,13 @@
the GEL objective function for a given vector of coefficient \eqn{\theta}.
}
\usage{
-Wu_lam(gmat, tol = 1e-08, maxiter = 50, k=1)
+Wu_lam(gmat, tol=1e-8, maxiter=50, k=1)
EEL_lam(gmat, k=1)
-REEL_lam(gmat, k=1, control=list())
+REEL_lam(gmat, tol=NULL, maxiter=50, k=1)
-getLambda(gmat, l0=NULL, gelType, rhoFct=NULL,
+getLambda(gmat, lambda0=NULL, gelType=NULL, rhoFct=NULL,
tol = 1e-07, maxiter = 100, k = 1, method="BFGS",
algo = c("nlminb", "optim", "Wu"), control = list())
}
@@ -25,7 +25,7 @@
\arguments{
\item{gmat}{The \eqn{n \times q} matrix of moments}
-\item{l0}{The \eqn{q \times 1} vector of starting values for the
+\item{lambda0}{The \eqn{q \times 1} vector of starting values for the
Lagrange multipliers.}
\item{tol}{A tolerance level for the stopping rule in the Wu algorithm}
Modified: pkg/gmm4/vignettes/empir.bib
===================================================================
--- pkg/gmm4/vignettes/empir.bib 2019-11-04 16:56:21 UTC (rev 149)
+++ pkg/gmm4/vignettes/empir.bib 2019-11-04 22:30:08 UTC (rev 150)
@@ -614,10 +614,21 @@
PAGES={300-325},
YEAR={1994}
}
-
+
+ at article{wu05,
+ NUMBER = {2},
+ AUTHOR = {Wu, C.},
+ TITLE = {Algorithms and {R} codes for the pseudo empirical likelihood
+ method in survey sampling},
+ JOURNAL = {Survey Methodology},
+ VOLUME = {31},
+ PAGES = {239},
+ YEAR = {2005}
+ }
+
@Manual{gmm,
title = {gmm: Generalized Method of Moments and Generalized Empirical Likelihood},
- author = {Pierre Chausse},
+ author = {Pierre Chauss\'e},
year = {2019},
note = {R package version 1.6-3},
}
Modified: pkg/gmm4/vignettes/gelS4.Rnw
===================================================================
--- pkg/gmm4/vignettes/gelS4.Rnw 2019-11-04 16:56:21 UTC (rev 149)
+++ pkg/gmm4/vignettes/gelS4.Rnw 2019-11-04 22:30:08 UTC (rev 150)
@@ -115,11 +115,19 @@
corresponds to Empirical Likelihood (EL) of \cite{owen01} ,
$\rho(v)=-\exp{(v)}$ to the Exponential Tilting (ET) of
\cite{kitamura-stutzer97}, and $\rho(v)=(-v-v^2/2)$ to the Continuous
- Updated GMM estimator (CUE) of \cite{hansen-heaton-yaron96}. In the
- context of GEL, the CUE is also known at the Euclidean Empirical
- Likelihood (EEL), because it corresponds to $h_n(p_i)$ being the
- Euclidean distance.
+Updated GMM estimator (CUE) of \cite{hansen-heaton-yaron96}. In the
+context of GEL, the CUE is also known at the Euclidean Empirical
+Likelihood (EEL), because it corresponds to $h_n(p_i)$ being the
+Euclidean distance.
+Once the solution is obtained for $\theta$ and $\lambda$, the implied
+probabilities can be computed as follows
+
+\begin{equation}\label{imp_prob}
+\hat{p}_i = \frac{\rho'(\hat{\lambda}'g_i(\hat{\theta}))}{\sum_{j=1}^n
+ \rho'(\hat{\lambda}'g_j(\hat{\theta}))}
+\end{equation}
+
If we relax the iid assumption, the problem is identical, but the
moment function must be smoothed using a kernel method. \cite{smith01}
proposes to replace $g_i(\theta)$ by:
@@ -131,7 +139,181 @@
\section{An S4 class object for GEL models} \label{sec:gelmodels}
+All classes for GEL models inherit directly from ``gmmModels''
+classes. It is just a gmmModel class with two additional slots:
+``gelType'' and ``wSpec''. The first is a list with the name of the
+GEL method and a function for $\rho(v)$, if not already available in
+the package. The second slot is used to store information about the
+smoothing of $g_i(\theta)$ in the case of non-iid observations. As for
+gmmModels, ``gelModels'' is a union class for ``linearGel'',
+``nonlinearGel'', ``formulaGel'' and ``functionGel''. They inherit
+directly from the associated GMM model class. For example,
+``linearGel'' is a class that contains a ``linearGmm'' class object
+and the two additional slots. The constructor is the gelModel()
+function. We use the same models presented in the gmmS4
+vignette:
+<<>>=
+library(gmm4)
+data(simData)
+@
+
+\begin{itemize}
+ \item Linear models:
+
+<<>>=
+lin <- gelModel(y~x1+x2, ~x2+z1+z2, data=simData, vcov="iid", gelType="EL")
+lin
+@
+
+\item Formula-type models:
+
+<<>>=
+theta0=c(mu=1,sig=1)
+x <- simData$x1
+dat <- data.frame(x=x, x2=x^2, x3=x^3, x4=x^4)
+gform <- list(x~mu,
+ x2~mu^2+sig,
+ x3~mu^3+3*mu*sig,
+ x4~mu^4+6*mu^2*sig+3*sig^2)
+form <- gelModel(gform, NULL, gelType="EEL", theta0=theta0, vcov="MDS", data=dat)
+form
+@
+
+\item function:
+
+<<>>=
+fct <- function(theta, x)
+ cbind(x-theta[1], (x-theta[1])^2-theta[2],
+ (x-theta[1])^3, (x-theta[1])^4-3*theta[2]^2)
+dfct <- function(theta, x)
+ {
+ m1 <- mean(x-theta[1])
+ m2 <- mean((x-theta[1])^2)
+ m3 <- mean((x-theta[1])^3)
+ matrix(c(-1, -2*m1, -3*m2, -4*m3,
+ 0, -1, 0, -6*theta[2]), 4, 2)
+ }
+theta0=c(mu=1,sig2=1)
+func <- gelModel(fct, simData$x3, theta0=theta0, grad=dfct, vcov="iid", gelType="ET")
+func
+@
+
+\item Non-linear models:
+
+<<>>=
+theta0=c(b0=1, b1=1, b2=1)
+gform <- y~exp(b0+b1*x1+b2*x2)
+nlin <- gelModel(gform, ~z1+z2+z3+x2, theta0=theta0, vcov="MDS", data=simData,
+ gelType="HD")
+nlin
+@
+\end{itemize}
+
+It is also posssible to convert an existing gmmModels to gelModels:
+
+<<>>=
+nlin <- gmmModel(gform, ~z1+z2+z3+x2, theta0=theta0, vcov="MDS", data=simData)
+nlin <- gmmToGel(nlin, gelType="HD")
+@
+
+\subsection{The rhoXXX functions}
+
+The package provides $\rho(v)$ for ET, EL, EEL and HD. The function
+names are respectively ``rhoET'', ``rhoEL'', ``rhoEEL'' and ``rhoHD''.
+For any other GEL, users can pass user specific $\rho(v)$ function to
+the rhoFct argument of the gelModel(). The following example shows how
+the function must be built:
+
+<<>>=
+rhoEL
+@
+
+Therefore, the function must be in the form $f(X,\lambda,d,k)$, where
+the first argument is an $n\times q$ matrix, the second argument is a
+vector of $q$ elements, the third is an integer that indicates the
+order of derivative to return, and the last is a scalar that depends
+on the kernel used to smooth the moment function. We will discuss that
+in more details below. The function must return the vector $\rho(k
+X\lambda)$, $\rho'(k X\lambda)$ or $\rho''(k X\lambda)$, when derive
+is 0, 1, or 2, where $\rho'(v)$ and $\rho''(v)$ are the first and
+second derivative of $\rho(v)$.
+
+\subsection{The Lagrange multiplier solver}
+
+The function getLambda() function solve the maximization problem
+\[
+\max_\lambda \frac{1}{n} \sum_{i=1}^n \rho(\lambda'X_i)
+\]
+It is used to solve problem (\ref{gel_obj}). The arguments are:
+
+<<>>=
+args(getLambda)
+@
+
+The first argument is the $n\times q$ matrix $X$. The second argument
+is the starting value for $\lambda$. If set to NULL, a vector of
+zeroes is used. The third argument is the GEL type, which is either
+"ET", "EL", "EEL", "REEL" or "HD". If the rhoFct is provided, getType
+is ignored. The argument control is used to pass a list of arguments
+to optim(), nlminb() or constrOptim(). The argument ``k'' is the
+scalar described in the previous subsection. To describe all other
+arguments, we are presenting the options by type of GEL:
+
+\begin{itemize}
+\item EL: There are three possible options for EL. The default is
+ ``nlminb'', in which case, the arguments tol, maxiter and method are
+ ignored. If algo is set to ``optim'', the solution is obtained using
+ constrOptim(), with the restriction $(1-\lambda'X_i)>0$ for all
+ $i$. If algo is set to ``Wu'', the \cite{wu05} algorithm is
+ used. The argument tol and maxit are used to control the stopping
+ rule.
+
+\item HD: Identical to EL, except that the ``Wu'' algorithm is not
+ available for that type of GEL.
+
+\item EEL: There is an analytical solution, so all other arguments are
+ ignored.
+
+\item REEL: This is EEL with a non-negativity constraint on all
+ implied probabilities. In that case, the maxiter can be used to
+ control the number of iterations.
+
+\item: Others: When rhoFct is provided or the type is ET, the solution
+ is obtained by either ``nlminb'' or ``optim''. In that case, the
+ algorithms are controlled through the control argument.
+\end{itemize}
+
+Here are a few example using the simulated dataset (convergence code
+of 0 means that the algorithm converged with no detected problem):
+
+<<>>=
+X <- simData[c("x3","x4","z5")]
+(res <- getLambda(X, gelType="EL"))$lambda
+res$convergence$convergence
+@
+
+<<>>=
+(res <- getLambda(X, gelType="EL", algo="Wu"))$lambda
+res$convergence$convergence
+@
+
+<<>>=
+(res <- getLambda(X, gelType="ET",control=list(maxit=2000)))$lambda
+res$convergence$convergence
+@
+
+<<>>=
+(res <- getLambda(X, rhoFct=rhoEEL))$lambda
+res$convergence$convergence
+@
+
+Although we rarely call the function directly, it is good to
+understand how it works, because it is an important part of the
+estimation procedure.
+
+\section{Methods for gelModels Classes} \label{sec:gelmodels-methods}
+
\bibliography{empir}
\pagebreak
\Large{\textbf{Appendix}}
Modified: pkg/gmm4/vignettes/gelS4.pdf
===================================================================
(Binary files differ)
More information about the Gmm-commits
mailing list