[Yuima-commits] r309 - in pkg/yuima: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 29 13:26:47 CEST 2014
Author: iacus
Date: 2014-04-29 13:26:47 +0200 (Tue, 29 Apr 2014)
New Revision: 309
Modified:
pkg/yuima/DESCRIPTION
pkg/yuima/NAMESPACE
pkg/yuima/NEWS
pkg/yuima/R/lasso.R
Log:
added print method for lasso
Modified: pkg/yuima/DESCRIPTION
===================================================================
--- pkg/yuima/DESCRIPTION 2014-04-29 03:34:57 UTC (rev 308)
+++ pkg/yuima/DESCRIPTION 2014-04-29 11:26:47 UTC (rev 309)
@@ -1,7 +1,7 @@
Package: yuima
Type: Package
Title: The YUIMA Project package for SDEs
-Version: 1.0.14
+Version: 1.0.15
Date: 2014-04-29
Depends: methods, zoo, stats4, utils, expm
Suggests: cubature, mvtnorm
Modified: pkg/yuima/NAMESPACE
===================================================================
--- pkg/yuima/NAMESPACE 2014-04-29 03:34:57 UTC (rev 308)
+++ pkg/yuima/NAMESPACE 2014-04-29 11:26:47 UTC (rev 309)
@@ -63,6 +63,7 @@
export(setSampling)
export(setCharacteristic)
export(setCarma)
+
export(dim)
export(length)
@@ -122,10 +123,12 @@
S3method(print, phitest)
S3method(print, qgv)
S3method(print, mmfrac)
+S3method(print, yuima.lasso)
S3method(toLatex, yuima)
S3method(toLatex, yuima.model)
S3method(toLatex, yuima.carma)
+
useDynLib(yuima)
Modified: pkg/yuima/NEWS
===================================================================
--- pkg/yuima/NEWS 2014-04-29 03:34:57 UTC (rev 308)
+++ pkg/yuima/NEWS 2014-04-29 11:26:47 UTC (rev 309)
@@ -16,4 +16,5 @@
2013/10/28: modify llag.R
2013/10/30: modify cce.R, cce_functions.c
2013/11/21: modify llag.R
-2013/11/22: modify cce.R, cce_functions.c
\ No newline at end of file
+2013/11/22: modify cce.R, cce_functions.c
+2014/04/28: modified qmle, added carma, modified lasso
Modified: pkg/yuima/R/lasso.R
===================================================================
--- pkg/yuima/R/lasso.R 2014-04-29 03:34:57 UTC (rev 308)
+++ pkg/yuima/R/lasso.R 2014-04-29 11:26:47 UTC (rev 309)
@@ -2,32 +2,49 @@
# fixes a small bug in passing arguments to the
# inner optim function
-lasso <- function (yuima, lambda0, start, delta = 1, ...)
+lasso <- function (yuima, lambda0, start, delta = 1, ...)
{
call <- match.call()
if (missing(yuima))
yuima.stop("yuima object 'yuima' is missing.")
+ pars <- yuima at model@parameter at all
+ npars <- length(pars)
if (missing(lambda0)) {
- pars <- yuima at model@parameter at all
- lambda0 <- rep(1, length(pars))
+ lambda0 <- rep(1, npars)
names(lambda0) <- pars
lambda0 <- as.list(lambda0)
}
+ if(!is.list(lambda0)){
+ lambda0 <- as.numeric(lambda0)
+ lambda0 <- as.numeric(matrix(lambda0, npars,1))
+ names(lambda0) <- pars
+ lambda0 <- as.list(lambda0)
+ }
if (missing(start))
yuima.stop("Starting values for the parameters are missing.")
fail <- lapply(lambda0, function(x) as.numeric(NA))
cat("\nLooking for MLE estimates...\n")
fit <- try(qmle(yuima, start = start, ...), silent = TRUE)
- if (class(fit) == "try-error")
- return(list(mle = fail, sd.mle = NA, lasso = fail, sd.lasso = NA))
+ if (class(fit) == "try-error"){
+ tmp <- list(mle = fail, sd.mle = NA, lasso = fail, sd.lasso = NA)
+ class(tmp) <- "yuima.lasso"
+ return(tmp)
+ }
theta.mle <- coef(fit)
SIGMA <- try(sqrt(diag(vcov(fit))), silent = TRUE)
- if (class(SIGMA) == "try-error")
- return(list(mle = theta.mle, sd.mle = NA, lasso = fail, sd.lasso = NA))
+ if (class(SIGMA) == "try-error"){
+ tmp <- list(mle = theta.mle, sd.mle = NA, lasso = fail, sd.lasso = NA)
+ class(tmp) <- "yuima.lasso"
+ return(tmp)
+ }
+
H <- try(solve(vcov(fit)), silent = TRUE)
- if (class(H) == "try-error")
- return(list(mle = theta.mle, sd.mle = SIGMA, lasso = fail, sd.lasso = NA))
-
+ if (class(H) == "try-error"){
+ tmp <- list(mle = theta.mle, sd.mle = SIGMA, lasso = fail, sd.lasso = NA)
+ class(tmp) <- "yuima.lasso"
+ return(tmp)
+ }
+
lambda <- unlist(lambda0[names(theta.mle)])/abs(theta.mle)^delta
#lambda1 <- unlist(lambda0[names(theta.mle)])/abs(theta.mle)
@@ -48,79 +65,46 @@
fit2 <- try( do.call(optim, args = args), silent = TRUE)
- if (class(fit2) == "try-error")
- return(list(mle = theta.mle, sd.mle = SIGMA, lasso = fail, sd.lasso = NA))
+ if (class(fit2) == "try-error"){
+ tmp <- list(mle = theta.mle, sd.mle = SIGMA, lasso = fail, sd.lasso = NA)
+ class(tmp) <- "yuima.lasso"
+ return(tmp)
+ }
theta.lasso <- fit2$par
SIGMA1 <- try(sqrt(diag(solve(fit2$hessian))), silent = TRUE)
- if (class(SIGMA1) == "try-error")
- return(list(mle = theta.mle, sd.mle = SIGMA, lasso = theta.lasso,
- sd.lasso = NA))
- return(list(mle = theta.mle, sd.mle = SIGMA, lasso = theta.lasso,
- sd.lasso = SIGMA1, call = call, lambda0 = lambda0))
+ if (class(SIGMA1) == "try-error"){
+ tmp <- list(mle = theta.mle, sd.mle = SIGMA, lasso = theta.lasso,
+ sd.lasso = NA)
+ class(tmp) <- "yuima.lasso"
+ return(tmp)
+ }
+
+ tmp <- list(mle = theta.mle, sd.mle = SIGMA, lasso = theta.lasso,
+ sd.lasso = SIGMA1, call = call, lambda0 = lambda0)
+ class(tmp) <- "yuima.lasso"
+ return(tmp)
+
}
-# removed version
-old.lasso <- function(yuima, lambda0, start, delta=1, ...){
-
- call <- match.call()
-
- if( missing(yuima))
- yuima.stop("yuima object 'yuima' is missing.")
-
- if( missing(lambda0) ){
- pars <- yuima at model@parameter at all
- lambda0 <- rep(1, length(pars))
- names(lambda0) <- pars
- lambda0 <- as.list(lambda0)
- }
-
-## FIXME: maybe we should choose initial values at random within lower/upper
-## at present, qmle stops
- if( missing(start) )
- yuima.stop("Starting values for the parameters are missing.")
-
- fail <- lapply(lambda0, function(x) as.numeric(NA))
-
- cat("\nLooking for MLE estimates...\n")
- fit <- try(qmle(yuima, start=start,...), silent=TRUE)
- if(class(fit)=="try-error")
- return(list(mle=fail, sd.mle=NA, lasso=fail, sd.lasso=NA))
-
- SIGMA <- try( sqrt(diag(vcov(fit))), silent=TRUE)
- if(class(SIGMA)=="try-error")
- return(list(mle=fail, sd.mle=NA, lasso=fail, sd.lasso=NA))
-
-
- theta.mle <- coef(fit)
-
- H <- try( solve(vcov(fit)), silent=TRUE)
-
- if(class(H)=="try-error")
- return(list(mle=fail, sd.mle=NA, lasso=fail, sd.lasso=NA))
-
-
-# lambda <- unlist(lambda0[names(theta.mle)])/abs(theta.mle)
- lambda <- unlist(lambda0[names(theta.mle)])/abs(theta.mle)^delta
- lambda1 <- unlist(lambda0[names(theta.mle)])/abs(theta.mle)
- idx <- which(lambda>1e4)
- lambda[idx] <- 1e4 # lambda1[idx]
-
- f2 <- function( theta ) as.numeric( t(theta-theta.mle) %*% H %*% (theta-theta.mle) + lambda %*% abs(theta) )
-
- cat("\nPerforming LASSO estimation...\n")
-
- fit2 <- try( optim(theta.mle, f2, hessian=TRUE,...,
- control = list(maxit=30000, temp=2000, REPORT=500)), silent=TRUE)
- if(class(fit2)=="try-error")
- return(list(mle=fail, sd.mle=NA, lasso=fail, sd.lasso=NA))
-
- theta.lasso <- fit2$par
-
- SIGMA1 <- try(sqrt(diag(solve(fit2$hessian))), silent=TRUE)
-
- if(class(SIGMA1)=="try-error")
- return(list(mle = theta.mle, sd.mle = NA, lasso = theta.lasso, sd.lasso = NA))
-# return(list(mle=fail, sd.mle=NA, lasso=fail, sd.lasso=NA))
-
- return(list(mle=theta.mle, sd.mle=SIGMA, lasso=theta.lasso, sd.lasso=SIGMA1,call=call, lambda0=lambda0))
+
+
+
+print.yuima.lasso <- function(x,...){
+ cat("Adaptive Lasso estimation\n")
+ cat("\nCall:\n")
+ print(x$cal)
+ if(!is.null(x$mle) & !is.null(x$sd.mle)){
+ qmle.tab <- rbind(x$mle, x$sd.mle)
+ rownames(qmle.tab) <- c("Estimate", "Std. Error")
+ cat("\nQMLE estimates\n")
+ print(t(qmle.tab))
+ }
+
+ if(!is.null(x$lasso) & !is.null(x$sd.lasso)){
+ lasso.tab <- rbind(x$lasso, x$sd.lasso)
+ rownames(lasso.tab) <- c("Estimate", "Std. Error")
+ cat("\nLASSO estimates\n")
+ print(t(lasso.tab))
+ }
}
+
More information about the Yuima-commits
mailing list