version 2.0.2

DESCRIPTION

@@ -1,23 +1,27 @@
 Package: SCGLR
 Type: Package
-Title: Supervised Component Generalized Linear Regression (SCGLR)
-Version: 2.0.1
+Title: Supervised Component Generalized Linear Regression
+Version: 2.0.2
 Date: 2014-02-21
-Author: Mortier F., Trottier C., Cornu G., Bry X.
-Maintainer: "G. Cornu" <gcornu@cirad.fr>
-Contact: "F. Mortier" <fmortier@cirad.fr> and "G. Cornu"
-        <gcornu@cirad.fr> and "C. Trottier"
-        <catherine.trottier@univ-montp3.fr> and "X. Bry"
-        <xavier.bry@univ-montp2.fr>
-Description: SCGLR extends the Fisher Scoring Algorithm so as to combine PLS
-    regression with GLM estimation in the multivariate context.
+Authors@R: c(
+  person("Guillaume", "Cornu", role=c("cre","aut"),email="gcornu@cirad.fr"),
+  person("Frederic", "Mortier", role="aut", email="fmortier@cirad.fr"),
+  person("Catherine", "Trottier", role="aut", email="catherine.trottier@univ-montp3.fr"),
+  person("Xavier", "Bry", role="aut", email="xavier.bry@univ-montp2.fr"))
+Description: The Fisher Scoring Algorithm is extended so as to combine Partial Least Squares
+    regression with Generalized Linear Model estimation in the multivariate context.
 License: CeCILL-2 | GPL-2
 Depends: R (>= 3.0.0)
-Imports: Matrix,Formula,expm,graphics,ggplot2,grid,ROCR
+Imports: Matrix,Formula,expm,graphics,ggplot2,grid,pROC
 Suggests: parallel,gridExtra,knitr
 LazyData: yes
 VignetteBuilder: knitr
-Packaged: 2014-10-14 13:18:14 UTC; cornu
+Packaged: 2015-02-16 15:21:24 UTC; cornu
+Author: Guillaume Cornu [cre, aut],
+  Frederic Mortier [aut],
+  Catherine Trottier [aut],
+  Xavier Bry [aut]
+Maintainer: Guillaume Cornu <gcornu@cirad.fr>
 NeedsCompilation: no
 Repository: CRAN
-Date/Publication: 2014-10-14 16:30:27
+Date/Publication: 2015-02-16 17:45:46

MD5

@@ -1,56 +1,56 @@
-53b6ba677ea2dc827dca86c7962388b3 *DESCRIPTION
-0a4725373356267f678f0f43e4da198c *NAMESPACE
-25c4dc5059d4ea7078370dcb14e4b880 *NEWS
-6a74749034a170c2c41807f74f21ac02 *R/critConvergence.r
-84e8367c5be6d4eb4aa05032e1d5d651 *R/customize.r
-9d8d98daabc44cb506bb340000ffe366 *R/data.r
+f9bcb4976f157950ef97c4b1f226e687 *DESCRIPTION
+dbde8a37f4c7fb6a9efecd3f12287875 *NAMESPACE
+b89bab137bd1feaad34216cd2df44180 *NEWS
+fe407b16523faae1e21b97df7b7602ce *R/critConvergence.r
+f7270f67b2a5ec01b786ce271a351dff *R/customize.r
+c769fb69d1872f5bd808b5c35d5692a9 *R/data.r
 f4253e5a2d3920e298ce31e34d0c4fe5 *R/f2x.r
-007faaac5e5d22ccbc32dc05ec106f48 *R/infoCriterion.r
-ffac6162e687a48e707b9a8ab87ac2b4 *R/ingUtils.r
+a646dc9a8fb3aa5e6b8160b265e59fca *R/infoCriterion.r
+3dbdb5168b05e9ec4e0da2776475ec4d *R/ingUtils.r
 0349b37413d57e6d921c8d43efcc7eee *R/kComponents.r
