[Robast-commits] r721 - in branches/robast-1.0/pkg: ROptEst/R RobAStBase RobAStBase/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Feb 23 00:36:17 CET 2014
Author: ruckdeschel
Date: 2014-02-23 00:36:16 +0100 (Sun, 23 Feb 2014)
New Revision: 721
Modified:
branches/robast-1.0/pkg/ROptEst/R/AllPlot.R
branches/robast-1.0/pkg/ROptEst/R/comparePlot.R
branches/robast-1.0/pkg/ROptEst/R/getReq.R
branches/robast-1.0/pkg/RobAStBase/R/comparePlot.R
branches/robast-1.0/pkg/RobAStBase/R/cutoff-class.R
branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R
branches/robast-1.0/pkg/RobAStBase/R/infoPlot.R
branches/robast-1.0/pkg/RobAStBase/R/outlyingPlot.R
branches/robast-1.0/pkg/RobAStBase/RobAStBase-Ex.R
Log:
fixed errors detected by Matthias / Misha
Modified: branches/robast-1.0/pkg/ROptEst/R/AllPlot.R
===================================================================
--- branches/robast-1.0/pkg/ROptEst/R/AllPlot.R 2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/ROptEst/R/AllPlot.R 2014-02-22 23:36:16 UTC (rev 721)
@@ -47,6 +47,6 @@
.getExtremeCoordIC <- function(IC, D, indi, n = 10000){
x <- q(D)(seq(1/2/n,1-1/2/n, length=n))
- y <- (matrix(evalIC(IC,matrix(x,ncol=1)),ncol=n))[indi,]
+ y <- (matrix(evalIC(IC,matrix(x,ncol=1)),ncol=n))[indi,,drop=FALSE]
return(cbind(min=apply(y,1,min),max=apply(y,1,max)))
}
\ No newline at end of file
Modified: branches/robast-1.0/pkg/ROptEst/R/comparePlot.R
===================================================================
--- branches/robast-1.0/pkg/ROptEst/R/comparePlot.R 2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/ROptEst/R/comparePlot.R 2014-02-22 23:36:16 UTC (rev 721)
@@ -1,3 +1,4 @@
+.oldcomparePlot <- getMethod("comparePlot", signature("IC","IC"))
setMethod("comparePlot", signature("IC","IC"),
function(obj1,obj2, obj3 = NULL, obj4 = NULL, data = NULL,
..., withSweave = getdistrOption("withSweave"),
@@ -45,8 +46,7 @@
}
mcl$MBRB <- MBRB
mcl$withMBR <- withMBR
- do.call(getMethod("comparePlot", signature("IC","IC"),
- where="RobAStBase"), as.list(mcl[-1]),
+ do.call(.oldcomparePlot, as.list(mcl[-1]),
envir=parent.frame(2))
return(invisible())
})
Modified: branches/robast-1.0/pkg/ROptEst/R/getReq.R
===================================================================
--- branches/robast-1.0/pkg/ROptEst/R/getReq.R 2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/ROptEst/R/getReq.R 2014-02-22 23:36:16 UTC (rev 721)
@@ -2,8 +2,10 @@
list(s = getRiskIC(IC,risk=trAsCov())$trAsCov$value^.5,
b = getRiskIC(IC,risk=asBias(),neighbor=neighbor)$asBias$value)
-getReq <- function(Risk,neighbor,IC1,IC2,n=1,upper=15){
- if(!is(IC1,"IC")||!is(IC2,"IC"))
+getReq <- function(Risk,neighbor,IC1,IC2,n=1,upper=15,
+ radOrOutl=c("radius","Outlier")){
+ radOrOutl <- match.arg(radOrOutl)
+ if(!is(IC1,"IC")||!is(IC2,"IC"))
stop("Arguments IC1, IC2 must be of class 'IC'.")
if(!identical(IC1 at CallL2Fam,IC2 at CallL2Fam))
stop("Arguments IC1, IC2 must be of defined for the same model.")
@@ -24,6 +26,8 @@
get.asGRisk.fct(Risk)(r,s=sb2$s,b=sb2$b)
}
r0 <- uniroot(dRisk,lower=0, upper=upper)$root/n^.5
+ if(radOrOutl=="Outlier")
+ r0 <- if(sb1$s<=sb2$s) floor(r0*n) else ceiling(r0*n)
if(sb1$s<=sb2$s)
return(c(0,r0))
else
Modified: branches/robast-1.0/pkg/RobAStBase/R/comparePlot.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/comparePlot.R 2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/RobAStBase/R/comparePlot.R 2014-02-22 23:36:16 UTC (rev 721)
@@ -24,7 +24,6 @@
xc <- c(.xc("obj1"), .xc("obj2"))
if(!is.null(obj3)) xc <- c(xc, .xc("obj3"))
if(!is.null(obj4)) xc <- c(xc, .xc("obj4"))
-
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
dotsP <- dots
Modified: branches/robast-1.0/pkg/RobAStBase/R/cutoff-class.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/cutoff-class.R 2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/RobAStBase/R/cutoff-class.R 2014-02-22 23:36:16 UTC (rev 721)
@@ -46,7 +46,7 @@
cutoff.quantile = 0.95)}
cutoff.chisq <- function(){cutoff(name = "chisq",
- body.fct0 = substitute({dim = nrow(data)
- qchisq(df=dim,cutoff.quantile)^.5
+ body.fct0 = substitute({dim = nrow(as.matrix(data))
+ qchisq(df = dim, cutoff.quantile)^.5
}),
cutoff.quantile = 0.95)}
Modified: branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R 2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R 2014-02-22 23:36:16 UTC (rev 721)
@@ -107,6 +107,7 @@
if(is.null(dots$lwd)) dots$lwd <- par("lwd")
if(is.null(dots$lty)) dots$lty <- par("lty")
+ if(is.null(col.cutoff)) col.cutoff <- "red"
col.cutoff <- rep(col.cutoff,length.out=2)
if(missing(lty.cutoff) && !is.null(dots$lty)) lty.cutoff <- dots$lty
if(missing(lwd.cutoff) && !is.null(dots$lwd)) lwd.cutoff <- dots$lwd
Modified: branches/robast-1.0/pkg/RobAStBase/R/infoPlot.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/infoPlot.R 2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/RobAStBase/R/infoPlot.R 2014-02-22 23:36:16 UTC (rev 721)
@@ -315,6 +315,7 @@
if(missing(col.pts)) col.pts <- c(col, colI)
col.pts <- rep(col.pts, length.out=2)
pch.pts <- matrix(rep(pch.pts, length.out=2*n),n,2)
+ cex.pts <- rep(cex.pts,length.out=2)
jitter.fac <- rep(jitter.fac, length.out=2)
with.lab <- rep(with.lab, length.out=2)
lab.font <- rep(lab.font, length.out=2)
@@ -349,27 +350,31 @@
pL.abs <- substitute({
+ ICy0r1 <- ICy0r
+ ICy0cr1 <- ICy0cr
if(is(distr, "DiscreteDistribution")){
- ICy0 <- jitter(ICy0, factor = jitter.fac0[1])
- ICy0c <- jitter(ICy0c, factor = jitter.fac0[2])
+ ICy0r1 <- jitter(ICy0r1, factor = jitter.fac0[1])
+ ICy0cr1 <- jitter(ICy0cr1, factor = jitter.fac0[2])
}
+
f1 <- log(ICy0+1)*3*cex0[1]
f1c <- log(ICy0c+1)*3*cex0[2]
col.pts <- if(!is.na(al0)) sapply(col0,
addAlphTrsp2col, alpha=al0) else col0
- do.pts(y0, ICy0r, f1,col.pts[1],pch0[,1])
- do.pts(y0c, ICy0cr, f1c,col.pts[2],pch0[,2])
+ do.pts(y0, ICy0r1, f1,col.pts[1],pch0[,1])
+ do.pts(y0c, ICy0cr1, f1c,col.pts[2],pch0[,2])
if(with.lab0){
- tx(y0, ICy0r, lab.pts0, f1/2, col0[1])
- tx(y0c, ICy0cr, lab.pts0C, f1c/2, col0[2])
+ tx(y0, ICy0r1, lab.pts0, f1/2, col0[1])
+ tx(y0c, ICy0cr1, lab.pts0C, f1c/2, col0[2])
}
pL0
}, list(ICy0c = y.dC, ICy0 = y.d,
ICy0r = y.dr, ICy0cr = y.dCr,
pL0 = pL, y0 = x.dr, y0c = x.dCr,
- cex0 = cex.pts, pch0 = pch.pts, al0 = alp.v[1],
+ cex0 = cex.pts,
+ pch0 = pch.pts, al0 = alp.v[1],
col0 = col.pts, with.lab0 = with.lab, n0 = n,
lab.pts0 = lab.pts[i.d], lab.pts0C = lab.pts[i.dC],
jitter.fac0 = jitter.fac)
Modified: branches/robast-1.0/pkg/RobAStBase/R/outlyingPlot.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/outlyingPlot.R 2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/RobAStBase/R/outlyingPlot.R 2014-02-22 23:36:16 UTC (rev 721)
@@ -36,41 +36,58 @@
if(missing(dist.y)){
if(robCov.y){
- evIC = evalIC(IC.y,as.matrix(data))
- asVar = solve(getCov(CovMcd(data.frame(evIC[1,],evIC[2,]),alpha=0.5)))
- cat("\n", sep="", gettext("Robust asVar"), ":\n")
- print(asVar)
- }else{
- if("asCov" %in% names(Risks(IC.y)))
- if(is.matrix(Risks(IC.y)$asCov) || length(Risks(IC.y)$asCov) == 1)
- {asVar <- Risks(IC.y)$asCov
- cat("\n", sep="", gettext("asVar"));# print("HHHH");
- print(asVar)
- }
- else{asVar <- Risks(IC.y)$asCov$value
- cat("\n", sep="", gettext("asVar"));#print("HHHH");
+ evIC <- evalIC(IC.y,as.matrix(data))
+ if(is.null(dim(evIC))){
+ asVar <- PosSemDefSymmMatrix(mad(evIC)^2)
+ if(asVar < 1e-8) asVar <- 1
+ }else{
+ dimevIC <- dim(evIC)[1]
+ devIC <- data.frame(t(evIC[1:dimevIC,,drop=FALSE]))
+ CMcd <- PosSemDefSymmMatrix(getCov(CovMcd(devIC,alpha=0.5)))
+ asVar <- solve(CMcd)
+ # cat("\n", sep="", gettext("Robust asVar"), ":\n")
+ # print(asVar)
+ }
+ }else{
+ if("asCov" %in% names(Risks(IC.y)))
+ if(is.matrix(Risks(IC.y)$asCov) || length(Risks(IC.y)$asCov) == 1)
+ {asVar <- Risks(IC.y)$asCov
+ cat("\n", sep="", gettext("asVar"));# print("HHHH");
+ print(asVar)
+ }
+ else{asVar <- Risks(IC.y)$asCov$value
+ cat("\n", sep="", gettext("asVar"));#print("HHHH");
+ print(asVar)
+ }
+ else{asVar <- getRiskIC(IC.y, risk = asCov())$asCov$value
+ cat("\n", sep="", gettext("Classic asVar"));
+ # print("HHHH");
print(asVar)
- }
- else{asVar <- getRiskIC(IC.y, risk = asCov())$asCov$value
- cat("\n", sep="", gettext("Classic asVar"));
- # print("HHHH");
- print(asVar)
- }}
+ }
+ }
- asVar <- PosSemDefSymmMatrix(solve(asVar))
- mc$dist.y <- QFNorm(name = gettext("Mahalonobis-Norm"), QuadForm = asVar)
+ asVar <- PosSemDefSymmMatrix(solve(asVar))
+ mc$dist.y <- QFNorm(name = gettext("Mahalonobis-Norm"), QuadForm = asVar)
}
if(missing(dist.x)){
#mc$dist.x <- NormType()
if(robCov.x){
evIC = evalIC(IC.x,as.matrix(data))
- asVar = getCov(CovMcd(data.frame(evIC[1,],evIC[2,]),alpha=0.5))
+ if(is.null(dim(evIC))){
+ asVar <- PosSemDefSymmMatrix(mad(evIC)^2)
+ if(asVar < 1e-8) asVar <- 1
+ }else{
+ dimevIC <- dim(evIC)[1]
+ devIC <- data.frame(t(evIC[1:dimevIC,,drop=FALSE]))
+ CMcd <- PosSemDefSymmMatrix(getCov(CovMcd(devIC,alpha=0.5)))
+ asVar <- solve(CMcd)
+# cat("\n", sep="", gettext("Robust asVar"), ":\n")
+# print(asVar)
+ }
#cat("\nRobust asVar:") ;print("KKKKK")
#print(asVar)
- }
- else{
- if("asCov" %in% names(Risks(IC.y)))
+ }else{if("asCov" %in% names(Risks(IC.y)))
if(is.matrix(Risks(IC.x)$asCov) || length(Risks(IC.y)$asCov) == 1)
{asVar <- Risks(IC.x)$asCov
cat("\n", sep="", gettext("asVar"));
Modified: branches/robast-1.0/pkg/RobAStBase/RobAStBase-Ex.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/RobAStBase-Ex.R 2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/RobAStBase/RobAStBase-Ex.R 2014-02-22 23:36:16 UTC (rev 721)
@@ -4,7 +4,7 @@
options(pager = "console")
library('RobAStBase')
-assign(".oldSearch", search(), pos = 'CheckExEnv')
+base::assign(".oldSearch", base::search(), pos = 'CheckExEnv')
cleanEx()
nameEx("0RobAStBase-package")
### * 0RobAStBase-package
@@ -92,6 +92,29 @@
cleanEx()
+nameEx("ComparePlotWrapper")
+### * ComparePlotWrapper
+
+flush(stderr()); flush(stdout())
+
+### Name: ComparePlot
+### Title: Wrapper function for function comparePlot
+### Aliases: ComparePlot
+
+### ** Examples
+
+# Gamma
+fam <- GammaFamily()
+rfam <- InfRobModel(fam, ContNeighborhood(0.5))
+IC1 <- optIC(model = fam, risk = asCov())
+IC2 <- makeIC(list(function(x)sin(x),function(x)x^2), L2Fam = fam)
+Y <- distribution(fam)
+y <- r(Y)(100)
+ComparePlot(IC1, IC2, y, withCall = TRUE)
+
+
+
+cleanEx()
nameEx("ContIC-class")
### * ContIC-class
@@ -386,6 +409,27 @@
cleanEx()
+nameEx("InfoPlotWrapper")
+### * InfoPlotWrapper
+
+flush(stderr()); flush(stdout())
+
+### Name: InfoPlot
+### Title: Wrapper function for information plot method
+### Aliases: InfoPlot
+
+### ** Examples
+
+# Gamma
+fam <- GammaFamily()
+IC <- optIC(model = fam, risk = asCov())
+Y <- distribution(fam)
+data <- r(Y)(1000)
+InfoPlot(IC, data, withCall = FALSE)
+
+
+
+cleanEx()
nameEx("MEstimate-class")
### * MEstimate-class
@@ -405,6 +449,28 @@
cleanEx()
+nameEx("PlotICWrapper")
+### * PlotICWrapper
+
+flush(stderr()); flush(stdout())
+
+### Name: PlotIC
+### Title: Wrapper function for plot method for IC
+### Aliases: PlotIC
+
+### ** Examples
+
+# Gamma
+fam <- GammaFamily()
+rfam <- InfRobModel(fam, ContNeighborhood(0.5))
+IC <- optIC(model = fam, risk = asCov())
+Y <- distribution(fam)
+y <- r(Y)(1000)
+PlotIC(IC, y, withCall = FALSE)
+
+
+
+cleanEx()
nameEx("RobAStBaseMASK")
### * RobAStBaseMASK
@@ -767,6 +833,19 @@
##D infoPlot(IC1, data=data[1:10], mfColRow = FALSE, panel.first= grid(),
##D with.lab = TRUE, cex.pts=0.7)
##D par(mfrow=c(1,1))
+##D
+##D ICr <- makeIC(list(function(x)sign(x),function(x)sign(abs(x)-qnorm(.75))),N)
+##D data <- r(N)(600)
+##D data.c <- c(data, 1000*data[1:30])
+##D par(mfrow=c(3,1))
+##D infoPlot(ICr, data=data.c, tmar=c(4.1,0,0), bmar=c(0,0,4.1),
+##D xaxt=c("n","n","s"), mfColRow = FALSE, panel.first= grid(),
+##D cex.pts=c(.9,.9), alpha.trsp=20, lwd=2, lwdI=1.5, col=3,
+##D col.pts=c(3,2), colI=2, pch.pts=c(20,20), inner=FALSE,
+##D scaleX = TRUE, scaleX.fct=pnorm, scaleX.inv=qnorm,
+##D scaleY=TRUE, scaleY.fct=function(x) pchisq(x,df=1),
+##D scaleY.inv=function(x)qchisq(x,df=1),legend.cex = 1.0)
+##D
## End(Not run)
@@ -1092,7 +1171,8 @@
### * <FOOTER>
###
-cat("Time elapsed: ", proc.time() - get("ptime", pos = 'CheckExEnv'),"\n")
+options(digits = 7L)
+base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
grDevices::dev.off()
###
### Local variables: ***
More information about the Robast-commits
mailing list