[Robast-commits] r517 - branches/robast-0.9/pkg/RobAStBase/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Sep 12 17:31:02 CEST 2012
Author: horbenko
Date: 2012-09-12 17:31:02 +0200 (Wed, 12 Sep 2012)
New Revision: 517
Added:
branches/robast-0.9/pkg/RobAStBase/R/.directory
Modified:
branches/robast-0.9/pkg/RobAStBase/R/ddPlot.R
branches/robast-0.9/pkg/RobAStBase/R/ddPlot_utils.R
branches/robast-0.9/pkg/RobAStBase/R/outlyingPlot.R
Log:
changes in outlyingPlot
Added: branches/robast-0.9/pkg/RobAStBase/R/.directory
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/R/.directory (rev 0)
+++ branches/robast-0.9/pkg/RobAStBase/R/.directory 2012-09-12 15:31:02 UTC (rev 517)
@@ -0,0 +1,8 @@
+[Dolphin]
+AdditionalInfo=3
+SortOrder=1
+Timestamp=2012,9,6,17,33,40
+ViewMode=1
+
+[Settings]
+ShowDotFiles=true
Modified: branches/robast-0.9/pkg/RobAStBase/R/ddPlot.R
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/R/ddPlot.R 2012-09-12 15:30:00 UTC (rev 516)
+++ branches/robast-0.9/pkg/RobAStBase/R/ddPlot.R 2012-09-12 15:31:02 UTC (rev 517)
@@ -4,18 +4,11 @@
cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
transform.x, transform.y = transform.x,
id.n, lab.pts, adj, cex.idn,
- col.idn, lty.cutoff, lwd.cutoff, col.cutoff, text.abline = TRUE,
- text.abline.x = NULL, text.abline.y = NULL,
- cex.abline = par("cex"), col.abline = col.cutoff,
- font.abline = par("font"), adj.abline = c(0,0),
- text.abline.x.x = NULL, text.abline.x.y = NULL,
- text.abline.y.x = NULL, text.abline.y.y = NULL,
- text.abline.x.fmt.cx = "%7.2f", text.abline.x.fmt.qx = "%4.2f%%",
- text.abline.y.fmt.cy = "%7.2f", text.abline.y.fmt.qy = "%4.2f%%"){
+ col.idn, lty.cutoff, lwd.cutoff, col.cutoff,jitt.fac){
mc <- as.list(match.call(expand.dots = TRUE,
call = sys.call(sys.parent(1)))[-1])
mc$data <- data
- do.call(.ddPlot.MatNtNtCoCo, args = mc)
+ do.call(RobAStBase:::.ddPlot.MatNtNtCoCo, args = mc)
})
setMethod("ddPlot", signature = signature(data = "data.frame"),
@@ -24,14 +17,7 @@
cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
transform.x, transform.y = transform.x,
id.n, lab.pts, adj, cex.idn,
- col.idn, lty.cutoff, lwd.cutoff, col.cutoff, text.abline = TRUE,
- text.abline.x = NULL, text.abline.y = NULL,
- cex.abline = par("cex"), col.abline = col.cutoff,
- font.abline = par("font"), adj.abline = c(0,0),
- text.abline.x.x = NULL, text.abline.x.y = NULL,
- text.abline.y.x = NULL, text.abline.y.y = NULL,
- text.abline.x.fmt.cx = "%7.2f", text.abline.x.fmt.qx = "%4.2f%%",
- text.abline.y.fmt.cy = "%7.2f", text.abline.y.fmt.qy = "%4.2f%%"){
+ col.idn, lty.cutoff, lwd.cutoff, col.cutoff,jitt.fac){
mc <- match.call(call = sys.call(sys.parent(1)))
mc$data <- t(as.matrix(data))
@@ -44,14 +30,7 @@
cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
transform.x, transform.y = transform.x,
id.n, lab.pts, adj, cex.idn,
- col.idn, lty.cutoff, lwd.cutoff, col.cutoff, text.abline = TRUE,
- text.abline.x = NULL, text.abline.y = NULL,
- cex.abline = par("cex"), col.abline = col.cutoff,
- font.abline = par("font"), adj.abline = c(0,0),
- text.abline.x.x = NULL, text.abline.x.y = NULL,
- text.abline.y.x = NULL, text.abline.y.y = NULL,
- text.abline.x.fmt.cx = "%7.2f", text.abline.x.fmt.qx = "%4.2f%%",
- text.abline.y.fmt.cy = "%7.2f", text.abline.y.fmt.qy = "%4.2f%%"){
+ col.idn, lty.cutoff, lwd.cutoff, col.cutoff,jitt.fac){
mc <- match.call(call = sys.call(sys.parent(1)))
mc$data <- matrix(data,nrow=1)
Modified: branches/robast-0.9/pkg/RobAStBase/R/ddPlot_utils.R
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/R/ddPlot_utils.R 2012-09-12 15:30:00 UTC (rev 516)
+++ branches/robast-0.9/pkg/RobAStBase/R/ddPlot_utils.R 2012-09-12 15:31:02 UTC (rev 517)
@@ -1,22 +1,24 @@
-.presubs <- distr:::.presubs
+.ddPlot.MatNtNtCoCo <- function(data, ...,
+ dist.x = NormType(),
+ dist.y = NormType(),
+ cutoff.x = cutoff(norm = dist.x, cutoff.quantile = cutoff.quantile.x),
+ cutoff.y = cutoff(norm = dist.y, cutoff.quantile = cutoff.quantile.y),
+ cutoff.quantile.x = 0.95,
+ cutoff.quantile.y = cutoff.quantile.x,
+ transform.x,
+ transform.y = transform.x,
+ id.n,
+ lab.pts,
+ adj =0,
+ cex.idn = 1,
+ col.idn = par("col"),
+ lty.cutoff,
+ lwd.cutoff,
+ col.cutoff = "red",
+ jitt.fac = 10){
-.ddPlot.MatNtNtCoCo <- function(data, ..., dist.x = NormType(), dist.y = NormType(),
- cutoff.x = cutoff(norm = dist.x, cutoff.quantile = cutoff.quantile.x),
- cutoff.y = cutoff(norm = dist.y, cutoff.quantile = cutoff.quantile.y),
- cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
- transform.x, transform.y = transform.x,
- id.n, lab.pts, adj =0, cex.idn,
- col.idn, lty.cutoff,
- lwd.cutoff, col.cutoff = "red", text.abline = TRUE,
- text.abline.x = NULL, text.abline.y = NULL,
- cex.abline = par("cex"), col.abline = col.cutoff,
- font.abline = par("font"), adj.abline = c(0,0),
- text.abline.x.x = NULL, text.abline.x.y = NULL,
- text.abline.y.x = NULL, text.abline.y.y = NULL,
- text.abline.x.fmt.cx = "%7.2f", text.abline.x.fmt.qx = "%4.2f%%",
- text.abline.y.fmt.cy = "%7.2f", text.abline.y.fmt.qy = "%4.2f%%"){
-
dots <- match.call(expand.dots = FALSE)$"..."
+
id.n1 <- 1:ncol(data)
if(missing(id.n) || is.null(id.n))
@@ -24,7 +26,7 @@
if(missing(lab.pts)|| is.null(lab.pts)){
- lab.pts <- if(!is.null(colnames(data))) colnames(data) else id.n1
+ lab.pts <- if(!is.null(colnames(data))) colnames(data) else 1:ncol(data)
}
data <- data[,id.n, drop = FALSE]
@@ -45,16 +47,10 @@
if(is.null(dist.x)) dist.x <- NormType()
if(is.null(dist.y)) dist.y <- NormType()
+
if(is.null(dots$xlab)) dots$xlab <- name(dist.x)
if(is.null(dots$ylab)) dots$ylab <- name(dist.y)
- if(!is.null(dots$log)){
- if(grepl("x",dots$log)) dots$xlab <- paste(dots$xlab, "(log-scale)",
- sep=" ")
- if(grepl("y",dots$log)) dots$ylab <- paste(dots$ylab, "(log-scale)",
- sep=" ")
- }
-
if(is.null(cutoff.quantile.x))
cutoff.quantile.x <- 0.95
@@ -78,24 +74,19 @@
ndata.x <- fct(dist.x)(data.x)
ndata.y <- fct(dist.y)(data.y)
+
+ print(ndata.x)
- co.x <- fct(cutoff.x)(data.x)
- co.y <- fct(cutoff.y)(data.y)
-
-
if(is.null(adj)) adj <- 0
- if(missing(cex.idn)||is.null(cex.idn)) cex.idn <- if(is.null(dots$cex)) 1 else dots$cex
- if(missing(col.idn)||is.null(col.idn)) col.idn <- if(is.null(dots$col)) par("col") else dots$col
+ if(is.null(cex.idn)) cex.idn <- 1
+ if(is.null(col.idn)) col.idn <- par("col")
if(is.null(col.cutoff)) col.cutoff <- "red"
- print(cex.idn)
- print(col.idn)
if(is.null(dots$lwd)) dots$lwd <- par("lwd")
if(is.null(dots$lty)) dots$lty <- par("lty")
pdots <- dots
- pdots$nsim <- NULL
pdots$type <- NULL
pdots$x <- NULL
pdots$y <- NULL
@@ -105,64 +96,15 @@
pdots$untf <- NULL
abdots <- pdots
- 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
- if(missing(cex.abline) && !is.null(dots$cex)) cex.abline <- dots$cex
- if(missing(adj.abline) && !is.null(dots$adj)) lty.abline <- dots$adj
- if(missing(font.abline) && !is.null(dots$font)) font.abline <- dots$font
-
- if(!missing(lty.cutoff)) abdots$lty <- lty.cutoff[[1]]
- if(!missing(lwd.cutoff)) abdots$lwd <- lwd.cutoff[1]
- abdots$col <- col.cutoff[1]
+ abdots$col <- col.cutoff
+ if(!missing(lwd.cutoff)) abdots$lwd <- lwd.cutoff
+ if(!missing(lty.cutoff)) abdots$lty <- lty.cutoff
abdots$pos <- NULL
abdots$untf <- dots$untf
abdots$adj <- NULL
- abdots <- list(abdots,abdots)
-
- if(!is.null(abdots$lty))
- if(is.list(lty.cutoff)) abdots[[2]]$lty <- lty.cutoff[[2]]
- if(!is.null(abdots$lwd))
- if(length(lwd.cutoff)>1) abdots[[2]]$lwd <- lwd.cutoff[2]
-
- ab.textL <- rep(text.abline,length.out=2)
- abtdots.x <- abtdots.y <- vector("list",0)
- cex.abline <- rep(cex.abline, length.out = 2)
- col.abline <- rep(if(!is.null(col.abline)) col.abline else "red", length.out = 2)
- font.abline <- rep(font.abline, length.out = 2)
- adj.abline <- matrix(rep(adj.abline,length.out=4),2,2)
+ abdots$jitt.fac <- pdots$jitt.fac
-
- .mpresubs <- function(inx)
- .presubs(inx, c("%qx", "%qy", "%cx", "%cy"),
- c(gettextf(text.abline.x.fmt.qx, round(cutoff.quantile.x*100,1)),
- gettextf(text.abline.y.fmt.qy, round(cutoff.quantile.y*100,1)),
- gettextf(text.abline.x.fmt.cx, round(co.x,2)),
- gettextf(text.abline.y.fmt.cy, round(co.y,2))))
-
- abtdots.x$labels <- if(! is.null(text.abline.x)) .mpresubs(text.abline.x) else
- gettextf(paste(text.abline.x.fmt.qx,"-cutoff = ",
- text.abline.x.fmt.cx,sep=""),
- cutoff.quantile.x*100,round(co.x,digits=2))
- abtdots.x$cex <- cex.abline[1]
- abtdots.x$col <- col.abline[1]
- abtdots.x$font <- font.abline[1]
- abtdots.x$srt <- NULL
- abtdots.x$adj <- adj.abline[,1]
-
- abtdots.y$labels <- if(! is.null(text.abline.y)) .mpresubs(text.abline.y) else
- gettextf(paste(text.abline.y.fmt.qy,"-cutoff = ",
- text.abline.y.fmt.cy,sep=""),
- cutoff.quantile.y*100,round(co.y,digits=2))
- abtdots.y$cex <- cex.abline[2]
- abtdots.y$col <- col.abline[2]
- abtdots.y$font <- font.abline[2]
- abtdots.y$srt <- NULL
- abtdots.y$adj <- adj.abline[,2]
-
adots <- pdots
adots$col <- pdots$col.axis
adots$lty <- pdots$lty.axis
@@ -174,13 +116,17 @@
tdots$offset <- dots$offset
tdots$pos <- dots$pos
tdots$adj <- adj
+
pdots$axes <- FALSE
pdots$log <- dots$log
pdots$adj <- par("adj")
+ print(tdots)
####
+ co.x <- fct(cutoff.x)(data.x)
+ co.y <- fct(cutoff.y)(data.y)
# print(quantile(ndata.x))
# print(co.x)
# print(fct(cutoff.x))
@@ -210,25 +156,23 @@
id0.y <- id.n1[id.y]
do.call(plot, args = c(list(x = ndata.x,ndata.y, type = "p"), pdots))
+
do.call(box,args=c(adots))
- do.call(abline, args = c(list(v=co.x), abdots[[1]]))
- do.call(abline, args = c(list(h=co.y), abdots[[2]]))
-
- pusr <- par("usr")
- mid.x = mean(pusr[c(1,2)])
- mid.y = mean(pusr[c(3,4)])
- abtdots.y$x <- if(is.null(text.abline.y.x)) mid.x else text.abline.y.x
- abtdots.x$y <- if(is.null(text.abline.x.y)) mid.y else text.abline.x.y
-
- if(ab.textL[1])
- do.call(text, args = c(list(y=co.y*1.03), abtdots.y))
- if(ab.textL[2])
- do.call(text, args = c(list(x=co.x*1.03), abtdots.x,srt=90))
+ mid.y = 0.5*(max(ndata.y)-min(ndata.y))
+ mid.x = 0.5*(max(ndata.x)-min(ndata.x))
+ do.call(abline, args = c(list(h=co.y), abdots))
+ do.call(text, args = c(list(co.x-5,mid.y,paste(cutoff.quantile.y*100,"%-cutoff = ",round(co.x,digits=2)),srt=90)))
+ do.call(abline, args = c(list(v=co.x), abdots))
+ do.call(text, args = c(list(mid.x,co.y+5,paste(cutoff.quantile.x*100," %-cutoff = ",round(co.y,digits=2)))))
+
if(length(id.xy))
- do.call(text, args = c(list(ndata.x[id.xy], ndata.y[id.xy],
- labels=lab.pts[id.xy]), tdots))
+ do.call(text, args = c(list(jitter(ndata.x[id.xy],factor=50), jitter(ndata.y[id.xy],factor=50),
+ labels=lab.pts[id.xy]), tdots))
+ #axis(side=4)
+ axis(side=1)
+
return(list(id.x=id0.x, id.y= id0.y, id.xy = id0.xy,
qtx = quantile(ndata.x), qty = quantile(ndata.y),
cutoff.x.v = co.x, cutoff.y.v = co.y
Modified: branches/robast-0.9/pkg/RobAStBase/R/outlyingPlot.R
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/R/outlyingPlot.R 2012-09-12 15:30:00 UTC (rev 516)
+++ branches/robast-0.9/pkg/RobAStBase/R/outlyingPlot.R 2012-09-12 15:31:02 UTC (rev 517)
@@ -1,48 +1,110 @@
-outlyingPlotIC <- function(data, IC.x, IC.y = IC.x, dist.x = NormType(),
- dist.y, cutoff.y = cutoff.chisq(), cutoff.x = cutoff.sememp(), ...,
- cutoff.quantile.x = 0.95,
- cutoff.quantile.y = cutoff.quantile.x,
- id.n, lab.pts, adj, cex.idn,
- col.idn, lty.cutoff, lwd.cutoff, col.cutoff,
- main = gettext("Outlyingness by means of a distance-distance plot")
- ){
+outlyingPlotIC <- function(data,
+ IC.x,
+ IC.y,
+ dist.x,
+ dist.y,
+ cutoff.y = cutoff.chisq(),
+ cutoff.x = cutoff.sememp(),
+ ...,
+ cutoff.quantile.x = 0.95,
+ cutoff.quantile.y = cutoff.quantile.x,
+ id.n,
+ lab.pts,
+ adj,
+ cex.idn,
+ col.idn,
+ lty.cutoff,
+ lwd.cutoff,
+ col.cutoff,
+ robCov.x = TRUE,
+ robCov.y = TRUE,
+ tf.x = data,
+ tf.y = data,
+ jitt.fac=10,
+ main = gettext("Outlyingness \n by means of a distance-distance plot")
+ ){
mc <- as.list(match.call(expand.dots = FALSE))[-1]
dots <- mc$"..."
- if(is.null(dots$xlim)) dots$xlim <- TRUE
- if(is.null(dots$ylim)) dots$ylim <- TRUE
+ if(is.null(mc$xlim)) mc$xlim <- TRUE
+ if(is.null(mc$ylim)) mc$ylim <- TRUE
if(is.null(mc$cutoff.quantile.x)) mc$cutoff.quantile.x <- 0.95
if(is.null(mc$cutoff.quantile.y)) mc$cutoff.quantile.y <- cutoff.quantile.x
if(is.null(mc$cutoff.x)) mc$cutoff.x <- cutoff.sememp()
if(is.null(mc$cutoff.y)) mc$cutoff.y <- cutoff.chisq()
if(missing(IC.x)) stop("Argument 'IC.x' must be given as argument to 'outlyingPlot'")
if(missing(data)) stop("Argument 'data' must be given as argument to 'outlyingPlot'")
-
+
if(missing(dist.y)){
+ if(robCov.y){
+ require(rrcov)
+ evIC = evalIC(IC.y,as.matrix(data))
+ asVar = solve(CovMcd(data.frame(evIC[1,],evIC[2,]),alpha=0.5)@cov)
+ cat("\nRobust asVar:")
+ 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
- else
- asVar <- Risks(IC.y)$asCov$value
- else
- asVar <- getRiskIC(IC.y, risk = asCov())$asCov$value
-
+ {asVar <- Risks(IC.y)$asCov
+ cat("\nasVar",asVar)}
+ else{asVar <- Risks(IC.y)$asCov$value
+ cat("\nasVar",asVar)}
+ else{asVar <- getRiskIC(IC.y, risk = asCov())$asCov$value
+ cat("\nClassic asVar",asVar)}}
+
asVar <- PosSemDefSymmMatrix(solve(asVar))
mc$dist.y <- QFNorm(name = gettext("Mahalonobis-Norm"), QuadForm = asVar)
}
- if(missing(dist.x))
- mc$dist.x <- NormType()
+ if(missing(dist.x)){
+ #mc$dist.x <- NormType()
+ if(robCov.x){
+ require(rrcov)
+ evIC = evalIC(IC.x,as.matrix(data))
+ asVar = CovMcd(data.frame(evIC[1,],evIC[2,]),alpha=0.5)@cov
+ cat("\nRobust asVar:")
+ print(asVar)}
+ 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("\nasVar",asVar)}
+ else
+ {asVar <- Risks(IC.x)$asCov$value
+ cat("\nasVar",asVar)}
+ else
+ {asVar <- getRiskIC(IC.x, risk = asCov())$asCov$value
+ cat("\nClassic asVar",asVar)}
+ }
+
+ asVar <- PosSemDefSymmMatrix(solve(asVar))
+ mc$dist.x <- QFNorm(name = gettext("Mahalonobis-Norm"), QuadForm = asVar)
+ }
+
+ if(missing(tf.x)){
tf.x <- function(x) apply(x,2,function(xx) evalIC(IC.x,xx))
+ }else{tf.x <- mc$tf.x}
+ if(missing(tf.y)){
tf.y <- function(x) apply(x,2,function(xx) evalIC(IC.y,xx))
+ }else{tf.y <- mc$tf.y}
+ do.call(ddPlot,args=c(list(data=data),dots,
+ list(dist.x = mc$dist.x,
+ dist.y = mc$dist.y,
+ cutoff.x = mc$cutoff.x,
+ cutoff.y = mc$cutoff.y,
+ cutoff.quantile.x = mc$cutoff.quantile.x,
+ cutoff.quantile.y = mc$cutoff.quantile.y,
+ transform.x = tf.x,
+ transform.y = tf.y,
+ id.n = mc$id.n,
+ lab.pts = mc$lab.pts,
+ adj = mc$adj,
+ cex.idn = mc$cex.idn,
+ col.idn = mc$col.idn,
+ lty.cutoff = mc$lty.cutoff,
+ lwd.cutoff = mc$lwd.cutoff,
+ col.cutoff = mc$col.cutoff,
+ jitt.fac = mc$jitt.fac,
+ main = main)))
- do.call(ddPlot,args=c(list(data=data), dots, list(dist.x = mc$dist.x,
- dist.y = mc$dist.y, cutoff.x = mc$cutoff.x, cutoff.y = mc$cutoff.y,
- cutoff.quantile.x = mc$cutoff.quantile.x, cutoff.quantile.y = mc$cutoff.quantile.y,
- transform.x = tf.x, transform.y = tf.y,
- id.n = mc$id.n, lab.pts = mc$lab.pts, adj = mc$adj, cex.idn = mc$cex.idn,
- col.idn = mc$col.idn, lty.cutoff = mc$lty.cutoff,
- lwd.cutoff = mc$lwd.cutoff, col.cutoff = mc$col.cutoff, main = main)))
-
}
More information about the Robast-commits
mailing list