-9ef082b58a74761b8feb872af2aa9dcc *R/methods.r
-58868746ee7485ae4a561700bfde1369 *R/metric.r
-3f8b27f5b653da4edd476daeb0d0df95 *R/multivariateFormula.r
+4ba7230033c3a7490d0dd9cc79e2bd15 *R/methods.r
+7bd55b5f836056a7a58f73375bf2d055 *R/metric.r
+e15ec931f554e11541a96ff4ee1e99f5 *R/multivariateFormula.r
 26ff07ca0c50f66a4007594d68b2f46b *R/multivariateGlm.fit.r
-3a5c41707e779dae512967e5583c3658 *R/multivariateGlm.r
-1623faa4d4209c3440489386c65f04fd *R/multivariatePredictGlm.r
-bcf5c06e0ab14381a378413a504cce91 *R/oneComponent.r
-f94d46225970293d9ec92be04a657190 *R/package.r
-3ad63e61d655ed7ec981b71c829ec742 *R/plot.r
-f8c0969def3216a54b01aedacb9191bc *R/print.r
+a41599c03c0d126edecb0dca6bbd7a9d *R/multivariateGlm.r
+476413c3061140b69bae791da7bc28c9 *R/multivariatePredictGlm.r
+658856a3e97ad270dcec6757f531fe5d *R/oneComponent.r
+af3562bfd9a5f7d37359be6780899f5c *R/package.r
+40bd86d9973e18d9cf60fd32fca625c8 *R/plot.r
+6b6c89a00bd175b725611565e868f1dd *R/print.r
 f0e3d52b7a0e6868e7ee81991ac06c8c *R/scglr.r
-02751b908c7184408b20b055d8768939 *R/scglrCrossVal.r
-77403d27d9fd979b66359208cde63a25 *R/summary.r
+fb8926305414a78135bf96b4f4a59e22 *R/scglrCrossVal.r
+3d486ffb933f86ee95ff48460220f5f1 *R/summary.r
 6134b8018a01f25abdacad8439433b4b *R/utils.r
-6a8d9385f5e2c72bafffabb0189a00a1 *build/vignette.rds
+a1baa945407de24483e5f6c5b0770ea4 *build/vignette.rds
 b454e91b945abf3eaaa1d2ddf9c52cfc *data/genus.rda
 7228f976812aee4fdd60f7ac760b4a43 *demo/00Index
 7ff42f88c9d37c33feb1dea01efbeebe *demo/scglr.r
 725274da96c067732984971ed539f43d *demo/scglrCrossVal.r
 619f968ac2ad86861dcb639dcc703aa8 *demo/scglrPlots.r
-f42b1d5ded8aac352618c1d24ab5d607 *demo/scglrPrediction.r
-da72624afaa9fcc6da2956eae853a582 *inst/doc/scglrVignettes.R
-c77621c3c776ac2ea9f5ae1fdcfec0fc *inst/doc/scglrVignettes.pdf
-4aa5072089942458487d6da7821228b7 *inst/doc/scglrVignettes.rnw
+bb881a7cd25753a10fb2af5b7b85beed *demo/scglrPrediction.r
+c6e040e085bdd5205853378e106275d0 *inst/doc/scglrVignettes.R
+2682315ff83e302194912d8c2fca551c *inst/doc/scglrVignettes.pdf
+0e57f56782f8048a2cf81a46c20af774 *inst/doc/scglrVignettes.rnw
 725274da96c067732984971ed539f43d *inst/examples/exCrossVal.r
 619f968ac2ad86861dcb639dcc703aa8 *inst/examples/exPlots.r
-f42b1d5ded8aac352618c1d24ab5d607 *inst/examples/exPrediction.r
+bb881a7cd25753a10fb2af5b7b85beed *inst/examples/exPrediction.r
 7ff42f88c9d37c33feb1dea01efbeebe *inst/examples/exScglr.r
