[Robast-commits] r691 - branches/robast-0.9/pkg/ROptEst/R branches/robast-0.9/pkg/RobAStBase/R branches/robast-0.9/pkg/RobAStBase/tests branches/robast-0.9/pkg/RobExtremes/R pkg/RandVar pkg/RandVar/inst pkg/RandVar/man pkg/RobAStBase pkg/RobAStBase/R pkg/RobAStBase/inst pkg/RobAStBase/man pkg/RobAStBase/tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Sep 11 16:07:53 CEST 2013
Author: ruckdeschel
Date: 2013-09-11 16:07:52 +0200 (Wed, 11 Sep 2013)
New Revision: 691
Added:
pkg/RandVar/.Rbuildignore
pkg/RobAStBase/.Rbuildignore
pkg/RobAStBase/R/00internal.R
pkg/RobAStBase/RobAStBase-Ex.R
pkg/RobAStBase/inst/unitTests/
pkg/RobAStBase/man/ComparePlotWrapper.Rd
pkg/RobAStBase/man/InfoPlotWrapper.Rd
pkg/RobAStBase/man/PlotICWrapper.Rd
pkg/RobAStBase/man/internal_plots.Rd
pkg/RobAStBase/man/mergelists.Rd
pkg/RobAStBase/man/rescaleFunction-methods.Rd
pkg/RobAStBase/tests/doRUnit.R
Removed:
pkg/RobAStBase/chm/
Modified:
branches/robast-0.9/pkg/ROptEst/R/00internal.R
branches/robast-0.9/pkg/RobAStBase/R/00internal.R
branches/robast-0.9/pkg/RobAStBase/tests/doRUnit.R
branches/robast-0.9/pkg/RobExtremes/R/LDEstimator.R
pkg/RandVar/DESCRIPTION
pkg/RandVar/inst/NEWS
pkg/RandVar/man/0RandVar-package.Rd
pkg/RobAStBase/DESCRIPTION
pkg/RobAStBase/NAMESPACE
pkg/RobAStBase/R/AllClass.R
pkg/RobAStBase/R/AllGeneric.R
pkg/RobAStBase/R/AllPlot.R
pkg/RobAStBase/R/bALEstimate.R
pkg/RobAStBase/R/comparePlot.R
pkg/RobAStBase/inst/NEWS
pkg/RobAStBase/man/0RobAStBase-package.Rd
pkg/RobAStBase/man/InfluenceCurve-class.Rd
pkg/RobAStBase/man/comparePlot.Rd
pkg/RobAStBase/man/cutoff.Rd
pkg/RobAStBase/man/ddPlot-methods.Rd
pkg/RobAStBase/man/infoPlot.Rd
pkg/RobAStBase/man/internals.Rd
pkg/RobAStBase/man/internals_ddPlot.Rd
pkg/RobAStBase/man/kStepEstimator.Rd
pkg/RobAStBase/man/makeIC-methods.Rd
pkg/RobAStBase/man/outlyingPlotIC.Rd
pkg/RobAStBase/man/plot-methods.Rd
Log:
RandVar und RobAStBase 0.9 in trunk gemerge-t
Modified: branches/robast-0.9/pkg/ROptEst/R/00internal.R
===================================================================
--- branches/robast-0.9/pkg/ROptEst/R/00internal.R 2013-09-11 08:56:09 UTC (rev 690)
+++ branches/robast-0.9/pkg/ROptEst/R/00internal.R 2013-09-11 14:07:52 UTC (rev 691)
@@ -5,3 +5,21 @@
.SelectOrderData <- RobAStBase:::.SelectOrderData
### helper function to recursively evaluate list
.evalListRec <- RobAStBase:::.evalListRec
+
+
+if(packageVersion("distrMod")<"2.5"){
+.isUnitMatrix <- function(m){
+### checks whether m is unit matrix
+ m.row <- nrow(m)
+ isTRUE(all.equal(m, diag(m.row), check.attributes = FALSE))
+ }
+
+.deleteDim <- function(x){
+ attribs <- attributes(x)
+ attribs$dim <- NULL
+ attribs$dimnames <- NULL
+ attributes(x) <- attribs
+ x
+ }
+
+}
Modified: branches/robast-0.9/pkg/RobAStBase/R/00internal.R
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/R/00internal.R 2013-09-11 08:56:09 UTC (rev 690)
+++ branches/robast-0.9/pkg/RobAStBase/R/00internal.R 2013-09-11 14:07:52 UTC (rev 691)
@@ -6,3 +6,125 @@
paste(format(100 * probs, trim = TRUE, scientific = FALSE, digits = digits),
"%")
+#------------------------------------------------------------------------------
+### for distrXXX pre 2.5
+#------------------------------------------------------------------------------
+
+
+if(packageVersion("distr")<"2.5"){
+
+.inArgs <- function(arg, fct)
+ {as.character(arg) %in% names(formals(fct))}
+
+.fillList <- function(list0, len = length(list0)){
+ if(len == length(list0))
+ return(list0)
+ i <- 0
+ ll0 <- length(list0)
+ li0 <- vector("list",len)
+ if(ll0)
+ while(i < len){
+ j <- 1 + ( i %% ll0)
+ i <- i + 1
+ li0[[i]] <- list0[[j]]
+ }
+ return(li0)
+}
+
+.ULC.cast <- function(x){
+ if( is(x,"AbscontDistribution"))
+ x <- as(as(x,"AbscontDistribution"), "UnivarLebDecDistribution")
+ if(is(x,"DiscreteDistribution"))
+ x <- as(as(x,"DiscreteDistribution"), "UnivarLebDecDistribution")
+ if(!is(x,"UnivarLebDecDistribution"))
+ x <- as(x,"UnivarLebDecDistribution")
+ return(x)
+}
+
+.isEqual <- function(p0, p1, tol = min( getdistrOption("TruncQuantile")/2,
+ .Machine$double.eps^.7
+ ))
+ abs(p0-p1)< tol
+
+.isIn <- function(p0, pmat, tol = min( getdistrOption("TruncQuantile")/2,
+ .Machine$double.eps^.7
+ ))
+ {list1 <- lapply(1:nrow(pmat), function(x){
+ (p0+tol > pmat[x,1]) & (p0-tol < pmat[x,2]) })
+ apply(matrix(unlist(list1), ncol = nrow(pmat)), 1, any)}
+
+
+.isEqual01<- function(x) .isEqual(x,0)|.isEqual(x,1)
+
+.presubs <- function(inp, frompat, topat){
+### replaces in an expression or a string all frompat patterns to topat patterns
+
+logic <- FALSE
+inCx <- sapply(inp,
+ function(inpx){
+ inC <- deparse(inpx)
+ l <- length(frompat)
+ for(i in 1:l)
+ { if (is.language(topat[[i]])){
+ totxt <- deparse(topat[[i]])
+ totxt <- gsub("expression\\(", "\", ", gsub("\\)$",", \"",totxt))
+ if (length(grep(frompat[i],inC))) logic <<- TRUE
+ inC <- gsub(frompat[i],totxt,inC)
+ }else inC <- gsub(frompat[i], topat[[i]], inC)
+ }
+ return(inC)
+ })
+if(length(grep("expression",inCx))>0)
+ inCx <- gsub("expression\\(", "", gsub("\\)$","",inCx))
+if (length(inCx) > 1) {
+ inCx <- paste(inCx, c(rep(",", length(inCx)-1), ""),
+ sep = "", collapse = "\"\\n\",")
+ if ( any(as.logical(c(lapply(inp,is.language)))) | logic )
+ inCx <- paste("expression(paste(", gsub("\\\\n"," ", inCx), "))", sep ="")
+ else
+ inCx <- paste("paste(",inCx,")", sep ="")
+}else inCx <- paste("expression(paste(",inCx,"))",sep="")
+outC <- eval(parse(text = eval(inCx)))
+return(outC)
+}
+
+.DistrCollapse <- function(support, prob,
+ eps = getdistrOption("DistrResolution")){
+ supp <- support
+ prob <- as.vector(prob)
+ suppIncr <- diff(c(supp[1]-2*eps,supp)) < eps
+ groups <- cumsum(!suppIncr)
+ prob <- as.vector(tapply(prob, groups, sum))
+ supp <- as.vector(tapply(supp, groups, quantile, probs = 0.5, type = 1))
+ ### in order to get a "support member" take the leftmost median
+ return(list(supp = supp, prob = prob))
+# newDistribution <- DiscreteDistribution(supp=supp,prob=prob)
+# return(newDistribution)
+}
+
+.makeLenAndOrder <- function(x,ord){
+ n <- length(ord)
+ x <- rep(x, length.out=n)
+ x[ord]
+}
+
+}
+
+if(packageVersion("distrMod")<"2.5"){
+.isUnitMatrix <- function(m){
+### checks whether m is unit matrix
+ m.row <- nrow(m)
+ isTRUE(all.equal(m, diag(m.row), check.attributes = FALSE))
+ }
+
+.deleteDim <- function(x){
+ attribs <- attributes(x)
+ attribs$dim <- NULL
+ attribs$dimnames <- NULL
+ attributes(x) <- attribs
+ x
+ }
+
+}
+
+
Modified: branches/robast-0.9/pkg/RobAStBase/tests/doRUnit.R
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/tests/doRUnit.R 2013-09-11 08:56:09 UTC (rev 690)
+++ branches/robast-0.9/pkg/RobAStBase/tests/doRUnit.R 2013-09-11 14:07:52 UTC (rev 691)
@@ -3,7 +3,7 @@
## --- Setup ---
- pkg <- "RobExtremes"
+ pkg <- "RobAStBase"
if((Sys.getenv("RCMDCHECK") == "")
|| (Sys.getenv("RCMDCHECK") == "FALSE")) {
Modified: branches/robast-0.9/pkg/RobExtremes/R/LDEstimator.R
===================================================================
--- branches/robast-0.9/pkg/RobExtremes/R/LDEstimator.R 2013-09-11 08:56:09 UTC (rev 690)
+++ branches/robast-0.9/pkg/RobExtremes/R/LDEstimator.R 2013-09-11 14:07:52 UTC (rev 691)
@@ -53,7 +53,9 @@
if(vdbg) print(val)
return(val)
}
- xi.0 <- uniroot(q.f,lower=q.lo.0,upper=q.up.0)$root
+ xi.01 <- try(uniroot(q.f,lower=q.lo.0,upper=q.up.0), silent=TRUE)
+ if(is(xi.01, "try-error")) stop("Error in calculating LD-estimator: 'uniroot' did not converge.")
+ xi.0 <- xi.01$root
th0 <- c(1,xi.0)
names(th0) <- c("scale","shape")
distr.new.0 <- ParamFamily.0 at modifyParam(theta=th0)-loc0
Added: pkg/RandVar/.Rbuildignore
===================================================================
--- pkg/RandVar/.Rbuildignore (rev 0)
+++ pkg/RandVar/.Rbuildignore 2013-09-11 14:07:52 UTC (rev 691)
@@ -0,0 +1,3 @@
+^.*\.svn.+
+inst/doc/Rplots.pdf
+.*-Ex\.R
\ No newline at end of file
Modified: pkg/RandVar/DESCRIPTION
===================================================================
--- pkg/RandVar/DESCRIPTION 2013-09-11 08:56:09 UTC (rev 690)
+++ pkg/RandVar/DESCRIPTION 2013-09-11 14:07:52 UTC (rev 691)
@@ -1,9 +1,9 @@
Package: RandVar
-Version: 0.9.1
-Date: 2013-02-08
+Version: 0.9.2
+Date: 2013-09-11
Title: Implementation of random variables
Description: Implementation of random variables by means of S4 classes and methods
-Depends: R (>= 2.14.0), methods, startupmsg, distr(>= 2.0), distrEx(>= 2.0)
+Depends: R (>= 2.14.0), methods, distr(>= 2.0), distrEx(>= 2.0)
Author: Matthias Kohl, Peter Ruckdeschel
Maintainer: Matthias Kohl <Matthias.Kohl at stamats.de>
ByteCompile: yes
@@ -13,4 +13,4 @@
URL: http://robast.r-forge.r-project.org/
LastChangedDate: {$LastChangedDate$}
LastChangedRevision: {$LastChangedRevision$}
-SVNRevision: 591
+SVNRevision: 690
Modified: pkg/RandVar/inst/NEWS
===================================================================
--- pkg/RandVar/inst/NEWS 2013-09-11 08:56:09 UTC (rev 690)
+++ pkg/RandVar/inst/NEWS 2013-09-11 14:07:52 UTC (rev 691)
@@ -10,7 +10,23 @@
#######################################
version 0.9
#######################################
+
+user-visible CHANGES:
+
+GENERAL ENHANCEMENTS:
++ cleaned DESCRIPTION and NAMESPACE file as to Imports/Depends
+
+under the hood:
+
++ added .Rbuildignore
+ introduced folder vignettes
++ some encoding problems with vignette which now includes "\usepackage[utf8]{inputenc}"
++ update of Rout.save files, added seed for reproducibility
++ suppressed gaps handling and warnings from .makeDNew (annoying with GEVD) in .getImageDistr
++ deleted chm folders --- they are no longer needed
++ RobASt-Pkgs: DESCRIPTION depends become stricter (requiring distrMod, distrEx, distr >=2.4 to be on the safe side)
+
+BUGFIXES
#######################################
Modified: pkg/RandVar/man/0RandVar-package.Rd
===================================================================
--- pkg/RandVar/man/0RandVar-package.Rd 2013-09-11 08:56:09 UTC (rev 690)
+++ pkg/RandVar/man/0RandVar-package.Rd 2013-09-11 14:07:52 UTC (rev 691)
@@ -11,14 +11,14 @@
\details{
\tabular{ll}{
Package: \tab RandVar \cr
-Version: \tab 0.9.1 \cr
-Date: \tab 2013-02-08 \cr
+Version: \tab 0.9.2 \cr
+Date: \tab 2013-09-11 \cr
Depends: \tab R (>= 2.12.0), methods, startupmsg, distr(>= 2.0), distrEx(>=
2.0)\cr
LazyLoad: \tab yes \cr
License: \tab LGPL-3 \cr
URL: \tab http://robast.r-forge.r-project.org/\cr
-SVNRevision: \tab 591 \cr
+SVNRevision: \tab 690 \cr
}
}
\author{
Added: pkg/RobAStBase/.Rbuildignore
===================================================================
--- pkg/RobAStBase/.Rbuildignore (rev 0)
+++ pkg/RobAStBase/.Rbuildignore 2013-09-11 14:07:52 UTC (rev 691)
@@ -0,0 +1,3 @@
+^.*\.svn.+
+inst/doc/Rplots.pdf
+.*-Ex\.R
\ No newline at end of file
Modified: pkg/RobAStBase/DESCRIPTION
===================================================================
--- pkg/RobAStBase/DESCRIPTION 2013-09-11 08:56:09 UTC (rev 690)
+++ pkg/RobAStBase/DESCRIPTION 2013-09-11 14:07:52 UTC (rev 691)
@@ -1,11 +1,10 @@
Package: RobAStBase
-Version: 0.8.1
-Date: 2011-09-30
+Version: 0.9
+Date: 2013-09-11
Title: Robust Asymptotic Statistics
Description: Base S4-classes and functions for robust asymptotic statistics.
-Depends: R(>= 2.7.0), methods, distr(>= 2.0), distrEx(>= 2.0), distrMod(>= 2.0), RandVar(>=
- 0.6.3)
-Suggests: ROptEst
+Depends: R(>= 2.12.0), methods, rrcov, distr(>= 2.4), distrEx(>= 2.4), distrMod(>= 2.4), RandVar(>= 0.6.3)
+Suggests: ROptEst, RUnit (>= 0.4.26)
Author: Matthias Kohl, Peter Ruckdeschel
Maintainer: Matthias Kohl <Matthias.Kohl at stamats.de>
ByteCompile: yes
@@ -15,4 +14,4 @@
URL: http://robast.r-forge.r-project.org/
LastChangedDate: {$LastChangedDate$}
LastChangedRevision: {$LastChangedRevision$}
-SVNRevision: 454
+SVNRevision: 690
Modified: pkg/RobAStBase/NAMESPACE
===================================================================
--- pkg/RobAStBase/NAMESPACE 2013-09-11 08:56:09 UTC (rev 690)
+++ pkg/RobAStBase/NAMESPACE 2013-09-11 14:07:52 UTC (rev 691)
@@ -1,4 +1,5 @@
import("methods")
+importFrom("rrcov", "getCov", "CovMcd")
import("distr")
import("distrEx")
import("distrMod")
@@ -19,6 +20,7 @@
"BdStWeight", "HampelWeight")
exportClasses("ALEstimate", "kStepEstimate", "MEstimate")
exportClasses("cutoff")
+exportClasses("interpolRisk", "OMSRRisk","MBRRisk","RMXRRisk")
exportClasses("StartClass", "pICList", "OptionalpICList")
exportMethods("show",
"plot")
@@ -57,8 +59,13 @@
"Mroot","kStepEstimator.start")
exportMethods("pICList","ICList", "ksteps", "uksteps",
"start", "startval", "ustartval")
+exportMethods("moveL2Fam2RefParam",
+ "moveICBackFromRefParam",
+ "rescaleFunction")
exportMethods("ddPlot", "qqplot")
exportMethods("cutoff.quantile", "cutoff.quantile<-")
+exportMethods("samplesize<-", "samplesize")
+exportMethods("getRiskFctBV")
export("oneStepEstimator", "kStepEstimator")
export("ContNeighborhood", "TotalVarNeighborhood")
export("FixRobModel", "InfRobModel")
@@ -67,3 +74,8 @@
export("RobAStBaseOptions", "getRobAStBaseOption")
export("cutoff","cutoff.chisq","cutoff.sememp")
export("outlyingPlotIC", "RobAStBaseMASK")
+export("OMSRRisk","MBRRisk","RMXRRisk")
+export("getRiskFctBV")
+export(".rescalefct",".plotRescaledAxis",".makedotsP",".makedotsLowLevel",".SelectOrderData")
+export(".merge.lists")
+export("InfoPlot", "ComparePlot", "PlotIC")
\ No newline at end of file
Added: pkg/RobAStBase/R/00internal.R
===================================================================
--- pkg/RobAStBase/R/00internal.R (rev 0)
+++ pkg/RobAStBase/R/00internal.R 2013-09-11 14:07:52 UTC (rev 691)
@@ -0,0 +1,130 @@
+#------------------------------------------------------------------------------
+# .format.perc : for formatting percentages
+#------------------------------------------------------------------------------
+### code borrowed from non-exported code from confint.default from package stats
+.format.perc <- function (probs, digits)
+ paste(format(100 * probs, trim = TRUE, scientific = FALSE, digits = digits),
+ "%")
+
+#------------------------------------------------------------------------------
+### for distrXXX pre 2.5
+#------------------------------------------------------------------------------
+
+
+if(packageVersion("distr")<"2.5"){
+
+.inArgs <- function(arg, fct)
+ {as.character(arg) %in% names(formals(fct))}
+
+.fillList <- function(list0, len = length(list0)){
+ if(len == length(list0))
+ return(list0)
+ i <- 0
+ ll0 <- length(list0)
+ li0 <- vector("list",len)
+ if(ll0)
+ while(i < len){
+ j <- 1 + ( i %% ll0)
+ i <- i + 1
+ li0[[i]] <- list0[[j]]
+ }
+ return(li0)
+}
+
+.ULC.cast <- function(x){
+ if( is(x,"AbscontDistribution"))
+ x <- as(as(x,"AbscontDistribution"), "UnivarLebDecDistribution")
+ if(is(x,"DiscreteDistribution"))
+ x <- as(as(x,"DiscreteDistribution"), "UnivarLebDecDistribution")
+ if(!is(x,"UnivarLebDecDistribution"))
+ x <- as(x,"UnivarLebDecDistribution")
+ return(x)
+}
+
+.isEqual <- function(p0, p1, tol = min( getdistrOption("TruncQuantile")/2,
+ .Machine$double.eps^.7
+ ))
+ abs(p0-p1)< tol
+
+.isIn <- function(p0, pmat, tol = min( getdistrOption("TruncQuantile")/2,
+ .Machine$double.eps^.7
+ ))
+ {list1 <- lapply(1:nrow(pmat), function(x){
+ (p0+tol > pmat[x,1]) & (p0-tol < pmat[x,2]) })
+ apply(matrix(unlist(list1), ncol = nrow(pmat)), 1, any)}
+
+
+.isEqual01<- function(x) .isEqual(x,0)|.isEqual(x,1)
+
+.presubs <- function(inp, frompat, topat){
+### replaces in an expression or a string all frompat patterns to topat patterns
+
+logic <- FALSE
+inCx <- sapply(inp,
+ function(inpx){
+ inC <- deparse(inpx)
+ l <- length(frompat)
+ for(i in 1:l)
+ { if (is.language(topat[[i]])){
+ totxt <- deparse(topat[[i]])
+ totxt <- gsub("expression\\(", "\", ", gsub("\\)$",", \"",totxt))
+ if (length(grep(frompat[i],inC))) logic <<- TRUE
+ inC <- gsub(frompat[i],totxt,inC)
+ }else inC <- gsub(frompat[i], topat[[i]], inC)
+ }
+ return(inC)
+ })
+if(length(grep("expression",inCx))>0)
+ inCx <- gsub("expression\\(", "", gsub("\\)$","",inCx))
+if (length(inCx) > 1) {
+ inCx <- paste(inCx, c(rep(",", length(inCx)-1), ""),
+ sep = "", collapse = "\"\\n\",")
+ if ( any(as.logical(c(lapply(inp,is.language)))) | logic )
+ inCx <- paste("expression(paste(", gsub("\\\\n"," ", inCx), "))", sep ="")
+ else
+ inCx <- paste("paste(",inCx,")", sep ="")
+}else inCx <- paste("expression(paste(",inCx,"))",sep="")
+outC <- eval(parse(text = eval(inCx)))
+return(outC)
+}
+
+.DistrCollapse <- function(support, prob,
+ eps = getdistrOption("DistrResolution")){
+ supp <- support
+ prob <- as.vector(prob)
+ suppIncr <- diff(c(supp[1]-2*eps,supp)) < eps
+ groups <- cumsum(!suppIncr)
+ prob <- as.vector(tapply(prob, groups, sum))
+ supp <- as.vector(tapply(supp, groups, quantile, probs = 0.5, type = 1))
+ ### in order to get a "support member" take the leftmost median
+ return(list(supp = supp, prob = prob))
+# newDistribution <- DiscreteDistribution(supp=supp,prob=prob)
+# return(newDistribution)
+}
+
+.makeLenAndOrder <- function(x,ord){
+ n <- length(ord)
+ x <- rep(x, length.out=n)
+ x[ord]
+}
+
+}
+
+if(packageVersion("distrMod")<"2.5"){
+.isUnitMatrix <- function(m){
+### checks whether m is unit matrix
+ m.row <- nrow(m)
+ isTRUE(all.equal(m, diag(m.row), check.attributes = FALSE))
+ }
+
+.deleteDim <- function(x){
+ attribs <- attributes(x)
+ attribs$dim <- NULL
+ attribs$dimnames <- NULL
+ attributes(x) <- attribs
+ x
+ }
+
+}
+
+
Modified: pkg/RobAStBase/R/AllClass.R
===================================================================
--- pkg/RobAStBase/R/AllClass.R 2013-09-11 08:56:09 UTC (rev 690)
+++ pkg/RobAStBase/R/AllClass.R 2013-09-11 14:07:52 UTC (rev 691)
@@ -312,3 +312,13 @@
prototype = prototype(name = "empirical",
fct = function(data) quantile(data),
cutoff.quantile = 0.95))
+
+
+#################################################
+# new risk classes
+#################################################
+setClass("interpolRisk", representation = representation(samplesize="numeric"),
+ contains = c("VIRTUAL", "RiskType"))
+setClass("OMSRRisk", contains = "interpolRisk", prototype=prototype(type=".OMSE", samplesize=100))
+setClass("RMXRRisk", contains = "interpolRisk", prototype=prototype(type=".RMXE", samplesize=100))
+setClass("MBRRisk", contains = "interpolRisk", prototype=prototype(type=".MBRE",samplesize=100))
Modified: pkg/RobAStBase/R/AllGeneric.R
===================================================================
--- pkg/RobAStBase/R/AllGeneric.R 2013-09-11 08:56:09 UTC (rev 690)
+++ pkg/RobAStBase/R/AllGeneric.R 2013-09-11 14:07:52 UTC (rev 691)
@@ -214,3 +214,29 @@
setGeneric("kStepEstimator.start",
function(start,...) standardGeneric("kStepEstimator.start"))
}
+if(!isGeneric("radius")){
+ setGeneric("radius", function(object) standardGeneric("radius"))
+}
+
+if(!isGeneric("samplesize<-")){
+ setGeneric("samplesize<-",
+ function(object, value) standardGeneric("samplesize<-"))
+}
+if(!isGeneric("getRiskFctBV")){
+ setGeneric("getRiskFctBV", function(risk, biastype) standardGeneric("getRiskFctBV"))
+}
+
+if(!isGeneric("moveL2Fam2RefParam")){
+ setGeneric("moveL2Fam2RefParam", function(L2Fam, ...)
+ standardGeneric("moveL2Fam2RefParam"))
+}
+
+if(!isGeneric("moveICBackFromRefParam")){
+ setGeneric("moveICBackFromRefParam", function(IC, L2Fam, ...)
+ standardGeneric("moveICBackFromRefParam"))
+}
+
+if(!isGeneric("rescaleFunction")){
+ setGeneric("rescaleFunction", function(L2Fam, ...)
+ standardGeneric("rescaleFunction"))
+}
Modified: pkg/RobAStBase/R/AllPlot.R
===================================================================
--- pkg/RobAStBase/R/AllPlot.R 2013-09-11 08:56:09 UTC (rev 690)
+++ pkg/RobAStBase/R/AllPlot.R 2013-09-11 14:07:52 UTC (rev 691)
@@ -1,26 +1,37 @@
setMethod("plot", signature(x = "IC", y = "missing"),
- function(x,...,withSweave = getdistrOption("withSweave"),
+ function(x, ...,withSweave = getdistrOption("withSweave"),
main = FALSE, inner = TRUE, sub = FALSE,
col.inner = par("col.main"), cex.inner = 0.8,
bmar = par("mar")[1], tmar = par("mar")[3],
+ with.legend = FALSE, legend = NULL, legend.bg = "white",
+ legend.location = "bottomright", legend.cex = 0.8,
+ withMBR = FALSE, MBRB = NA, MBR.fac = 2, col.MBR = par("col"),
+ lty.MBR = "dashed", lwd.MBR = 0.8,
+ scaleX = FALSE, scaleX.fct, scaleX.inv,
+ scaleY = FALSE, scaleY.fct = pnorm, scaleY.inv=qnorm,
+ scaleN = 9, x.ticks = NULL, y.ticks = NULL,
mfColRow = TRUE, to.draw.arg = NULL){
xc <- match.call(call = sys.call(sys.parent(1)))$x
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
+ dotsLeg <- dotsT <- dotsL <- .makedotsLowLevel(dots)
-
if(!is.logical(inner)){
if(!is.list(inner))
inner <- as.list(inner)
#stop("Argument 'inner' must either be 'logical' or a 'list'")
- inner <- distr:::.fillList(inner,4)
+ inner <- .fillList(inner,4)
innerD <- inner[1:3]
innerL <- inner[4]
}else{innerD <- innerL <- inner}
L2Fam <- eval(x at CallL2Fam)
+ if(missing(scaleX.fct)){
+ scaleX.fct <- p(L2Fam)
+ scaleX.inv <- q(L2Fam)
+ }
trafO <- trafo(L2Fam at param)
dims <- nrow(trafO)
@@ -39,7 +50,15 @@
nrows <- trunc(sqrt(dims0))
ncols <- ceiling(dims0/nrows)
+ if(!is.null(x.ticks)) dots$xaxt <- "n"
+ if(!is.null(y.ticks)){
+ y.ticks <- .fillList(list(y.ticks), dims0)
+ dots$yaxt <- "n"
+ }
+ MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T)
+ MBRB <- MBRB * MBR.fac
+
e1 <- L2Fam at distribution
if(!is(e1, "UnivariateDistribution")) stop("not yet implemented")
@@ -48,6 +67,9 @@
if(!is.null(xlim)){
xm <- min(xlim)
xM <- max(xlim)
+ if(!length(xlim) %in% c(2,2*dims0))
+ stop("Wrong length of Argument xlim");
+ xlim <- matrix(xlim, 2,dims0)
}
if(is(e1, "AbscontDistribution")){
lower0 <- getLow(e1, eps = getdistrOption("TruncQuantile")*2)
@@ -74,7 +96,7 @@
plty <- "p"
lty <- "dotted"
if(!is.null(dots$xlim)) x.vec <- x.vec[(x.vec>=xm) & (x.vec<=xM)]
-
+
}
}
ylim <- eval(dots$ylim)
@@ -87,8 +109,9 @@
if(!is.null(dots[["lty"]])) dots["lty"] <- NULL
if(!is.null(dots[["type"]])) dots["type"] <- NULL
- if(!is.null(dots[["xlab"]])) dots["xlab"] <- NULL
- if(!is.null(dots[["ylab"]])) dots["ylab"] <- NULL
+ xlab <- dots$xlab; if(is.null(xlab)) xlab <- "x"
+ ylab <- dots$ylab; if(is.null(ylab)) ylab <- "(partial) IC"
+ dots$xlab <- dots$ylab <- NULL
IC1 <- as(diag(dims) %*% x at Curve, "EuclRandVariable")
@@ -97,7 +120,7 @@
lineT <- NA
.mpresubs <- function(inx)
- distr:::.presubs(inx, c("%C", "%D", "%A"),
+ .presubs(inx, c("%C", "%D", "%A"),
c(as.character(class(x)[1]),
as.character(date()),
as.character(deparse(xc))))
@@ -162,14 +185,28 @@
}
}else{
innerT <- lapply(inner, .mpresubs)
- innerT <- distr:::.fillList(innerT,dims)
+ innerT <- .fillList(innerT,dims)
if(dims0<dims){
innerT0 <- innerT
for(i in 1:dims0) innerT[to.draw[i]] <- innerT0[i]
}
}
+ if(with.legend){
+ fac.leg <- if(dims0>1) 3/4 else .75/.8
+ if(missing(legend.location)){
+ legend.location <- .fillList(list("bottomright"), dims0)
+ }else{
+ legend.location <- as.list(legend.location)
+ legend.location <- .fillList(legend.location, dims0)
+ }
+ if(is.null(legend)){
+ legend <- vector("list",dims0)
+ legend <- .fillList(as.list(xc),dims0)
+ }
+ }
+
w0 <- getOption("warn")
options(warn = -1)
on.exit(options(warn = w0))
@@ -188,37 +225,64 @@
do.call(par,args=parArgs)
- dotsT <- dots
- dotsT["main"] <- NULL
- dotsT["cex.main"] <- NULL
- dotsT["col.main"] <- NULL
- dotsT["line"] <- NULL
+ dotsT["pch"] <- dotsT["cex"] <- NULL
+ dotsT["col"] <- dotsT["lwd"] <- NULL
+ dotsL["cex"] <- dotsLeg["bg"] <- dotsLeg["cex"] <- NULL
+ dots$ylim <- NULL
- dots$ylim <- NULL
for(i in 1:dims0){
indi <- to.draw[i]
if(!is.null(ylim)) dots$ylim <- ylim[,i]
- do.call(plot, args=c(list(x.vec, sapply(x.vec, IC1 at Map[[indi]]),
- type = plty, lty = lty,
- xlab = "x", ylab = "(partial) IC"),
- dots))
+ fct <- function(x) sapply(x, IC1 at Map[[indi]])
+ print(xlim[,i])
+ resc <-.rescalefct(x.vec, fct, scaleX, scaleX.fct,
+ scaleX.inv, scaleY, scaleY.fct, xlim[,i],
+ ylim[,i], dots)
+ dots <- resc$dots
+ dots$xlim <- xlim[,i]
+ dots$ylim <- ylim[,i]
+ x.vec1 <- resc$X
+ y.vec1 <- resc$Y
+ do.call(plot, args=c(list(x=x.vec1, y=y.vec1, type = plty, lty = lty,
+ xlab = xlab, ylab = ylab), dots))
+ .plotRescaledAxis(scaleX, scaleX.fct, scaleX.inv,
+ scaleY,scaleY.fct, scaleY.inv,
+ xlim[,i], ylim[,i], x.vec1, ypts = 400, n = scaleN,
+ x.ticks = x.ticks, y.ticks = y.ticks[[i]])
+ if(withMBR){
+ MBR.i <- MBRB[i,]
+ if(scaleY) MBR.i <- scaleY.fct(MBR.i)
+ abline(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR)
+ }
if(is(e1, "DiscreteDistribution")){
- x.vec1 <- seq(from = min(x.vec), to = max(x.vec), length = 1000)
- do.call(lines,args=c(list(x.vec1, sapply(x.vec1, IC1 at Map[[indi]]),
- lty = "dotted"), dots))
+ x.vec1D <- seq(from = min(x.vec), to = max(x.vec), length = 1000)
+ rescD <-.rescalefct(x.vec1D, fct, scaleX, scaleX.fct,
+ scaleX.inv, scaleY, scaleY.fct, xlim[,i],
+ ylim[,i], dots)
+ x.vecD <- rescD$X
+ y.vecD <- rescD$Y
+
+ dotsL$lty <- NULL
+ do.call(lines,args=c(list(x.vecD, y.vecD,
+ lty = "dotted"), dotsL))
}
do.call(title,args=c(list(main = innerT[indi]), dotsT, line = lineT,
cex.main = cex.inner, col.main = col.inner))
+ if(with.legend)
+ legend(.legendCoord(legend.location[[i]], scaleX, scaleX.fct,
+ scaleY, scaleY.fct), bg = legend.bg,
+ legend = legend[[i]], dotsLeg, cex = legend.cex*fac.leg)
+
}
- if(!hasArg(cex.main)) cex.main <- par("cex.main") else cex.main <- dots$"cex.main"
- if(!hasArg(col.main)) col.main <- par("col.main") else col.main <- dots$"col.main"
+ cex.main <- if(!hasArg(cex.main)) par("cex.main") else dots$"cex.main"
+ col.main <- if(!hasArg(col.main)) par("col.main") else dots$"col.main"
if (mainL)
mtext(text = main, side = 3, cex = cex.main, adj = .5,
outer = TRUE, padj = 1.4, col = col.main)
- if(!hasArg(cex.sub)) cex.sub <- par("cex.sub") else cex.sub <- dots$"cex.sub"
- if(!hasArg(col.sub)) col.sub <- par("col.sub") else col.sub <- dots$"col.sub"
+ cex.sub <- if(!hasArg(cex.sub)) par("cex.sub") else dots$"cex.sub"
+ col.sub <- if(!hasArg(col.sub)) par("col.sub") else dots$"col.sub"
if (subL)
mtext(text = sub, side = 1, cex = cex.sub, adj = .5,
outer = TRUE, line = -1.6, col = col.sub)
@@ -230,20 +294,15 @@
setMethod("plot", signature(x = "IC",y = "numeric"),
function(x, y, ..., cex.pts = 1, col.pts = par("col"),
pch.pts = 1, jitter.fac = 1, with.lab = FALSE,
- lab.pts = NULL, lab.font = NULL,
- which.lbs = NULL, which.Order = NULL, return.Order = FALSE){
+ lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
+ which.lbs = NULL, which.Order = NULL, return.Order = FALSE){
+
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
n <- if(!is.null(dim(y))) nrow(y) else length(y)
- oN0 <- NULL
- if(is.null(which.lbs))
- which.lbs <- 1:n
- which.lbs0 <- (1:n) %in% which.lbs
- which.lbx <- rep(which.lbs0, length.out=length(y))
- y0 <- y[which.lbx]
- n <- if(!is.null(dim(y0))) nrow(y0) else length(y0)
- oN <- (1:n)[which.lbs0]
+ pch.pts <- rep(pch.pts, length.out=n)
+ lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,n)
L2Fam <- eval(x at CallL2Fam)
@@ -259,50 +318,52 @@
absInfo <- t(IC1) %*% QF %*% IC1
ICMap <- IC1 at Map
- absInfo <- sapply(y, absInfo at Map[[1]])
- absInfo0 <- absInfo[which.lbs]/max(absInfo)
+ sel <- .SelectOrderData(y, function(x)sapply(x, absInfo at Map[[1]]),
+ which.lbs, which.Order)
+ i.d <- sel$ind
+ i0.d <- sel$ind1
+ n <- length(i.d)
- if (n==length(y0)) {
- oN <- order(absInfo0)
- oN0 <- order(absInfo)
- oN0 <- oN0[oN0 %in% which.lbs]
- y0 <- y0[oN]
- if(!is.null(which.Order)){
- oN <- oN0[(n+1)-which.Order]
- y0 <- y[oN]
- absInfo0 <- absInfo[oN]/max(absInfo[oN])
- }
- }
- if(is.null(lab.pts)) lab.pts <- paste(oN)
- else {lab.pts <- rep(lab.pts, length.out=length(y))
- lab.pts <- lab.pts[oN]}
-
dots.without <- dots
dots.without$col <- dots.without$cex <- dots.without$pch <- NULL
+
pL <- expression({})
if(!is.null(dots$panel.last))
pL <- dots$panel.last
dots$panel.last <- NULL
pL <- substitute({
+ y1 <- y0s
ICy <- sapply(y0s,ICMap0[[indi]])
+ print(xlim[,i])
+ resc.dat <-.rescalefct(y0s, function(x) sapply(x,ICMap0[[indi]]),
+ scaleX, scaleX.fct, scaleX.inv,
+ scaleY, scaleY.fct, xlim[,i], ylim[,i],
+ dwo0)
+ y1 <- resc.dat$X
+ ICy <- resc.dat$Y
+
if(is(e1, "DiscreteDistribution"))
ICy <- jitter(ICy, factor = jitter.fac0)
- do.call(points, args=c(list(y0s, ICy, cex = log(absy0+1)*3*cex0,
- col = col0, pch = pch0), dwo0))
+
+ col.pts <- if(!is.na(al0)) sapply(col0, addAlphTrsp2col,alpha=al0) else col0
+
+ do.call(points, args=c(list(y1, ICy, cex = log(absy0+1)*3*cex0,
+ col = col.pts, pch = pch0), dwo0))
if(with.lab0){
text(x = y0s, y = ICy, labels = lab.pts0,
cex = log(absy0+1)*1.5*cex0, col = col0)
}
pL0
- }, list(pL0 = pL, ICMap0 = ICMap, y0s = y0, absy0 = absInfo0,
- dwo0 = dots.without, cex0 = cex.pts, pch0 = pch.pts,
- col0 = col.pts, with.lab0 = with.lab, lab.pts0 = lab.pts,
- jitter.fac0 = jitter.fac
+ }, list(pL0 = pL, ICMap0 = ICMap, y0s = sel$data, absy0 = sel$y,
+ dwo0 = dots.without, cex0 = cex.pts, pch0 = pch.pts[i.d],
+ col0 = col.pts, with.lab0 = with.lab, lab.pts0 = lab.pts[i.d],
+ al0 = alpha.trsp, jitter.fac0 = jitter.fac
))
do.call("plot", args = c(list(x = x, panel.last = pL), dots))
- if(return.Order) return(oN0)
+ if(return.Order) return(i0.d)
invisible()
})
+
Modified: pkg/RobAStBase/R/bALEstimate.R
===================================================================
--- pkg/RobAStBase/R/bALEstimate.R 2013-09-11 08:56:09 UTC (rev 690)
+++ pkg/RobAStBase/R/bALEstimate.R 2013-09-11 14:07:52 UTC (rev 691)
@@ -22,7 +22,7 @@
### code borrowed from confint.default from package stats
a <- (1 - level)/2
a <- c(a, 1 - a)
- pct <- stats:::format.perc(a, 3)
+ pct <- .format.perc(a, 3)
fac <- qnorm(a)
ci <- array(NA, dim = c(length(object at estimate), 2),
dimnames = list(names(object at estimate), pct))
@@ -58,7 +58,7 @@
### code borrowed from confint.default from package stats
a <- (1 - level)/2
a <- c(a, 1 - a)
- pct <- stats:::format.perc(a, 3)
+ pct <- .format.perc(a, 3)
fac <- qnorm(a, mean = c(-object at asbias, object at asbias))
ci <- array(NA, dim = c(length(object at estimate), 2),
dimnames = list(names(object at estimate), pct))
@@ -97,7 +97,7 @@
### code borrowed from confint.default from package stats
a <- (1 - level)/2
a <- c(a, 1 - a)
- pct <- stats:::format.perc(a, 3)
+ pct <- .format.perc(a, 3)
if(method at sign == -1)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 691
More information about the Robast-commits
mailing list