-f013f7b855138d284ade90f865586fce *man/barplot.SCGLR.Rd
-1072dc62e4091534de93e790ebcefe0d *man/critConvergence.Rd
-e218267e92beb59b1e0d367471a57002 *man/customize.Rd
-b3703f16b8c666243bd742562d8b5878 *man/genus.Rd
-5ad43f3a5a500c7e722e3abf8ab43d2d *man/infoCriterion.Rd
-e7c579545496ee8c09e9b904f97f9c24 *man/method.Rd
-4f4eb91b27d6f52b1a5215abe4cb5a36 *man/multivariateFormula.Rd
-81d7e766cf43f3339b049a9b83c73fa0 *man/multivariateGlm.Rd
-2b18bba5138ae136085c708927c278ff *man/multivariatePredictGlm.Rd
-d6233b35c7c7ce2b457185671d573c4e *man/pairs.SCGLR.Rd
-abfb0831d3eb2151e841c8d890983b3f *man/plot.SCGLR.Rd
-9e35d15095a98828074d888d82f52da9 *man/print.SCGLR.Rd
-1f581ab5d5cb3dabf8b9aab73293ad88 *man/scglr-package.Rd
-c8d575bc092dc4f1e7bd439ca7674c25 *man/scglr.Rd
-90d44b9bf570badec6b05cc2c920439f *man/scglrCrossVal.Rd
-e1471eaa535bd7afdf087ab9ee82581b *man/summary.SCGLR.Rd
+41b723814971ea3ae23c72e018592966 *man/barplot.SCGLR.Rd
+942169004fe3d29b13b2aaa5254c059f *man/critConvergence.Rd
+337143294908e9c7f41d07c76d1111f8 *man/customize.Rd
+fae23e61ce55d56fd95088e3b002f572 *man/genus.Rd
+885860d1502f83b3e5fa3fbccfe394cf *man/infoCriterion.Rd
+d2d4758e6975a58f4bf0bfd12001edfd *man/method.Rd
+e16c4519eac5481c61cb9593ca4f9290 *man/multivariateFormula.Rd
+251425b7f53977e906245e2888d9cd87 *man/multivariateGlm.Rd
+eb969fdb8b86ea9f364980dff2ce9fdc *man/multivariatePredictGlm.Rd
+2e0383d57e3e9eba920110ba82172200 *man/pairs.SCGLR.Rd
+56683bb246ae374589f4be164f91d254 *man/plot.SCGLR.Rd
+b77acaeb5365ae2ae22568903f20c856 *man/print.SCGLR.Rd
+63a59c5dff75029689a25dcae05ee672 *man/scglr-package.Rd
+cf0386eb71df5bec37d842c3358a5dc3 *man/scglr.Rd
+99bd0d94029e9d7d6001a1df89f57389 *man/scglrCrossVal.Rd
+64a6acc2dfca6474d1978b4079eaf254 *man/summary.SCGLR.Rd
 3088a2c384aac3c5287caca92e3cbf07 *vignettes/bibScglr.bib
-4aa5072089942458487d6da7821228b7 *vignettes/scglrVignettes.rnw
+0e57f56782f8048a2cf81a46c20af774 *vignettes/scglrVignettes.rnw

NAMESPACE

@@ -1,4 +1,4 @@
-# Generated by roxygen2 (4.0.2): do not edit by hand
+# Generated by roxygen2 (4.1.0): do not edit by hand
 
 S3method(barplot,SCGLR)
 S3method(pairs,SCGLR)
@@ -17,9 +17,9 @@ export(multivariatePredictGlm)
 export(scglr)
 export(scglrCrossVal)
 import(Formula)
-import(ROCR)
 import(expm)
 import(ggplot2)
 import(grid)
+import(pROC)
 importFrom(Matrix,bdiag)
 importFrom(graphics,barplot)

NEWS

@@ -1,3 +1,6 @@
+* version 2.0.2
+- fix bug in component optimization
+
 * version 2.0.1
 - performance improvement
 - fix compatibility of vignette source with knitr 1.7

R/critConvergence.r

@@ -11,4 +11,4 @@ critConvergence <- function (tol = 1e-6, maxit = 50) {
   if (!is.numeric(maxit) || maxit <= 0) 
     stop("maximum number of iterations must be > 0")
   list(tol = tol, maxit = maxit)
-}
+}

R/customize.r

@@ -66,4 +66,4 @@
 #' myStyle <- list(predictors=TRUE, pred.arrows=FALSE)
 #' plot(genus.scglr, style=myStyle)
 #' }
-NULL
+NULL

R/data.r

@@ -12,7 +12,7 @@
 #'  14 physical factors were used pertaining the description of topography, geology and rainfall 
 #'  of each plot. Vegetation is characterized through 16-days enhanced vegetation index (EVI) data.
 #' @references S. Gourlet-Fleury et al. (2009--2014) CoForChange project: \url{http://www.coforchange.eu/}
-#' @references C. Garcia et al. (2013--2015) CoForTips project: \url{http://www.fordev.ethz.ch/research/active/CoForTips}
+#' @references C. Garcia et al. (2013--2015) CoForTips project: \url{http://www.cofortips.org/}
 #' @format
 #' \tabular{ll}{
 #'    \code{gen1 to gen27} \tab abundance of the 27 common genera.\cr

R/infoCriterion.r

@@ -25,26 +25,26 @@ infoCriterion <- function(ynew,pred,family,type,size=NULL,npar=0) {
   res <- rep(0,ny)
  # success <- ynew
   if(sum("bernoulli" %in% family)>0) {
-    tmpy <- ynew[,which(family %in% "bernoulli"),drop=F]
-    tmpp <- pred[,which(family %in% "bernoulli"),drop=F]
+    tmpy <- ynew[,which(family %in% "bernoulli"),drop=FALSE]
+    tmpp <- pred[,which(family %in% "bernoulli"),drop=FALSE]
     if(type=="mspe") {
       ldber <- apply((tmpy-tmpp)^2/(tmpp*(1-tmpp)),2,mean)
     } else {
-      ldber <- -2*apply(dbinom(tmpy,1,tmpp,log=T),2,sum)
+      ldber <- -2*apply(dbinom(tmpy,1,tmpp,log=TRUE),2,sum)
     }
     res[which(family=="bernoulli")] <- ldber
     success <- NULL
   } else {
     ldber=0
   }
   if(sum("binomial" %in% family)>0) {
-    tmpy <- ynew[,which(family %in% "binomial"),drop=F]*size
-    tmpp <- pred[,which(family %in% "binomial"),drop=F]
+    tmpy <- ynew[,which(family %in% "binomial"),drop=FALSE]*size
+    tmpp <- pred[,which(family %in% "binomial"),drop=FALSE]
 
     if(type=="mspe"){
       ldbin <-  apply((tmpy-tmpp)^2/(tmpp*(1-tmpp)*size),2,mean)
     } else {
-      ldbin <- -2*apply(dbinom(tmpy,size,tmpp,log=T),2,sum)
+      ldbin <- -2*apply(dbinom(tmpy,size,tmpp,log=TRUE),2,sum)
     }
     success <- NULL
     res[which(family=="binomial")] <- ldbin
@@ -53,12 +53,12 @@ infoCriterion <- function(ynew,pred,family,type,size=NULL,npar=0) {
   }
 
   if(sum("poisson"%in%family)>0){
-    tmpy <- ynew[,which(family%in%"poisson"),drop=F]
-    tmpp <- pred[,which(family%in%"poisson"),drop=F]
+    tmpy <- ynew[,which(family%in%"poisson"),drop=FALSE]
+    tmpp <- pred[,which(family%in%"poisson"),drop=FALSE]
     if(type=="mspe"){
       ldpois <- apply((tmpy-tmpp)^2/tmpp,2,mean)#/tmpp
     } else {
-      ldpois <- -2*apply(dpois(tmpy,tmpp,log=T),2,sum)
+      ldpois <- -2*apply(dpois(tmpy,tmpp,log=TRUE),2,sum)
     }
 
     #lower <- (tmpp-alpha*sqrt(tmpp))
@@ -72,13 +72,13 @@ infoCriterion <- function(ynew,pred,family,type,size=NULL,npar=0) {
   }
 
   if(sum("gaussian"%in%family)>0){
-    tmpy <- ynew[,which(family%in%"gaussian"),drop=F]
-    tmpp <- pred[,which(family%in%"gaussian"),drop=F]   
+    tmpy <- ynew[,which(family%in%"gaussian"),drop=FALSE]
+    tmpp <- pred[,which(family%in%"gaussian"),drop=FALSE]   
     if(type=="mspe"){
       ldgaus <- apply((tmpy-tmpp)^2/tmpp,2,sum)
     } else {
-      sd <- matrix(sqrt(apply((tmpy-tmpp)^2,2,mean)),nobs,ny,byrow=T)
-      ldgaus <- -2*apply(dnorm(tmpy,tmpp,tmpp,log=T),2,sum)##à corriger
+      sd <- matrix(sqrt(apply((tmpy-tmpp)^2,2,mean)),nobs,ny,byrow=TRUE)
+      ldgaus <- -2*apply(dnorm(tmpy,tmpp,tmpp,log=TRUE),2,sum)##a corriger
     }
     #sd <- matrix(sqrt(apply((tmpy-tmpp)^2,2,mean)),nobs,ny,byrow=T)
     #success[,which(family%in%"gaussian")] <- (tmpy>=(tmpp-alpha*sqrt(sd)))&(tmpy<=(tmpp+alpha*sqrt(sd))) 
@@ -89,4 +89,4 @@ infoCriterion <- function(ynew,pred,family,type,size=NULL,npar=0) {
   #success <- apply(success,2,mean)
   #return(list(out=res+pen,success=success))  
  return(res+pen)
-}
+}

R/ingUtils.r

@@ -40,7 +40,6 @@ updateGamma <- function(Z,X,AX,W,gamma,method){
 }
 
 
-
 hFunct<- function(z,X,AX,W,u,method)
 {
   #dim(W)=n*q
@@ -59,7 +58,7 @@ hFunct<- function(z,X,AX,W,u,method)
       # Pi_{T^ortho} Xu = Pi_{T^ortho} f 
       projWkforthoAX <- f - projWkfAX  
       #Pi_T z_k verif AX%*%solve(t(AX)%*%diag(W[,k])%*%AX,t(AX)%*%diag(W[,k])%*%z[,k])
-      #z W_k centrés-réduit
+      #z W_k standardized
       zk <- wtScale(z[,k],W[,k])#z[,k] - sum(W[,k]*z[,k])
       Wzk <- W[,k]*zk
       projWkzAX <- AX%*%solve(AXtWkAX,crossprod(AX,Wzk))      
@@ -69,7 +68,7 @@ hFunct<- function(z,X,AX,W,u,method)
       scalsqpfz <- sum(c(projWkforthoAX)*Wzk)^2#<Pi_{T^{ortho}}Xu|z_k>^2_{W_k} verif  (t(projWkforthoAX)%*%diag(W[,k])%*%z[,k])^2
       scalsqpfpf <- sum(c(projWkforthoAX)^2*W[,k])#||Pi_{T^{ortho}}Xu||_{W_k}^2    
       #term1psi <- sum(scalsqpfz/(scalsqpfpf*scalsqzz[k]))
-      ##comme z[,k] est W[,k] centré-réduit, le terme scalsqzz[k] disparait
+      ##comme z[,k] est W[,k] standardized, le terme scalsqzz[k] disparait
       term1psi <- sum(scalsqpfz/(scalsqpfpf))
       term2psi <- sum(Wzk*projWkzAX)
       psi <- psi+term1psi+term2psi     
@@ -81,10 +80,12 @@ hFunct<- function(z,X,AX,W,u,method)
 
       WprojWkOrthof <- W[,k]*projWkforthoAX#W_k Pi_{T^{ortho}}Xu
       ##verif diag(W[,k])%*%projWkforthoAX
-      PiorthoPrimeWkf <- WprojWkOrthof-W[,k]*AX%*%solve(AXtWkAX,crossprod(AX,WprojWkOrthof))#Pi_{T^{ortho}}^primeW_k\pi_{T^{ortho}}Xu
+      # PiorthoPrimeWkf <- WprojWkOrthof-W[,k]*AX%*%solve(AXtWkAX,crossprod(AX,WprojWkOrthof))#Pi_{T^{ortho}}^primeW_k\pi_{T^{ortho}}Xu
+
       ##verif cf  PiorthoPrimeWkz
       #term2 <-  scalsqpfz*c(crossprod(X,PiorthoPrimeWkf))/(scalsqpfpf^2*scalsqzz[k])  
-      term2 <-  scalsqpfz*c(crossprod(X,PiorthoPrimeWkf))/(scalsqpfpf^2)  
+
+      term2 <-  scalsqpfz*c(crossprod(X,WprojWkOrthof))/(scalsqpfpf^2)  
       gradpsi <- gradpsi +(term1-term2)
     }
     gradpsi <- 2*gradpsi
@@ -99,33 +100,32 @@ hFunct<- function(z,X,AX,W,u,method)
       #calcul de grad de psi     
       XprimeWz <- crossprod(X,Wzk) #X'W_k z_k
       term1 <- c(XprimeWz%*%crossprod(XprimeWz,u))/(scalsqpfpf)
-
-
       term2 <-  scalsqpfz*c(crossprod(X,W[,k]*f))/(scalsqpfpf^2)  
       gradpsi <- gradpsi +(term1-term2)
     }
+    gradpsi <- 2*gradpsi
   }
   n <- nrow(X)    
   # calcul phi Component Variance: cv
   if(method$phi=="cv") {
-    phi <- c(crossprod(f))    
+    phi <- c(crossprod(f))/n    
     # calcul grad phi
     gradphi <- c(2*crossprod(X,f/n))
   } else { 
     ### autre calcul de phi avec l>=1 : vpi: Variable Powered Inertia
     scalsqfX <- colSums(f*X/n)
+    XtWX <- crossprod(X)/n
     phi <- (sum((scalsqfX^2)^method$l))^(1/method$l)    
     # calcul de grad phi
-    term1 <- (scalsqfX^2)^(method$l-1)
-    term2 <- scalsqfX * crossprod(X)
-    gradphi <- (2*method$l*colSums(term2%*%diag(term1)))*phi^(1/method$l-1)
+    gradphi <- 2*phi^(1-method$l)*rowSums(XtWX%*%diag(scalsqfX)^(2*method$l-1))
   }
   # calcul de h (s in R+)
   #h = log(psi)+method$s*log(phi)
   #gradh=gradpsi/psi+method$s*gradphi/phi
   # calcul de h (s in [0..1])
   h = (1-method$s)*log(psi)+method$s*log(phi)
   gradh=(1-method$s)*gradpsi/psi+method$s*gradphi/phi    
-
-  return(list(h=h, gradh=gradh))
+  return(list(h=h, gradh=gradh,psi=psi,gradpsi=gradpsi,phi=phi,gradphi=gradphi))
 }
+
+

R/methods.r

@@ -52,4 +52,4 @@ methodSR <- function(phi="vpi",l=1,s=1/2,maxiter=1000,epsilon=1e-6,bailout=10) {
   class="method.SCGLR",
   description="Method iterative normed gradient (ING) for Structural Relevance"
   )
-}
+}

R/metric.r

@@ -21,4 +21,4 @@ metric <- function(data){
   z <- svd(z)
   z <- z$u%*%diag(1/sqrt(z$d))%*%t(z$v)
   return(z)
-}
+}

R/multivariateFormula.r

@@ -19,4 +19,4 @@ multivariateFormula <- function(namesY,namesX,namesAX=NULL)
   formula <- as.Formula(paste(form_lhs, "~", form_rhs, sep=""))
   environment(formula) <- .GlobalEnv
   return(formula)
-}
+}

R/multivariateGlm.r

@@ -32,7 +32,7 @@
 #' form <- multivariateFormula(ny,c(nx,"I(lat*lon)"),c("geology"))
 #' 
 #' # split genus dataset
-#' sub <- sample(1:nrow(genus),100,replace=F)
+#' sub <- sample(1:nrow(genus),100,replace=FALSE)
 #' sub_fit <- (1:nrow(genus))[-sub]
 #' 
 #' # define family 
@@ -99,8 +99,8 @@ multivariateGlm<-  function(formula,data,family,size=NULL,offset=NULL,subset=NUL
   vnames <- names(x)
   fTypes <- sapply(x,is.factor)
   if(sum(fTypes)>0){
-    xFactors <- x[,fTypes,drop=F]
-    colnames(xFactors) <- colnames(x[,fTypes,drop=F])
+    xFactors <- x[,fTypes,drop=FALSE]
+    colnames(xFactors) <- colnames(x[,fTypes,drop=FALSE])
   }else{
     xFactors <- NULL
   }
@@ -157,4 +157,4 @@ multivariateGlm<-  function(formula,data,family,size=NULL,offset=NULL,subset=NUL
   }
 
   return(gamma.fit)
-}
+}