From noreply at r-forge.r-project.org Wed Aug 1 03:09:12 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 1 Aug 2018 03:09:12 +0200 (CEST) Subject: [Robast-commits] r1080 - branches/robast-1.1/pkg/ROptEst branches/robast-1.1/pkg/ROptEst/R branches/robast-1.1/pkg/ROptEst/inst branches/robast-1.1/pkg/ROptEst/man branches/robast-1.2/pkg/ROptEst branches/robast-1.2/pkg/ROptEst/R branches/robast-1.2/pkg/ROptEst/inst branches/robast-1.2/pkg/ROptEst/man pkg/ROptEst pkg/ROptEst/R pkg/ROptEst/inst pkg/ROptEst/man Message-ID: <20180801010912.6831218A2A4@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-01 03:09:11 +0200 (Wed, 01 Aug 2018) New Revision: 1080 Added: branches/robast-1.1/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R branches/robast-1.1/pkg/ROptEst/man/ORobEstimate-class.Rd branches/robast-1.1/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R branches/robast-1.2/pkg/ROptEst/man/ORobEstimate-class.Rd branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd pkg/ROptEst/R/RMXEOMSEMBREOBRE.R pkg/ROptEst/man/ORobEstimate-class.Rd pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd Modified: branches/robast-1.1/pkg/ROptEst/NAMESPACE branches/robast-1.1/pkg/ROptEst/R/AllClass.R branches/robast-1.1/pkg/ROptEst/R/AllGeneric.R branches/robast-1.1/pkg/ROptEst/R/getInfLM.R branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asAnscombe.R branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asGRisk.R branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asHampel.R branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asUnOvShoot.R branches/robast-1.1/pkg/ROptEst/R/getModifyIC.R branches/robast-1.1/pkg/ROptEst/R/getStartIC.R branches/robast-1.1/pkg/ROptEst/R/internal.roptest.R branches/robast-1.1/pkg/ROptEst/R/optIC.R branches/robast-1.1/pkg/ROptEst/R/radiusMinimaxIC.R branches/robast-1.1/pkg/ROptEst/R/roptest.new.R branches/robast-1.1/pkg/ROptEst/inst/NEWS branches/robast-1.1/pkg/ROptEst/man/getInfRobIC.Rd branches/robast-1.1/pkg/ROptEst/man/getModifyIC.Rd branches/robast-1.1/pkg/ROptEst/man/getStartIC-methods.Rd branches/robast-1.1/pkg/ROptEst/man/inputGenerator.Rd branches/robast-1.1/pkg/ROptEst/man/optIC.Rd branches/robast-1.1/pkg/ROptEst/man/radiusMinimaxIC.Rd branches/robast-1.1/pkg/ROptEst/man/robest.Rd branches/robast-1.1/pkg/ROptEst/man/roptest.Rd branches/robast-1.2/pkg/ROptEst/NAMESPACE branches/robast-1.2/pkg/ROptEst/R/AllClass.R branches/robast-1.2/pkg/ROptEst/R/AllGeneric.R branches/robast-1.2/pkg/ROptEst/R/getInfLM.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asGRisk.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asHampel.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asUnOvShoot.R branches/robast-1.2/pkg/ROptEst/R/getModifyIC.R branches/robast-1.2/pkg/ROptEst/R/getStartIC.R branches/robast-1.2/pkg/ROptEst/R/internal.roptest.R branches/robast-1.2/pkg/ROptEst/R/optIC.R branches/robast-1.2/pkg/ROptEst/R/radiusMinimaxIC.R branches/robast-1.2/pkg/ROptEst/R/roptest.new.R branches/robast-1.2/pkg/ROptEst/inst/NEWS branches/robast-1.2/pkg/ROptEst/man/getInfRobIC.Rd branches/robast-1.2/pkg/ROptEst/man/getModifyIC.Rd branches/robast-1.2/pkg/ROptEst/man/getStartIC-methods.Rd branches/robast-1.2/pkg/ROptEst/man/inputGenerator.Rd branches/robast-1.2/pkg/ROptEst/man/optIC.Rd branches/robast-1.2/pkg/ROptEst/man/radiusMinimaxIC.Rd branches/robast-1.2/pkg/ROptEst/man/robest.Rd branches/robast-1.2/pkg/ROptEst/man/roptest.Rd pkg/ROptEst/NAMESPACE pkg/ROptEst/R/AllClass.R pkg/ROptEst/R/AllGeneric.R pkg/ROptEst/R/getInfLM.R pkg/ROptEst/R/getInfRobIC_asAnscombe.R pkg/ROptEst/R/getInfRobIC_asGRisk.R pkg/ROptEst/R/getInfRobIC_asHampel.R pkg/ROptEst/R/getInfRobIC_asUnOvShoot.R pkg/ROptEst/R/getModifyIC.R pkg/ROptEst/R/getStartIC.R pkg/ROptEst/R/internal.roptest.R pkg/ROptEst/R/optIC.R pkg/ROptEst/R/radiusMinimaxIC.R pkg/ROptEst/R/roptest.new.R pkg/ROptEst/inst/NEWS pkg/ROptEst/man/getInfRobIC.Rd pkg/ROptEst/man/getModifyIC.Rd pkg/ROptEst/man/getStartIC-methods.Rd pkg/ROptEst/man/inputGenerator.Rd pkg/ROptEst/man/optIC.Rd pkg/ROptEst/man/radiusMinimaxIC.Rd pkg/ROptEst/man/robest.Rd pkg/ROptEst/man/roptest.Rd Log: [ROptEst] trunk & branch 1.1 & branch 1.2 + new wrapper functions RMXEstimator, OBREstimator, MBREstimator, OMSEstimator + new return class ORobEstimate for optimally robust estimators + try to minimize interim output while using roptest- and friends Modified: branches/robast-1.1/pkg/ROptEst/NAMESPACE =================================================================== --- branches/robast-1.1/pkg/ROptEst/NAMESPACE 2018-07-31 20:53:06 UTC (rev 1079) +++ branches/robast-1.1/pkg/ROptEst/NAMESPACE 2018-08-01 01:09:11 UTC (rev 1080) @@ -38,13 +38,14 @@ "getModifyIC") exportMethods("updateNorm", "scaleUpdateIC", "eff", "get.asGRisk.fct", "getStartIC", "plot", - "comparePlot", "getRiskFctBV") + "comparePlot", "getRiskFctBV", "roptestCall") export("getL2normL2deriv", "asAnscombe", "asL1", "asL4", "getReq", "getMaxIneff", "getRadius") export("roptest","roptest.old", "robest", + "OBREstimator", "RMXEstimator", "MBREstimator", "OMSEstimator", "getLagrangeMultByOptim","getLagrangeMultByIter") -export("genkStepCtrl", "genstartCtrl", "gennbCtrl") +export("genkStepCtrl", "genstartCtrl", "genstartICCtrl", "gennbCtrl") export("cniperCont", "cniperPoint", "cniperPointPlot") export(".generateInterpGrid",".getLMGrid",".saveGridToCSV", ".readGridFromCSV") export(".RMXE.th",".OMSE.th", ".MBRE.th") Modified: branches/robast-1.1/pkg/ROptEst/R/AllClass.R =================================================================== --- branches/robast-1.1/pkg/ROptEst/R/AllClass.R 2018-07-31 20:53:06 UTC (rev 1079) +++ branches/robast-1.1/pkg/ROptEst/R/AllClass.R 2018-08-01 01:09:11 UTC (rev 1080) @@ -26,3 +26,33 @@ ## asymptotic L1 error setClass("asL1", contains = "asGRisk", prototype = prototype(type = "asymptotic mean absolute error")) + +setClass("ORobEstimate", + representation(roptestCall = "OptionalCall"), + prototype(name = "Optimally robust asymptotically linear estimate", + estimate = numeric(0), + samplesize = numeric(0), + completecases = logical(0), + estimate.call = call("{}"), + steps = integer(0), + asvar = NULL, + asbias = NULL, + pIC = NULL, + pICList = NULL, + ICList = NULL, + ksteps = NULL, + uksteps = NULL, + start = matrix(0), + startval = matrix(0), + ustartval = matrix(0), + nuis.idx = NULL, + trafo = list(fct = function(x){ + list(fval = x, mat = matrix(1))}, + mat = matrix(1)), ### necessary for comparison with unit matrix + Infos = matrix(c(character(0),character(0)), ncol=2, + dimnames=list(character(0), c("method", "message"))), + untransformed.estimate = NULL, + untransformed.asvar = NULL, + robestCall = NULL, + roptestCall = NULL), + contains = "kStepEstimate") Modified: branches/robast-1.1/pkg/ROptEst/R/AllGeneric.R =================================================================== --- branches/robast-1.1/pkg/ROptEst/R/AllGeneric.R 2018-07-31 20:53:06 UTC (rev 1079) +++ branches/robast-1.1/pkg/ROptEst/R/AllGeneric.R 2018-08-01 01:09:11 UTC (rev 1080) @@ -90,3 +90,6 @@ if(!isGeneric("getStartIC")){ setGeneric("getStartIC", function(model, risk, ...) standardGeneric("getStartIC")) } +if(!isGeneric("roptestCall")){ + setGeneric("roptestCall", function(object) standardGeneric("roptestCall")) +} Added: branches/robast-1.1/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R =================================================================== --- branches/robast-1.1/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R (rev 0) +++ branches/robast-1.1/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R 2018-08-01 01:09:11 UTC (rev 1080) @@ -0,0 +1,177 @@ +RMXEstimator <- function(x, L2Fam, fsCor = 1, initial.est, + neighbor = ContNeighborhood(), steps = 1L, + distance = CvMDist, startPar = NULL, verbose = NULL, + OptOrIter = "iterate", + useLast = getRobAStBaseOption("kStepUseLast"), + withUpdateInKer = getRobAStBaseOption("withUpdateInKer"), + IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"), + withICList = getRobAStBaseOption("withICList"), + withPICList = getRobAStBaseOption("withPICList"), + na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, + ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, + withEvalAsVar = NULL, withMakeIC = FALSE, + modifyICwarn = NULL){ + + mc <- match.call(expand.dots=FALSE) + dots <- mc$"..." + + gsANY <- selectMethod("getStartIC", c(model="ANY",risk="ANY"))@defined + clsL2Fam <- c(class(L2Fam)) + gsCUR <- selectMethod("getStartIC", c(model=clsL2Fam, risk="interpolRisk"))@defined + risk0 <- asMSE() + if(!all(all.equal(gsANY,gsCUR)==TRUE)) risk0 <- RMXRRisk() + + roptestArgList <- list(x = x, L2Fam = L2Fam, fsCor = fsCor, + neighbor = neighbor, risk = risk0, steps = steps, + distance = distance, startPar = startPar, verbose = verbose, + OptOrIter = OptOrIter, useLast = useLast, + withUpdateInKer = withUpdateInKer, IC.UpdateInKer = IC.UpdateInKer, + withICList = withICList, withPICList = withPICList, na.rm = na.rm, + withLogScale = withLogScale, ..withCheck = ..withCheck, + withTimings = withTimings, withMDE = withMDE, + withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC, + modifyICwarn = modifyICwarn) + + if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots) + if(!missing(initial.est)) roptestArgList$initial.est <- initial.est + if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est + + res <- do.call(roptest, roptestArgList) + res at roptestCall <- quote(res at estimate.call) + res at estimate.call <- mc + return(res) +} + +OMSEstimator <- function(x, L2Fam, eps =0.5, fsCor = 1, initial.est, + neighbor = ContNeighborhood(), steps = 1L, + distance = CvMDist, startPar = NULL, verbose = NULL, + OptOrIter = "iterate", + useLast = getRobAStBaseOption("kStepUseLast"), + withUpdateInKer = getRobAStBaseOption("withUpdateInKer"), + IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"), + withICList = getRobAStBaseOption("withICList"), + withPICList = getRobAStBaseOption("withPICList"), + na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, + ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, + withEvalAsVar = NULL, withMakeIC = FALSE, + modifyICwarn = NULL){ + + if(!is.numeric(eps)||length(eps)>1||any(eps<0)) + stop("Radius 'eps' must be given, of length 1 and non-negative.") + mc <- match.call(expand.dots=FALSE) + dots <- mc$"..." + + gsANY <- selectMethod("getStartIC", c(model="ANY",risk="ANY"))@defined + clsL2Fam <- c(class(L2Fam)) + gsCUR <- selectMethod("getStartIC", c(model=clsL2Fam, risk="interpolRisk"))@defined + risk0 <- asMSE() + if(!all(all.equal(gsANY,gsCUR)==TRUE)&& abs(eps-0.5)<1e-3) risk0 <- OMSRRisk() + + roptestArgList <- list(x = x, L2Fam = L2Fam, eps = 0.5, fsCor = fsCor, + neighbor = neighbor, risk = risk0, steps = steps, + distance = distance, startPar = startPar, verbose = verbose, + OptOrIter = OptOrIter, useLast = useLast, + withUpdateInKer = withUpdateInKer, IC.UpdateInKer = IC.UpdateInKer, + withICList = withICList, withPICList = withPICList, na.rm = na.rm, + withLogScale = withLogScale, ..withCheck = ..withCheck, + withTimings = withTimings, withMDE = withMDE, + withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC, + modifyICwarn = modifyICwarn) + + if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots) + if(!missing(initial.est)) roptestArgList$initial.est <- initial.est + if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est + + res <- do.call(roptest, roptestArgList) + res at roptestCall <- quote(res at estimate.call) + res at estimate.call <- mc + return(res) +} + +OBREstimator <- function(x, L2Fam, eff=0.95, fsCor = 1, initial.est, + neighbor = ContNeighborhood(), steps = 1L, + distance = CvMDist, startPar = NULL, verbose = NULL, + OptOrIter = "iterate", + useLast = getRobAStBaseOption("kStepUseLast"), + withUpdateInKer = getRobAStBaseOption("withUpdateInKer"), + IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"), + withICList = getRobAStBaseOption("withICList"), + withPICList = getRobAStBaseOption("withPICList"), + na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, + ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, + withEvalAsVar = NULL, withMakeIC = FALSE, + modifyICwarn = NULL){ + + if(!is.numeric(eff)||length(eff)>1||any(eff<0|eff>1)) + stop("Efficiency loss (in the ideal model) 'eff' must be given, of length 1 and in [0,1].") + mc <- match.call(expand.dots=FALSE) + dots <- mc$"..." + + risk0 <- asAnscombe(eff) + + roptestArgList <- list(x = x, L2Fam = L2Fam, fsCor = fsCor, + neighbor = neighbor, risk = risk0, steps = steps, + distance = distance, startPar = startPar, verbose = verbose, + OptOrIter = OptOrIter, useLast = useLast, + withUpdateInKer = withUpdateInKer, IC.UpdateInKer = IC.UpdateInKer, + withICList = withICList, withPICList = withPICList, na.rm = na.rm, + withLogScale = withLogScale, ..withCheck = ..withCheck, + withTimings = withTimings, withMDE = withMDE, + withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC, + modifyICwarn = modifyICwarn) + + if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots) + if(!missing(initial.est)) roptestArgList$initial.est <- initial.est + if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est + + res <- do.call(roptest, roptestArgList) + res at roptestCall <- quote(res at estimate.call) + res at estimate.call <- mc + return(res) +} + +MBREstimator <- function(x, L2Fam, fsCor = 1, initial.est, + neighbor = ContNeighborhood(), steps = 1L, + distance = CvMDist, startPar = NULL, verbose = NULL, + OptOrIter = "iterate", + useLast = getRobAStBaseOption("kStepUseLast"), + withUpdateInKer = getRobAStBaseOption("withUpdateInKer"), + IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"), + withICList = getRobAStBaseOption("withICList"), + withPICList = getRobAStBaseOption("withPICList"), + na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, + ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, + withEvalAsVar = NULL, withMakeIC = FALSE, + modifyICwarn = NULL){ + + mc <- match.call(expand.dots=FALSE) + dots <- mc$"..." + + gsANY <- selectMethod("getStartIC", c(model="ANY",risk="ANY"))@defined + clsL2Fam <- c(class(L2Fam)) + gsCUR <- selectMethod("getStartIC", c(model=clsL2Fam, risk="interpolRisk"))@defined + risk0 <- asBias() + if(!all(all.equal(gsANY,gsCUR)==TRUE)) risk0 <- MBRRisk() + + roptestArgList <- list(x = x, L2Fam = L2Fam, fsCor = fsCor, + neighbor = neighbor, risk = risk0, steps = steps, + distance = distance, startPar = startPar, verbose = verbose, + OptOrIter = OptOrIter, useLast = useLast, + withUpdateInKer = withUpdateInKer, IC.UpdateInKer = IC.UpdateInKer, + withICList = withICList, withPICList = withPICList, na.rm = na.rm, + withLogScale = withLogScale, ..withCheck = ..withCheck, + withTimings = withTimings, withMDE = withMDE, + withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC, + modifyICwarn = modifyICwarn) + + if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots) + if(!missing(initial.est)) roptestArgList$initial.est <- initial.est + if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est + + res <- do.call(roptest, roptestArgList) + res at roptestCall <- quote(res at estimate.call) + res at estimate.call <- mc + return(res) + +} + Modified: branches/robast-1.1/pkg/ROptEst/R/getInfLM.R =================================================================== --- branches/robast-1.1/pkg/ROptEst/R/getInfLM.R 2018-07-31 20:53:06 UTC (rev 1079) +++ branches/robast-1.1/pkg/ROptEst/R/getInfLM.R 2018-08-01 01:09:11 UTC (rev 1080) @@ -9,6 +9,7 @@ verbose = NULL, warnit = TRUE){ if(missing(verbose)|| is.null(verbose)) verbose <- getRobAStBaseOption("all.verbose") + if(missing(warnit)|| is.null(warnit)) warnit <- TRUE LMcall <- match.call() ## initialization Modified: branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asAnscombe.R =================================================================== --- branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asAnscombe.R 2018-07-31 20:53:06 UTC (rev 1079) +++ branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asAnscombe.R 2018-08-01 01:09:11 UTC (rev 1080) @@ -8,6 +8,8 @@ upper = NULL, lower = NULL, maxiter, tol, warn, noLow = FALSE, verbose = NULL, checkBounds = TRUE, ...){ + if(missing(warn)|| is.null(warn)) warn <- FALSE + if(missing(verbose)|| is.null(verbose)) verbose <- getRobAStBaseOption("all.verbose") @@ -55,7 +57,7 @@ normtype = normtype(risk)) upBerg <- getInfRobIC(L2deriv, risk.b, neighbor, symm, Finfo, trafo, upper = 3*upper, lower = lower, maxiter = maxi, - tol = toli, warn, noLow = noLow, + tol = toli, warn = warn, noLow = noLow, verbose = FALSE, checkBounds = FALSE) trV <- upBerg$risk$trAsCov$value if(!is.na(trV)) e.up <- FI/trV @@ -72,7 +74,8 @@ toli <- min(tol*100^(1/it.erg),1e-3) checkBounds <- checkBounds & it.erg>10 erg <<- getInfRobIC(L2deriv, risk.b, neighbor, symm, Finfo, trafo, - upper = upper, lower = lower, maxiter = maxi, tol = toli, warn, noLow = noLow, + upper = upper, lower = lower, maxiter = maxi, tol = toli, + warn = warn, noLow = noLow, verbose = verbose, checkBounds = checkBounds) trV <- erg$risk$trAsCov$value if(verbose) cat("Outer iteration:", it.erg," b_0=", round(b0,3), @@ -87,7 +90,7 @@ b <- uniroot(funb, interval=c(lower,upper), f.lower=f.low, f.upper=e.up-eff,tol=tol,maxiter=maxiter) erg$info <- c(erg$info, - paste("optimally bias-robust IC for ARE", eff, " in the ideal model")) + paste("optimally bias-robust IC for ARE", eff, " in the ideal model" ,collapse="", sep=" ")) erg$risk$eff <- b$f.root+eff return(erg) @@ -167,7 +170,7 @@ L2derivDistrSymm, Finfo, trafo, onesetLM = onesetLM, z.start, A.start, upper = upper, lower = lower, OptOrIter = OptOrIter, maxiter=maxi, - tol=toli, warn, + tol=toli, warn = warn, verbose = FALSE, checkBounds = FALSE, ...) trV <- lowBerg$risk$trAsCov$value f.low <- trV.ML/trV -eff @@ -189,7 +192,7 @@ L2derivDistrSymm, Finfo, trafo, onesetLM = onesetLM, z.start, A.start, upper = upper, lower = lower, OptOrIter = OptOrIter, maxiter=maxi, - tol=toli, warn, + tol=toli, warn = warn, verbose = FALSE, checkBounds = FALSE, ...) trV <- upBerg$risk$trAsCov$value e.up <- trV.ML/trV @@ -213,18 +216,19 @@ Distr, DistrSymm, L2derivSymm, L2derivDistrSymm, Finfo, trafo, onesetLM = onesetLM, z.start, A.start, upper = upper, lower = lower, - OptOrIter = OptOrIter, maxiter = maxi, tol = toli , warn, + OptOrIter = OptOrIter, maxiter = maxi, tol = toli , warn = warn, verbose = verbL, checkBounds = chkbd, ...) trV <- erg$risk$trAsCov$value if(verbose) cat("Outer iteration:", it.erg," b_0=", round(b0,3), " eff=", round(trV.ML/trV,3), "\n") return(trV.ML/trV-eff) } - print(c(lower,upper, f.lower=f.low, f.upper=e.up-eff)) + if(verbose) print(c(lower,upper, f.lower=f.low, f.upper=e.up-eff)) b <- uniroot(funb, interval=c(lower,upper), f.lower=f.low, f.upper=e.up-eff,tol=tol,maxiter=maxiter) erg$info <- c(erg$info, - paste("optimally bias-robust IC for ARE", eff, " in the ideal model")) + paste("optimally bias-robust IC for ARE", eff, " in the ideal model", + collapse="", sep=" ")) erg$risk$eff <- b$f.root+eff erg$call <- mc Modified: branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asGRisk.R =================================================================== --- branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asGRisk.R 2018-07-31 20:53:06 UTC (rev 1079) +++ branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asGRisk.R 2018-08-01 01:09:11 UTC (rev 1080) @@ -11,6 +11,8 @@ if(missing(verbose)|| is.null(verbose)) verbose <- getRobAStBaseOption("all.verbose") + if(missing(warn)|| is.null(warn)) warn <- FALSE + biastype <- biastype(risk) normtype <- normtype(risk) radius <- neighbor at radius @@ -133,13 +135,13 @@ if(abs(prec.old - prec) < 1e-10){ if(iter>1) problem <- TRUE - cat("algorithm did not converge!\n", "achieved precision:\t", prec, "\n") + if(warn) cat("algorithm did not converge!\n", "achieved precision:\t", prec, "\n") break } if(iter > maxiter){ if(iter>1) problem <- TRUE - cat("maximum iterations reached!\n", "achieved precision:\t", prec, "\n") + if(warn) cat("maximum iterations reached!\n", "achieved precision:\t", prec, "\n") break } } @@ -375,7 +377,7 @@ a.start = a, z.start = z, A.start = A, w.start = w, std = std, z.comp = z.comp, A.comp = A.comp, maxiter = maxit2, tol = tol, - verbose = verbose, warnit = (OptOrIter!=2)) + verbose = verbose, warnit = warn&(OptOrIter!=2)) ## read out solution w <- erg$w @@ -405,12 +407,12 @@ if(prec < tol) break if(abs(prec.old - prec) < 1e-10){ problem <- TRUE - cat("algorithm did not converge!\n", "achieved precision:\t", prec, "\n") + if(warn) cat("algorithm did not converge!\n", "achieved precision:\t", prec, "\n") break } if(iter > maxiter){ problem <- TRUE - cat("maximum iterations reached!\n", "achieved precision:\t", prec, "\n") + if(warn) cat("maximum iterations reached!\n", "achieved precision:\t", prec, "\n") break } } Modified: branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asHampel.R =================================================================== --- branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asHampel.R 2018-07-31 20:53:06 UTC (rev 1079) +++ branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asHampel.R 2018-08-01 01:09:11 UTC (rev 1080) @@ -10,6 +10,7 @@ if(missing(verbose)|| is.null(verbose)) verbose <- getRobAStBaseOption("all.verbose") + if(missing(warn)|| is.null(warn)) warn <- FALSE biastype <- biastype(risk) normtype <- normtype(risk) @@ -20,7 +21,7 @@ if(checkBounds){ bmax <- abs(as.vector(A))*max(abs(q.l(L2deriv)(0)), q.l(L2deriv)(1)) if(b >= bmax){ - if(warn) cat("'b >= maximum asymptotic bias' => (classical) optimal IC\n", + if(warn) cat("'b >= maximum asymptotic bias' => (classical) optimal IC\n", "in sense of Cramer-Rao bound is returned\n") res <- getInfRobIC(L2deriv = L2deriv, risk = asCov(), neighbor = neighbor, Finfo = Finfo, trafo = trafo, @@ -43,7 +44,7 @@ trafo = trafo, maxiter = maxiter, tol = tol, Finfo = Finfo, warn = warn, verbose = verbose) bmin <- res$b - cat("minimal bound:\t", bmin, "\n") + if(verbose)cat("minimal bound:\t", bmin, "\n") }else{ bmin <- b/2 } @@ -98,7 +99,7 @@ print(round(c(A=A,z=z),3)) } if(iter > maxiter){ - cat("maximum iterations reached!\n", "achieved precision:\t", + if(verbose) cat("maximum iterations reached!\n", "achieved precision:\t", max(abs(as.vector(A-A.old)), abs(z-z.old)), "\n") break } @@ -153,6 +154,7 @@ if(missing(verbose)|| is.null(verbose)) verbose <- getRobAStBaseOption("all.verbose") + if(missing(warn)|| is.null(warn)) warn <- FALSE mc <- match.call() @@ -237,7 +239,7 @@ w.start = w, std = std, z.comp = z.comp, A.comp = A.comp, maxiter = maxiter, tol = tol, - verbose = verbose) + warnit = warn, verbose = verbose) } ## read out solution @@ -331,6 +333,7 @@ L2derivDistrSymm, z.start, A.start, trafo, maxiter, tol, QuadForm, verbose, nrvalpts, warn){ + if(missing(warn)|| is.null(warn)) warn <- FALSE ClassIC <- trafo %*% solve(Finfo) %*% L2deriv lower.x <- getLow(Distr) @@ -338,7 +341,7 @@ x <- seq(from = lower.x, to = upper.x, length = nrvalpts) bmax <- sapply(x,function(x) evalRandVar(ClassIC,x)) bmax <- sqrt(max(colSums(as.matrix(bmax^2)))) - cat("numerical approximation of maximal bound:\t", bmax, "\n") + if (verbose) cat("numerical approximation of maximal bound:\t", bmax, "\n") if(b >= bmax){ if(warn) cat("'b >= maximum asymptotic bias' => (classical) optimal IC\n", @@ -368,7 +371,7 @@ verbose = verbose) bmin <- res$b - cat("minimal bound:\t", bmin, "\n") + if(verbose) cat("minimal bound:\t", bmin, "\n") if(b <= bmin){ if(warn) cat("'b <= minimum asymptotic bias'\n", "=> the minimum asymptotic bias (lower case) solution is returned\n") Modified: branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asUnOvShoot.R =================================================================== --- branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asUnOvShoot.R 2018-07-31 20:53:06 UTC (rev 1079) +++ branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asUnOvShoot.R 2018-08-01 01:09:11 UTC (rev 1080) @@ -5,7 +5,12 @@ risk = "asUnOvShoot", neighbor = "UncondNeighborhood"), function(L2deriv, risk, neighbor, symm, Finfo, trafo, - upper, lower, maxiter, tol, warn, ...){ + upper, lower, maxiter, tol, warn, verbose = NULL, ...){ + + if(missing(verbose)|| is.null(verbose)) + verbose <- getRobAStBaseOption("all.verbose") + if(missing(warn)|| is.null(warn)) warn <- FALSE + biastype <- biastype(risk) radius <- neighbor at radius if(identical(all.equal(radius, 0), TRUE)){ @@ -115,7 +120,7 @@ if(S) break if(max(abs(z - z.old), abs(c0-c0.old)) < tol) break if(iter > maxiter){ - cat("maximum iterations reached!\n", "achieved precision:\t", abs(c0 - c0.old), "\n") + if(warn) cat("maximum iterations reached!\n", "achieved precision:\t", abs(c0 - c0.old), "\n") break } } Modified: branches/robast-1.1/pkg/ROptEst/R/getModifyIC.R =================================================================== --- branches/robast-1.1/pkg/ROptEst/R/getModifyIC.R 2018-07-31 20:53:06 UTC (rev 1079) +++ branches/robast-1.1/pkg/ROptEst/R/getModifyIC.R 2018-08-01 01:09:11 UTC (rev 1080) @@ -5,14 +5,18 @@ setMethod("getModifyIC", signature(L2FamIC = "L2ParamFamily", neighbor = "Neighborhood", risk = "asRisk"), function(L2FamIC, neighbor, risk, ...){ - dots <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)[["..."]] + mc <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE) + mcl <- as.list(mc)[-1] + dots <- mcl[["..."]] dots$verbose <- NULL + dots$warn <- FALSE modIC <- function(L2Fam, IC){} body(modIC) <- substitute({ verbose <- getRobAStBaseOption("all.verbose") infMod <- InfRobModel(L2Fam, nghb) do.call(optIC, args = c(list(infMod, risk=R), dots0)) }, - list(nghb = neighbor, R = risk, dots0 = dots)) + list(nghb = neighbor, R = risk, + dots0 = eval(dots, envir=parent.frame(2)))) return(modIC) }) @@ -104,7 +108,9 @@ setMethod("getModifyIC", signature(L2FamIC = "L2ScaleFamily", neighbor = "UncondNeighborhood", risk = "asGRisk"), - function(L2FamIC, neighbor, risk, ...){ + function(L2FamIC, neighbor, risk, ..., modifyICwarn = NULL){ + if(missing(modifyICwarn)|| is.null(modifyICwarn)) + modifyICwarn <- getRobAStBaseOption("modifyICwarn") modIC <- function(L2Fam, IC){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), class(distribution(ICL2Fam)))){ @@ -112,8 +118,10 @@ sdalt = main(ICL2Fam), IC = IC, neighbor = neighbor) IC <- generateIC(neighbor = neighbor, L2Fam = L2Fam, res = res) - addInfo(IC) <- c("modifyIC", "The IC has been modified") - addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong") + if(!any(grepl("Some entries in 'Infos' may be wrong", Infos(IC)[,2])) && modifyICwarn){ + addInfo(IC) <- c("modifyIC", "The IC has been modified") + addInfo(IC) <- c("modifyIC", "Some entries in 'Infos' may be wrong") + } return(IC) }else{ makeIC(IC, L2Fam) @@ -124,7 +132,10 @@ setMethod("getModifyIC", signature(L2FamIC = "L2LocationScaleFamily", neighbor = "UncondNeighborhood", risk = "asGRisk"), - function(L2FamIC, neighbor, risk, ...){ + function(L2FamIC, neighbor, risk, ..., modifyICwarn = NULL){ + if(missing(modifyICwarn)|| is.null(modifyICwarn)) + modifyICwarn <- getRobAStBaseOption("modifyICwarn") + modIC <- function(L2Fam, IC){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2LocationScaleFamily") && is(distribution(L2Fam), @@ -143,8 +154,10 @@ IC = IC, neighbor = neighbor) IC <- generateIC(neighbor = neighbor, L2Fam = L2Fam, res = res) - addInfo(IC) <- c("modifyIC", "The IC has been modified") - addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong") + if(!any(grepl("Some entries in 'Infos' may be wrong", Infos(IC)[,2])) && modifyICwarn){ + addInfo(IC) <- c("modifyIC", "The IC has been modified") + addInfo(IC) <- c("modifyIC", "Some entries in 'Infos' may be wrong") + } return(IC) }else{ makeIC(IC, L2Fam) Modified: branches/robast-1.1/pkg/ROptEst/R/getStartIC.R =================================================================== --- branches/robast-1.1/pkg/ROptEst/R/getStartIC.R 2018-07-31 20:53:06 UTC (rev 1079) +++ branches/robast-1.1/pkg/ROptEst/R/getStartIC.R 2018-08-01 01:09:11 UTC (rev 1080) @@ -3,10 +3,9 @@ setMethod("getStartIC",signature(model = "L2ParamFamily", risk = "asGRisk"), function(model, risk, ..., withEvalAsVar = TRUE, withMakeIC = FALSE, - ..debug=FALSE){ + ..debug=FALSE, modifyICwarn = NULL){ mc <- match.call(expand.dots=FALSE, call = sys.call(sys.parent(1))) dots <- as.list(mc$"...") -# cat("HALLLO IN getstartIC\n"); print(..debug) if(missing(..debug)||!is.logical(..debug)) ..debug <- FALSE if("fsCor" %in% names(dots)){ fsCor <- eval(dots[["fsCor"]]) @@ -21,23 +20,19 @@ dots$neighbor <- NULL }else neighbor <- ContNeighborhood() - sm.rmx <- selectMethod("radiusMinimaxIC", signature( + + if(is.null(eps[["e"]])){ + sm.rmx <- selectMethod("radiusMinimaxIC", signature( class(model),class(neighbor),class(risk))) - dots.rmx <- .fix.in.defaults(dots, sm.rmx) - dots.rmx$L2Fam <- NULL - dots.rmx$neighbor <- NULL - dots.rmx$risk <- NULL + dots.rmx <- .fix.in.defaults(dots, sm.rmx) + dots.rmx$L2Fam <- NULL + dots.rmx$neighbor <- NULL + dots.rmx$risk <- NULL + dots.rmx$modifyICwarn <- modifyICwarn + dots.rmx[["warn"]] <- FALSE + if(!is.null(dots[["warn"]]))if(eval(dots[["warn"]])) dots.rmx[["warn"]] <- TRUE - infMod <- InfRobModel(center = model, neighbor = neighbor) - sm.optic <- selectMethod("optIC", signature( - class(infMod),class(risk))) - dots.optic <- .fix.in.defaults(dots, sm.optic) - dots.optic$model <- NULL - dots.optic$risk <- NULL - dots.optic$.withEvalAsVar <- withEvalAsVar - dots.optic$withMakeIC <- withMakeIC - - if(is.null(eps[["e"]])){ + infMod <- InfRobModel(center = model, neighbor = neighbor) dots.rmx$loRad <- eps$sqn * eps$lower dots.rmx$upRad <- eps$sqn * eps$upper arg.rmx <- c(list(L2Fam = model, neighbor = neighbor, @@ -54,6 +49,17 @@ }else{ neighbor at radius <- eps$sqn * fsCor * eps$e infMod <- InfRobModel(center = model, neighbor = neighbor) + sm.optic <- selectMethod("optIC", signature( + class(infMod),class(risk))) + dots.optic <- .fix.in.defaults(dots, sm.optic) + dots.optic$model <- NULL + dots.optic$risk <- NULL + dots.optic$.withEvalAsVar <- withEvalAsVar + dots.optic$withMakeIC <- withMakeIC + dots.optic$modifyICwarn <- modifyICwarn + dots.optic[["warn"]] <- FALSE + if(!is.null(dots[["warn"]]))if(eval(dots[["warn"]])) dots.optic[["warn"]] <- TRUE + arg.optic <- c(list(model = infMod, risk = risk), dots.optic) if(..debug) print(c(arg.optic=arg.optic)) @@ -71,16 +77,49 @@ ) setMethod("getStartIC",signature(model = "L2ParamFamily", risk = "asBias"), - function(model, risk, ..., withMakeIC = FALSE, ..debug=FALSE){ + function(model, risk, ..., withMakeIC = FALSE, ..debug=FALSE, + modifyICwarn = NULL){ mc <- match.call(expand.dots=FALSE, call = sys.call(sys.parent(1))) dots <- as.list(mc$"...") + if("neighbor" %in% names(dots)){ neighbor <- eval(dots[["neighbor"]]) dots$neighbor <- NULL [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/robast -r 1080 From noreply at r-forge.r-project.org Wed Aug 1 03:10:03 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 1 Aug 2018 03:10:03 +0200 (CEST) Subject: [Robast-commits] r1081 - branches/robast-1.1 Message-ID: <20180801011003.241AB18A2A4@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-01 03:09:59 +0200 (Wed, 01 Aug 2018) New Revision: 1081 Modified: branches/robast-1.1/20180726ReleaseNote.txt Log: updated release notes 1.1 Modified: branches/robast-1.1/20180726ReleaseNote.txt =================================================================== --- branches/robast-1.1/20180726ReleaseNote.txt 2018-08-01 01:09:11 UTC (rev 1080) +++ branches/robast-1.1/20180726ReleaseNote.txt 2018-08-01 01:09:59 UTC (rev 1081) @@ -105,6 +105,7 @@ \code{ggplot}) to produce the plot in a different framework. + new methods for returnlevelplot for RobModel, InfRobModel, kStepEstimate (as qqplot) ROptEst: + + new wrapper functions RMXEstimator, OBREstimator, MBREstimator, OMSEstimator + several tweaks to speed up things: - optIC gains argument withMakeIC - roptest gains argument withMakeIC From noreply at r-forge.r-project.org Wed Aug 1 05:02:33 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 1 Aug 2018 05:02:33 +0200 (CEST) Subject: [Robast-commits] r1082 - branches/robast-1.1/pkg/ROptEst/R branches/robast-1.1/pkg/RobExtremes branches/robast-1.1/pkg/RobExtremes/R branches/robast-1.1/pkg/RobExtremes/inst branches/robast-1.1/pkg/RobExtremes/inst/scripts branches/robast-1.1/pkg/RobExtremes/man branches/robast-1.2/pkg/ROptEst/R branches/robast-1.2/pkg/RobExtremes branches/robast-1.2/pkg/RobExtremes/R branches/robast-1.2/pkg/RobExtremes/inst branches/robast-1.2/pkg/RobExtremes/inst/scripts branches/robast-1.2/pkg/RobExtremes/man pkg/ROptEst/R pkg/RobExtremes pkg/RobExtremes/R pkg/RobExtremes/inst pkg/RobExtremes/inst/scripts pkg/RobExtremes/man Message-ID: <20180801030233.5D2A71899CB@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-01 05:02:30 +0200 (Wed, 01 Aug 2018) New Revision: 1082 Modified: branches/robast-1.1/pkg/ROptEst/R/roptest.new.R branches/robast-1.1/pkg/RobExtremes/NAMESPACE branches/robast-1.1/pkg/RobExtremes/R/AllClass.R branches/robast-1.1/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R branches/robast-1.1/pkg/RobExtremes/R/getStartICPareto.R branches/robast-1.1/pkg/RobExtremes/inst/NEWS branches/robast-1.1/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R branches/robast-1.1/pkg/RobExtremes/man/0RobExtremes-package.Rd branches/robast-1.1/pkg/RobExtremes/man/GEVFamily.Rd branches/robast-1.1/pkg/RobExtremes/man/GParetoFamily.Rd branches/robast-1.1/pkg/RobExtremes/man/WeibullFamily.Rd branches/robast-1.1/pkg/RobExtremes/man/getStartIC-methods.Rd branches/robast-1.1/pkg/RobExtremes/man/internal-methods.Rd branches/robast-1.1/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd branches/robast-1.2/pkg/ROptEst/R/roptest.new.R branches/robast-1.2/pkg/RobExtremes/NAMESPACE branches/robast-1.2/pkg/RobExtremes/R/AllClass.R branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R branches/robast-1.2/pkg/RobExtremes/inst/NEWS branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R branches/robast-1.2/pkg/RobExtremes/man/0RobExtremes-package.Rd branches/robast-1.2/pkg/RobExtremes/man/GEVFamily.Rd branches/robast-1.2/pkg/RobExtremes/man/GParetoFamily.Rd branches/robast-1.2/pkg/RobExtremes/man/WeibullFamily.Rd branches/robast-1.2/pkg/RobExtremes/man/getStartIC-methods.Rd branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd pkg/ROptEst/R/roptest.new.R pkg/RobExtremes/NAMESPACE pkg/RobExtremes/R/AllClass.R pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R pkg/RobExtremes/R/getStartIC.R pkg/RobExtremes/R/getStartICPareto.R pkg/RobExtremes/inst/NEWS pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R pkg/RobExtremes/man/0RobExtremes-package.Rd pkg/RobExtremes/man/GEVFamily.Rd pkg/RobExtremes/man/GParetoFamily.Rd pkg/RobExtremes/man/WeibullFamily.Rd pkg/RobExtremes/man/getStartIC-methods.Rd pkg/RobExtremes/man/internal-methods.Rd pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd Log: [RobExtremes] in trunk & in branch 1.1 and in branch 1.2: + replaced calls in example script to roptest by RMXEstimator, MBREstimator, OBREstimator, OMSEstimator, + to this end needed new intermediate return classes in case of GEV[U], GPD families (for ismev diagnostics) (and roptest had to coerce first back to kStepEstimate) + some cosmetics as to Rd files (and R CMD check threw an error at TeX due to (misplaced) \cr) + the new getStartIC methods also respect modifyICwarn Modified: branches/robast-1.1/pkg/ROptEst/R/roptest.new.R =================================================================== --- branches/robast-1.1/pkg/ROptEst/R/roptest.new.R 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/ROptEst/R/roptest.new.R 2018-08-01 03:02:30 UTC (rev 1082) @@ -138,7 +138,7 @@ retV at estimate.call <- mc tim <- attr(retV,"timings") - retV <- as(retV, "ORobEstimate") + retV <- as(as(retV,"kStepEstimate"), "ORobEstimate") retV <- .checkEstClassForParamFamily(L2Fam,retV) attr(retV,"timings") <- tim retV at roptestCall <- mc Modified: branches/robast-1.1/pkg/RobExtremes/NAMESPACE =================================================================== --- branches/robast-1.1/pkg/RobExtremes/NAMESPACE 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/NAMESPACE 2018-08-01 03:02:30 UTC (rev 1082) @@ -31,7 +31,8 @@ exportClasses("L2LocScaleShapeUnion") exportClasses("GPDEstimate","GPDMCEstimate","GPDLDEstimate", "GPDkStepEstimate","GEVEstimate","GEVLDEstimate", - "GEVkStepEstimate","GEVMCEstimate") + "GEVkStepEstimate","GEVMCEstimate", + "GPDORobEstimate","GEVORobEstimate") exportMethods("initialize", "show", "rescaleFunction") exportMethods("loc", "loc<-", "kMAD", "Sn", "Qn") exportMethods("validParameter", Modified: branches/robast-1.1/pkg/RobExtremes/R/AllClass.R =================================================================== --- branches/robast-1.1/pkg/RobExtremes/R/AllClass.R 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/R/AllClass.R 2018-08-01 03:02:30 UTC (rev 1082) @@ -288,7 +288,9 @@ setClass("GPDMCEstimate", contains=c("MCEstimate", "GPDEstimate")) setClass("GPDLDEstimate", contains=c("LDEstimate", "GPDEstimate")) setClass("GPDkStepEstimate", contains=c("kStepEstimate", "GPDEstimate")) +setClass("GPDORobEstimate", contains=c("ORobEstimate", "GPDkStepEstimate")) setClass("GEVEstimate", contains="Estimate") setClass("GEVLDEstimate", contains=c("LDEstimate", "GEVEstimate")) setClass("GEVkStepEstimate", contains=c("kStepEstimate", "GEVEstimate")) +setClass("GEVORobEstimate", contains=c("ORobEstimate", "GEVkStepEstimate")) setClass("GEVMCEstimate", contains=c("MCEstimate", "GEVEstimate")) Modified: branches/robast-1.1/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R =================================================================== --- branches/robast-1.1/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-08-01 03:02:30 UTC (rev 1082) @@ -8,6 +8,9 @@ signature=signature(PFam="GParetoFamily",estimator="kStepEstimate"), function(PFam, estimator) as(estimator,"GPDkStepEstimate")) setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GParetoFamily",estimator="ORobEstimate"), + function(PFam, estimator) as(estimator,"GPDORobEstimate")) +setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GParetoFamily",estimator="MCEstimate"), function(PFam, estimator) as(estimator,"GPDMCEstimate")) setMethod(".checkEstClassForParamFamily", @@ -20,6 +23,9 @@ signature=signature(PFam="GEVFamily",estimator="kStepEstimate"), function(PFam, estimator) as(estimator,"GEVkStepEstimate")) setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamily",estimator="ORobEstimate"), + function(PFam, estimator) as(estimator,"GEVORobEstimate")) +setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamily",estimator="MCEstimate"), function(PFam, estimator) as(estimator,"GEVMCEstimate")) setMethod(".checkEstClassForParamFamily", @@ -32,5 +38,8 @@ signature=signature(PFam="GEVFamilyMuUnknown",estimator="kStepEstimate"), function(PFam, estimator) as(estimator,"GEVkStepEstimate")) setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamilyMuUnknown",estimator="ORobEstimate"), + function(PFam, estimator) as(estimator,"GEVORobEstimate")) +setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCEstimate"), function(PFam, estimator) as(estimator,"GEVMCEstimate")) Modified: branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R =================================================================== --- branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R 2018-08-01 03:02:30 UTC (rev 1082) @@ -1,15 +1,11 @@ setMethod("getStartIC",signature(model = "L2ScaleShapeUnion", risk = "interpolRisk"), - function(model, risk, ...){ + function(model, risk, ..., withMakeIC = FALSE, ..debug=FALSE, + modifyICwarn = NULL){ mc <- match.call(call = sys.call(sys.parent(1))) - dots <- match.call(call = sys.call(sys.parent(1)), - expand.dots = FALSE)$"..." mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias() mc$neighbor <- ContNeighborhood(radius=0.5) - withMakeIC <- FALSE - if(!is.null(dots$withMakeIC)) withMakeIC <- dots$withMakeIC - gridn <- gsub("\\.","",type(risk)) nam <- paste(".",gsub("[F,f]amily","",gsub(" ","",name(model))),sep="") @@ -76,15 +72,13 @@ }) setMethod("getStartIC",signature(model = "L2LocScaleShapeUnion", risk = "interpolRisk"), - function(model, risk, ...){ + function(model, risk, ..., withMakeIC = FALSE, ..debug=FALSE, + modifyICwarn = NULL){ mc <- match.call(call = sys.call(sys.parent(1))) - dots <- match.call(call = sys.call(sys.parent(1)), - expand.dots = FALSE)$"..." mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias() mc$neighbor <- ContNeighborhood(radius=0.5) - withMakeIC <- FALSE gridn <- gsub("\\.","",type(risk)) Modified: branches/robast-1.1/pkg/RobExtremes/R/getStartICPareto.R =================================================================== --- branches/robast-1.1/pkg/RobExtremes/R/getStartICPareto.R 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/R/getStartICPareto.R 2018-08-01 03:02:30 UTC (rev 1082) @@ -1,13 +1,6 @@ setMethod("getStartIC",signature(model = "ParetoFamily", risk = "interpolRisk"), - function(model, risk, ...){ + function(model, risk, ..., withMakeIC = FALSE){ - mc <- match.call(call = sys.call(sys.parent(1))) - dots <- match.call(call = sys.call(sys.parent(1)), - expand.dots = FALSE)$"..." - - withMakeIC <- FALSE - if(!is.null(dots$withMakeIC)) withMakeIC <- dots$withMakeIC - param1 <- param(model) xi <- main(param1) .modifyIC0 <- function(L2Fam, IC){ Modified: branches/robast-1.1/pkg/RobExtremes/inst/NEWS =================================================================== --- branches/robast-1.1/pkg/RobExtremes/inst/NEWS 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/inst/NEWS 2018-08-01 03:02:30 UTC (rev 1082) @@ -42,6 +42,8 @@ + in ParetoFamily.R L2derivDistr was not attached to return value under the hood: ++ inserted new intermediate classes for return values of roptest, RMXEstimator, MBREstimator, + OBREstimator, OMSEstimator, in case of GEV[U], GPD families (for ismev diagnostics) + Expectation E for DistributionsIntegratingByQuantiles to speed up things now uses stop.on.error = FALSE and for accuracy splits up the integration range in [0,0.98] and [0.98, upp] as soon as upp>0.98 + prepared everything for first release on CRAN Modified: branches/robast-1.1/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R =================================================================== --- branches/robast-1.1/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-01 03:02:30 UTC (rev 1082) @@ -43,12 +43,16 @@ system.time(mlEiALE <- roptest(portpiriei, GEVFam,risk=asCov())) ## with 10 steps and with system.time(mlEi10ALE <- roptest(portpiriei, GEVFam,risk=asCov(),steps=10)) -system.time(MBRi <- roptest(portpiriei, GEVFam,risk=MBRRisk())) -system.time(RMXi <- roptest(portpiriei, GEVFam,risk=RMXRRisk())) +system.time(MBRi <- MBREstimator(portpiriei, GEVFam)) +## synonymous to +## system.time(MBRi0 <- roptest(portpiriei, GEVFam,risk=MBRRisk())) +system.time(RMXi <- RMXEstimator(portpiriei, GEVFam)) +## synonymous to +## system.time(RMXi <- roptest(portpiriei, GEVFam,risk=RMXRRisk())) ## in fact the precision of the pIC is not too good, but the resp. estimate only differs ## little to the situation where we enforce IC conditions checkIC(pIC(RMXi)) -system.time(RMXiw <- roptest(portpiriei, GEVFam,risk=RMXRRisk(),withMakeIC=TRUE)) +system.time(RMXiw <- RMXEstimator(portpiriei, GEVFam,withMakeIC=TRUE)) checkIC(pIC(RMXiw)) estimate(RMXi) estimate(RMXiw) @@ -131,8 +135,8 @@ gev.diag(ppfitc) ## mlEc <- MLEstimator(portpiriec, GEVFamilyMuUnknown(withPos=FALSE)) -system.time(MBRc <- roptest(portpiriec, GEVFamilyMuUnknown(withPos=FALSE),risk=MBRRisk())) -system.time(RMXc <- roptest(portpiriec, GEVFamilyMuUnknown(withPos=FALSE),risk=RMXRRisk())) +system.time(MBRc <- MBREstimator(portpiriec, GEVFamilyMuUnknown(withPos=FALSE))) +system.time(RMXc <- RMXEstimator(portpiriec, GEVFamilyMuUnknown(withPos=FALSE))) ## our output: mlEc MBRc @@ -182,8 +186,8 @@ ## mlE2i <- MLEstimator(raini, GParetoFamily(loc=10)) gpd.diag(mlE2i) -system.time(MBR2i <- roptest(raini, GParetoFamily(loc=10),risk=MBRRisk())) -system.time(RMX2i <- roptest(raini, GParetoFamily(loc=10),risk=RMXRRisk())) +system.time(MBR2i <- MBREstimator(raini, GParetoFamily(loc=10))) +system.time(RMX2i <- RMXEstimator(raini, GParetoFamily(loc=10))) mlE2i MBR2i estimate(mlE2i) @@ -210,8 +214,8 @@ mlE2c <- MLEstimator(rainc, GParetoFamily(loc=10)) devNew() gpd.diag(mlE2c) -system.time(MBR2c <- roptest(rainc, GParetoFamily(loc=10),risk=MBRRisk())) -system.time(RMX2c <- roptest(rainc, GParetoFamily(loc=10),risk=RMXRRisk())) +system.time(MBR2c <- MBREstimator(rainc, GParetoFamily(loc=10))) +system.time(RMX2c <- RMXEstimator(rainc, GParetoFamily(loc=10))) ## again a comparison, and again MLE is shuttered, the robust ones keep cool estimate(mlE2i) @@ -294,10 +298,10 @@ devNew() returnlevelplot(x, mlE3i, MaxOrPOT="POT",ylim=c(1,1e5),log="y") -system.time(MBR3i <- roptest(x, PM,risk=MBRRisk())) -system.time(RMX3i <- roptest(x, PM,risk=RMXRRisk())) -system.time(MBR3c <- roptest(xc, PM,risk=MBRRisk())) -system.time(RMX3c <- roptest(xc, PM,risk=RMXRRisk())) +system.time(MBR3i <- MBREstimator(x, PM)) +system.time(RMX3i <- RMXEstimator(x, PM)) +system.time(MBR3c <- MBREstimator(xc, PM)) +system.time(RMX3c <- RMXEstimator(xc, PM)) estimate(mlE3i) estimate(MBR3i) estimate(RMX3i) @@ -314,13 +318,15 @@ ####################################################### WF <- WeibullFamily() system.time(mlE4i <- MLEstimator(grbsi, WF)) -system.time(MBR4i <- roptest(grbsi, WF,risk=MBRRisk())) -system.time(OMS4i <- roptest(grbsi, WF,risk=OMSRRisk())) -system.time(RMX4i <- roptest(grbsi, WF,risk=RMXRRisk())) +system.time(MBR4i <- MBREstimator(grbsi, WF)) +system.time(OMS4i <- OMSEstimator(grbsi, WF)) +## synonymous to +## system.time(OMS4i <- roptest(grbsi, WF, risk= OMSRRisk())) +system.time(RMX4i <- RMXEstimator(grbsi, WF)) system.time(mlE4c <- MLEstimator(grbsc, WF)) -system.time(MBR4c <- roptest(grbsc, WF,risk=MBRRisk())) -system.time(OMS4c <- roptest(grbsc, WF,risk=OMSRRisk())) -system.time(RMX4c <- roptest(grbsc, WF,risk=RMXRRisk())) +system.time(MBR4c <- MBREstimator(grbsc, WF)) +system.time(OMS4c <- OMSEstimator(grbsc, WF)) +system.time(RMX4c <- RMXEstimator(grbsc, WF)) estimate(mlE4i) estimate(MBR4i) estimate(RMX4i) @@ -344,13 +350,13 @@ GF <- GammaFamily() system.time(mlE5i <- MLEstimator(grbsi, GF)) -system.time(OMS5i <- roptest(grbsi, GF,risk=OMSRRisk())) -system.time(RMX5i <- roptest(grbsi, GF,risk=RMXRRisk())) -system.time(MBR5i <- roptest(grbsi, GF,risk=MBRRisk())) +system.time(OMS5i <- MBREstimator(grbsi, GF)) +system.time(RMX5i <- OMSEstimator(grbsi, GF)) +system.time(MBR5i <- RMXEstimator(grbsi, GF)) system.time(mlE5c <- MLEstimator(grbsc, GF)) -system.time(OMS5c <- roptest(grbsc, GF,risk=OMSRRisk())) -system.time(RMX5c <- roptest(grbsc, GF,risk=RMXRRisk())) -system.time(MBR5c <- roptest(grbsc, GF,risk=MBRRisk())) +system.time(OMS5c <- MBREstimator(grbsc, GF)) +system.time(RMX5c <- OMSEstimator(grbsc, GF)) +system.time(MBR5c <- RMXEstimator(grbsc, GF)) estimate(mlE5i) estimate(RMX5i) estimate(OMS5i) Modified: branches/robast-1.1/pkg/RobExtremes/man/0RobExtremes-package.Rd =================================================================== --- branches/robast-1.1/pkg/RobExtremes/man/0RobExtremes-package.Rd 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/man/0RobExtremes-package.Rd 2018-08-01 03:02:30 UTC (rev 1082) @@ -19,7 +19,7 @@ \item Generalized Extreme Value distribution (GEVD) \item Generalized Pareto distribution (GPD) \item Pareto distribution} -\cr +%\cr } \section{Functionals for Distributions}{ @@ -37,7 +37,7 @@ In addition, extending estimators \code{Sn} and \code{Qn} from package \pkg{robustbase}, we provide functionals for Sn and Qn. A new asymmetric version of the \code{mad}, \code{kMAD} gives yet another robust -scale estimator (and functional). \cr +scale estimator (and functional). %\cr } \section{Models and Estimators}{ @@ -68,7 +68,7 @@ } For all these families, of course, MLEs and Minimum-Distance-Estimators -are also available through package "distrMod". \cr +are also available through package "distrMod". %\cr } \section{Diagnostics}{ @@ -87,7 +87,7 @@ \itemize{ \item qqplots (with confidence bands) via \code{qqplot} \item returnlevel plots via \code{returnlevelplot} -}\cr +}%\cr } \section{Starting Point}{ @@ -96,7 +96,8 @@ accessible by \code{file.path(system.file(package="RobExtremes"), "scripts/RobFitsAtRealData.R")}. -\cr} +%\cr +} \details{ \tabular{ll}{ @@ -114,10 +115,11 @@ Authors: \tab Bernhard Spangl [contributed smoothed grid values of the Lagrange multipliers]\cr \tab Sascha Desmettre [contributed smoothed grid values of the Lagrange multipliers]\cr -\tab Eugen Massini [contributed an interactive smoothing routine for smoothing the - Lagrange multipliers and smoothed grid values of the Lagrange multipliers] \cr +\tab Eugen Massini [contributed an interactive smoothing routine for smoothing the\cr +\tab Lagrange multipliers and smoothed grid values of the Lagrange multipliers] \cr \tab Daria Pupashenko [contributed MDE-estimation for GEV distribution in -the framework of her PhD thesis 2011--14]\cr +the framework of\cr +\tab her PhD thesis 2011--14]\cr \tab Gerald Kroisandt [contributed testing routines]\cr \tab Nataliya Horbenko ["aut","cph"] \cr \tab Matthias Kohl ["aut", "cph"]\cr @@ -136,7 +138,8 @@ \preformatted{ [*]: there is a generating function with the same name in RobExtremes -[**]: generating function from distrMod, but with (speeded-up) opt.rob-estimators in RobExtremes +[**]: generating function from distrMod, but with (speeded-up) + opt.rob-estimators in RobExtremes ########################## Distribution Classes @@ -188,7 +191,8 @@ \section{Functions}{ \preformatted{ -LDEstimator Estimators for scale-shape models based on location and dispersion +LDEstimator Estimators for scale-shape models based on + location and dispersion medSn loc=median disp=Sn medQn loc=median disp=Qn medkMAD loc=median disp=kMAD @@ -219,13 +223,15 @@ \preformatted{ Functionals: -E Generic function for the computation of (conditional) expectations +E Generic function for the computation of + (conditional) expectations var Generic functions for the computation of functionals IQR Generic functions for the computation of functionals median Generic functions for the computation of functionals skewness Generic functions for the computation of functionals kurtosis Generic functions for the computation of functionals -Sn Generic function for the computation of (conditional) expectations +Sn Generic function for the computation of (conditional) + expectations Qn Generic functions for the computation of functionals } @@ -247,7 +253,7 @@ (and gratefully ackknowledged). Thanks also goes to the maintainers of CRAN, in particully to Uwe Ligges who greatly helped us with finding an appropriate way to store the database of interpolating functions which allow the speed up --- this is now package RobAStRDA on CRAN.\cr +-- this is now package RobAStRDA on CRAN. %\cr } \author{ Modified: branches/robast-1.1/pkg/RobExtremes/man/GEVFamily.Rd =================================================================== --- branches/robast-1.1/pkg/RobExtremes/man/GEVFamily.Rd 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/man/GEVFamily.Rd 2018-08-01 03:02:30 UTC (rev 1082) @@ -8,9 +8,9 @@ } \usage{ GEVFamily(loc = 0, scale = 1, shape = 0.5, of.interest = c("scale", "shape"), - p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE, - secLevel = 0.7, withCentL2 = FALSE, withL2derivDistr = FALSE, - withMDE = FALSE, ..ignoreTrafo = FALSE, ..withWarningGEV = TRUE) + p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE, + secLevel = 0.7, withCentL2 = FALSE, withL2derivDistr = FALSE, + withMDE = FALSE, ..ignoreTrafo = FALSE, ..withWarningGEV = TRUE) } \arguments{ \item{loc}{ real: known/fixed threshold/location parameter } Modified: branches/robast-1.1/pkg/RobExtremes/man/GParetoFamily.Rd =================================================================== --- branches/robast-1.1/pkg/RobExtremes/man/GParetoFamily.Rd 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/man/GParetoFamily.Rd 2018-08-01 03:02:30 UTC (rev 1082) @@ -8,9 +8,9 @@ } \usage{ GParetoFamily(loc = 0, scale = 1, shape = 0.5, of.interest = c("scale", "shape"), - p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE, - secLevel = 0.7, withCentL2 = FALSE, withL2derivDistr = FALSE, - withMDE = FALSE, ..ignoreTrafo = FALSE) + p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE, + secLevel = 0.7, withCentL2 = FALSE, withL2derivDistr = FALSE, + withMDE = FALSE, ..ignoreTrafo = FALSE) } \arguments{ \item{loc}{ real: known/fixed threshold/location parameter } Modified: branches/robast-1.1/pkg/RobExtremes/man/WeibullFamily.Rd =================================================================== --- branches/robast-1.1/pkg/RobExtremes/man/WeibullFamily.Rd 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/man/WeibullFamily.Rd 2018-08-01 03:02:30 UTC (rev 1082) @@ -8,8 +8,8 @@ } \usage{ WeibullFamily(scale = 1, shape = 0.5, of.interest = c("scale", "shape"), - p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE, - withCentL2 = FALSE, withL2derivDistr = FALSE, ..ignoreTrafo = FALSE) + p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE, + withCentL2 = FALSE, withL2derivDistr = FALSE, ..ignoreTrafo = FALSE) } \arguments{ \item{scale}{ positive real: scale parameter } Modified: branches/robast-1.1/pkg/RobExtremes/man/getStartIC-methods.Rd =================================================================== --- branches/robast-1.1/pkg/RobExtremes/man/getStartIC-methods.Rd 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/man/getStartIC-methods.Rd 2018-08-01 03:02:30 UTC (rev 1082) @@ -12,12 +12,25 @@ argument \code{ICstart} in \code{kStepEstimator}.} \usage{getStartIC(model, risk, ...) +\S4method{getStartIC}{L2ScaleShapeUnion,interpolRisk}(model, risk, ..., + withMakeIC = FALSE, ..debug=FALSE, modifyICwarn = NULL) +\S4method{getStartIC}{L2LocScaleShapeUnion,interpolRisk}(model, risk, ..., + withMakeIC = FALSE, ..debug=FALSE, modifyICwarn = NULL) +\S4method{getStartIC}{ParetoFamily,interpolRisk}(model, risk, ..., + withMakeIC = FALSE) } \arguments{ \item{model}{normtype of class \code{NormType}} \item{risk}{normtype of class \code{NormType}} \item{\dots}{ further arguments to be passed to specific methods.} + \item{withMakeIC}{logical; if \code{TRUE} the IC is passed through + \code{makeIC} before return.} + \item{..debug}{logical; if \code{TRUE} information for debugging is issued.} + \item{modifyICwarn}{logical: should a (warning) information be added if + \code{modifyIC} is applied and hence some optimality information could + no longer be valid? Defaults to \code{NULL} in which case this value + is taken from \code{RobAStBaseOptions}.} } \section{Methods}{\describe{ \item{getStartIC}{\code{signature(model = "L2ScaleShapeUnion", risk = "interpolRisk")}: Modified: branches/robast-1.1/pkg/RobExtremes/man/internal-methods.Rd =================================================================== --- branches/robast-1.1/pkg/RobExtremes/man/internal-methods.Rd 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/man/internal-methods.Rd 2018-08-01 03:02:30 UTC (rev 1082) @@ -6,14 +6,17 @@ \alias{.checkEstClassForParamFamily,GParetoFamily,LDEstimate-method} \alias{.checkEstClassForParamFamily,GParetoFamily,MCEstimate-method} \alias{.checkEstClassForParamFamily,GParetoFamily,kStepEstimate-method} +\alias{.checkEstClassForParamFamily,GParetoFamily,ORobEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,Estimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,MCEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,LDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,kStepEstimate-method} +\alias{.checkEstClassForParamFamily,GEVFamily,ORobEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,Estimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,MCEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,LDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,kStepEstimate-method} +\alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,ORobEstimate-method} \title{ Methods for Function .checkEstClassForParamFamily in Package `RobExtremes' } \description{.checkEstClassForParamFamily-methods} %\usage{.checkEstClassForParamFamily(PFam, estimator) @@ -41,29 +44,29 @@ \value{ The \code{GParetoFamily,Estimate}-method returns the estimator cast to -S4 class \code{GPDEstimate}, +S4 class \code{GPDEstimate},\cr the \code{GParetoFamily,LDEstimate}-method cast to -S4 class \code{GPDLDEstimate}, +S4 class \code{GPDLDEstimate},\cr the \code{GParetoFamily,MCEstimate}-method cast to -S4 class \code{GPDMCEstimate}, +S4 class \code{GPDMCEstimate},\cr the \code{GParetoFamily,kStepEstimate}-method cast to -S4 class \code{GPDkStepstimate}, +S4 class \code{GPDkStepstimate},\cr the \code{GEVFamily,Estimate}-method cast to -S4 class \code{GEVEstimate}, +S4 class \code{GEVEstimate},\cr the \code{GEVFamily,LDEstimate}-method cast to -S4 class \code{GEVLDEstimate}, +S4 class \code{GEVLDEstimate},\cr the \code{GEVFamily,MCEstimate}-method cast to -S4 class \code{GEVMCEstimate}, +S4 class \code{GEVMCEstimate},\cr the \code{GEVFamily,kStepEstimate}-method cast to -S4 class \code{GEVkStepstimate}. +S4 class \code{GEVkStepstimate},\cr the \code{GEVFamilyMuUnknown,Estimate}-method cast to -S4 class \code{GEVEstimate}, +S4 class \code{GEVEstimate},\cr the \code{GEVFamilyMuUnknown,LDEstimate}-method cast to -S4 class \code{GEVLDEstimate}, +S4 class \code{GEVLDEstimate},\cr the \code{GEVFamilyMuUnknown,MCEstimate}-method cast to -S4 class \code{GEVMCEstimate}, +S4 class \code{GEVMCEstimate},\cr the \code{GEVFamilyMuUnknown,kStepEstimate}-method cast to -S4 class \code{GEVkStepstimate}. +S4 class \code{GEVkStepstimate}.\cr } \author{ Peter Ruckdeschel \email{peter.ruckdeschel at uni-oldenburg.de} Modified: branches/robast-1.1/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd =================================================================== --- branches/robast-1.1/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.1/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd 2018-08-01 03:02:30 UTC (rev 1082) @@ -9,6 +9,8 @@ \alias{GEVLDEstimate-class} \alias{GPDkStepEstimate-class} \alias{GEVkStepEstimate-class} +\alias{GPDORobEstimate-class} +\alias{GEVORobEstimate-class} \title{Internal Estimator Return Classes in 'RobExtremes'} \description{S4 classes for return values of estimators in package \pkg{RobExtremes} defined for internal @@ -18,7 +20,8 @@ The S4 classes described here are \code{GPDEstimate}, \code{GEVEstimate}, \code{GPDMCEstimate}, \code{GEVMCEstimate}, \code{GPDLDEstimate}, \code{GEVLDEstimate}, - \code{GPDkStepEstimate}, \code{GEVkStepEstimate}.} + \code{GPDkStepEstimate}, \code{GEVkStepEstimate} + \code{GPDORobEstimate}, \code{GEVORobEstimate}.} \section{Objects from the Class}{These classes are used internally to provide specific S4 methods for different estimators later on; @@ -41,6 +44,10 @@ \code{kStepEstimate}, directly.\cr Class \code{GEVkStepEstimate} extends classes \code{GEVEstimate}, \code{kStepEstimate}, directly.\cr +Class \code{GPDORobEstimate} extends classes \code{GPDkStepEstimate}, +\code{ORobEstimate}, directly.\cr +Class \code{GEVORobEstimate} extends classes \code{GEVkStepEstimate}, +\code{ORobEstimate}, directly.\cr } %\references{} \author{Peter Ruckdeschel \email{peter.ruckdeschel at uni-oldenburg.de}} Modified: branches/robast-1.2/pkg/ROptEst/R/roptest.new.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-01 03:02:30 UTC (rev 1082) @@ -138,7 +138,7 @@ retV at estimate.call <- mc tim <- attr(retV,"timings") - retV <- as(retV, "ORobEstimate") + retV <- as(as(retV,"kStepEstimate"), "ORobEstimate") retV <- .checkEstClassForParamFamily(L2Fam,retV) attr(retV,"timings") <- tim retV at roptestCall <- mc Modified: branches/robast-1.2/pkg/RobExtremes/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/RobExtremes/NAMESPACE 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.2/pkg/RobExtremes/NAMESPACE 2018-08-01 03:02:30 UTC (rev 1082) @@ -31,7 +31,8 @@ exportClasses("L2LocScaleShapeUnion") exportClasses("GPDEstimate","GPDMCEstimate","GPDLDEstimate", "GPDkStepEstimate","GEVEstimate","GEVLDEstimate", - "GEVkStepEstimate","GEVMCEstimate") + "GEVkStepEstimate","GEVMCEstimate", + "GPDORobEstimate","GEVORobEstimate") exportMethods("initialize", "show", "rescaleFunction") exportMethods("loc", "loc<-", "kMAD", "Sn", "Qn") exportMethods("validParameter", Modified: branches/robast-1.2/pkg/RobExtremes/R/AllClass.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/AllClass.R 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.2/pkg/RobExtremes/R/AllClass.R 2018-08-01 03:02:30 UTC (rev 1082) @@ -288,7 +288,9 @@ setClass("GPDMCEstimate", contains=c("MCEstimate", "GPDEstimate")) setClass("GPDLDEstimate", contains=c("LDEstimate", "GPDEstimate")) setClass("GPDkStepEstimate", contains=c("kStepEstimate", "GPDEstimate")) +setClass("GPDORobEstimate", contains=c("ORobEstimate", "GPDkStepEstimate")) setClass("GEVEstimate", contains="Estimate") setClass("GEVLDEstimate", contains=c("LDEstimate", "GEVEstimate")) setClass("GEVkStepEstimate", contains=c("kStepEstimate", "GEVEstimate")) +setClass("GEVORobEstimate", contains=c("ORobEstimate", "GEVkStepEstimate")) setClass("GEVMCEstimate", contains=c("MCEstimate", "GEVEstimate")) Modified: branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-08-01 03:02:30 UTC (rev 1082) @@ -8,6 +8,9 @@ signature=signature(PFam="GParetoFamily",estimator="kStepEstimate"), function(PFam, estimator) as(estimator,"GPDkStepEstimate")) setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GParetoFamily",estimator="ORobEstimate"), + function(PFam, estimator) as(estimator,"GPDORobEstimate")) +setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GParetoFamily",estimator="MCEstimate"), function(PFam, estimator) as(estimator,"GPDMCEstimate")) setMethod(".checkEstClassForParamFamily", @@ -20,6 +23,9 @@ signature=signature(PFam="GEVFamily",estimator="kStepEstimate"), function(PFam, estimator) as(estimator,"GEVkStepEstimate")) setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamily",estimator="ORobEstimate"), + function(PFam, estimator) as(estimator,"GEVORobEstimate")) +setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamily",estimator="MCEstimate"), function(PFam, estimator) as(estimator,"GEVMCEstimate")) setMethod(".checkEstClassForParamFamily", @@ -32,5 +38,8 @@ signature=signature(PFam="GEVFamilyMuUnknown",estimator="kStepEstimate"), function(PFam, estimator) as(estimator,"GEVkStepEstimate")) setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamilyMuUnknown",estimator="ORobEstimate"), + function(PFam, estimator) as(estimator,"GEVORobEstimate")) +setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCEstimate"), function(PFam, estimator) as(estimator,"GEVMCEstimate")) Modified: branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R 2018-08-01 03:02:30 UTC (rev 1082) @@ -1,15 +1,11 @@ setMethod("getStartIC",signature(model = "L2ScaleShapeUnion", risk = "interpolRisk"), - function(model, risk, ...){ + function(model, risk, ..., withMakeIC = FALSE, ..debug=FALSE, + modifyICwarn = NULL){ mc <- match.call(call = sys.call(sys.parent(1))) - dots <- match.call(call = sys.call(sys.parent(1)), - expand.dots = FALSE)$"..." mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias() mc$neighbor <- ContNeighborhood(radius=0.5) - withMakeIC <- FALSE - if(!is.null(dots$withMakeIC)) withMakeIC <- dots$withMakeIC - gridn <- gsub("\\.","",type(risk)) nam <- paste(".",gsub("[F,f]amily","",gsub(" ","",name(model))),sep="") @@ -76,15 +72,13 @@ }) setMethod("getStartIC",signature(model = "L2LocScaleShapeUnion", risk = "interpolRisk"), - function(model, risk, ...){ + function(model, risk, ..., withMakeIC = FALSE, ..debug=FALSE, + modifyICwarn = NULL){ mc <- match.call(call = sys.call(sys.parent(1))) - dots <- match.call(call = sys.call(sys.parent(1)), - expand.dots = FALSE)$"..." mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias() mc$neighbor <- ContNeighborhood(radius=0.5) - withMakeIC <- FALSE gridn <- gsub("\\.","",type(risk)) Modified: branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R 2018-08-01 01:09:59 UTC (rev 1081) +++ branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R 2018-08-01 03:02:30 UTC (rev 1082) @@ -1,13 +1,6 @@ setMethod("getStartIC",signature(model = "ParetoFamily", risk = "interpolRisk"), - function(model, risk, ...){ + function(model, risk, ..., withMakeIC = FALSE){ - mc <- match.call(call = sys.call(sys.parent(1))) - dots <- match.call(call = sys.call(sys.parent(1)), - expand.dots = FALSE)$"..." - - withMakeIC <- FALSE - if(!is.null(dots$withMakeIC)) withMakeIC <- dots$withMakeIC - param1 <- param(model) xi <- main(param1) [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/robast -r 1082 From noreply at r-forge.r-project.org Wed Aug 1 05:06:52 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 1 Aug 2018 05:06:52 +0200 (CEST) Subject: [Robast-commits] r1083 - in pkg: ROptEst ROptEst/man ROptEstOld ROptRegTS RandVar RandVar/man RobAStBase RobAStBase/man RobAStRDA RobAStRDA/man RobExtremes RobLox RobLox/man RobLoxBioC RobLoxBioC/man RobRex Message-ID: <20180801030652.34D6D1899CB@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-01 05:06:49 +0200 (Wed, 01 Aug 2018) New Revision: 1083 Modified: pkg/ROptEst/DESCRIPTION pkg/ROptEst/man/0ROptEst-package.Rd pkg/ROptEstOld/DESCRIPTION pkg/ROptRegTS/DESCRIPTION pkg/RandVar/DESCRIPTION pkg/RandVar/man/0RandVar-package.Rd pkg/RobAStBase/DESCRIPTION pkg/RobAStBase/man/0RobAStBase-package.Rd pkg/RobAStRDA/DESCRIPTION pkg/RobAStRDA/man/0RobRDA-package.Rd pkg/RobExtremes/DESCRIPTION pkg/RobLox/DESCRIPTION pkg/RobLox/man/0RobLox-package.Rd pkg/RobLoxBioC/DESCRIPTION pkg/RobLoxBioC/man/0RobLoxBioC-package.Rd pkg/RobRex/DESCRIPTION Log: in trunk: updated date and svnrev Modified: pkg/ROptEst/DESCRIPTION =================================================================== --- pkg/ROptEst/DESCRIPTION 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/ROptEst/DESCRIPTION 2018-08-01 03:06:49 UTC (rev 1083) @@ -1,21 +1,22 @@ Package: ROptEst Version: 1.1.0 -Date: 2018-07-25 +Date: 2018-08-01 Title: Optimally Robust Estimation -Description: Optimally robust estimation in general smoothly parameterized models using S4 classes and - methods. -Depends: R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), RandVar(>= 0.9.2), - RobAStBase(>= 1.0) -Imports: startupmsg, MASS, stats, graphics, utils, grDevices +Description: Optimally robust estimation in general smoothly parameterized models using S4 + classes and methods. +Depends: R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), + RandVar(>= 0.9.2), RobAStBase(>= 1.0) +Imports: startupmsg, MASS, stats, graphics, utils, grDevices Suggests: RobLox -Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph"), email="Matthias.Kohl at stamats.de"), - person("Mykhailo", "Pupashenko", role="ctb", comment="contributed wrapper functions for diagnostic - plots"), person("Gerald", "Kroisandt", role="ctb", comment="contributed testing routines"), - person("Peter", "Ruckdeschel", role=c("aut", "cph"))) +Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph"), + email="Matthias.Kohl at stamats.de"), person("Mykhailo", "Pupashenko", role="ctb", + comment="contributed wrapper functions for diagnostic plots"), person("Gerald", + "Kroisandt", role="ctb", comment="contributed testing routines"), person("Peter", + "Ruckdeschel", role=c("aut", "cph"))) ByteCompile: yes License: LGPL-3 URL: http://robast.r-forge.r-project.org/ Encoding: latin1 LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1057 +VCS/SVNRevision: 1081 Modified: pkg/ROptEst/man/0ROptEst-package.Rd =================================================================== --- pkg/ROptEst/man/0ROptEst-package.Rd 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/ROptEst/man/0ROptEst-package.Rd 2018-08-01 03:06:49 UTC (rev 1083) @@ -13,7 +13,7 @@ \tabular{ll}{ Package: \tab ROptEst \cr Version: \tab 1.1.0 \cr -Date: \tab 2018-07-25 \cr +Date: \tab 2018-08-01 \cr Depends: \tab R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), RandVar(>= 0.9.2), RobAStBase(>= 1.0) \cr Suggests: \tab RobLox\cr @@ -22,7 +22,7 @@ Encoding: \tab latin1 \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1057 \cr +VCS/SVNRevision: \tab 1081 \cr } } \author{ Modified: pkg/ROptEstOld/DESCRIPTION =================================================================== --- pkg/ROptEstOld/DESCRIPTION 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/ROptEstOld/DESCRIPTION 2018-08-01 03:06:49 UTC (rev 1083) @@ -1,15 +1,16 @@ Package: ROptEstOld Version: 1.1.0 -Date: 2018-07-25 +Date: 2018-08-01 Title: Optimally Robust Estimation - Old Version -Description: Optimally robust estimation using S4 classes and methods. Old version still needed for current - versions of ROptRegTS and RobRex. +Description: Optimally robust estimation using S4 classes and methods. Old version still needed + for current versions of ROptRegTS and RobRex. Depends: R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.2), RandVar(>= 0.9.2), evd -Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), email="Matthias.Kohl at stamats.de") +Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), + email="Matthias.Kohl at stamats.de") ByteCompile: yes License: LGPL-3 URL: http://robast.r-forge.r-project.org/ Encoding: latin1 LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1057 +VCS/SVNRevision: 1081 Modified: pkg/ROptRegTS/DESCRIPTION =================================================================== --- pkg/ROptRegTS/DESCRIPTION 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/ROptRegTS/DESCRIPTION 2018-08-01 03:06:49 UTC (rev 1083) @@ -1,16 +1,18 @@ Package: ROptRegTS Version: 1.1.0 -Date: 2018-07-25 +Date: 2018-08-01 Title: Optimally Robust Estimation for Regression-Type Models -Description: Optimally robust estimation for regression-type models using S4 classes and methods. +Description: Optimally robust estimation for regression-type models using S4 classes and + methods. Depends: R (>= 2.14.0), methods, ROptEstOld(>= 0.9.1) Imports: distr(>= 2.5.2), distrEx(>= 2.5), RandVar(>= 0.9.2) -Authors at R: c(person("Matthias", "Kohl", role=c("cre", "aut", "cph"), email="Matthias.Kohl at stamats.de"), - person("Peter", "Ruckdeschel", role=c("aut", "cph"))) +Authors at R: c(person("Matthias", "Kohl", role=c("cre", "aut", "cph"), + email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", role=c("aut", + "cph"))) ByteCompile: yes License: LGPL-3 Encoding: latin1 URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1057 +VCS/SVNRevision: 1081 Modified: pkg/RandVar/DESCRIPTION =================================================================== --- pkg/RandVar/DESCRIPTION 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/RandVar/DESCRIPTION 2018-08-01 03:06:49 UTC (rev 1083) @@ -1,12 +1,13 @@ Package: RandVar Version: 1.1.0 -Date: 2018-07-25 +Date: 2018-08-01 Title: Implementation of Random Variables Description: Implements random variables by means of S4 classes and methods. Depends: R (>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5) Imports: startupmsg -Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), email="Matthias.Kohl at stamats.de"), - person("Peter", "Ruckdeschel", role=c("aut", "cph"))) +Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), + email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", role=c("aut", + "cph"))) ByteCompile: yes LazyLoad: yes License: LGPL-3 @@ -14,4 +15,4 @@ URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1057 +VCS/SVNRevision: 1081 Modified: pkg/RandVar/man/0RandVar-package.Rd =================================================================== --- pkg/RandVar/man/0RandVar-package.Rd 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/RandVar/man/0RandVar-package.Rd 2018-08-01 03:06:49 UTC (rev 1083) @@ -12,14 +12,14 @@ \tabular{ll}{ Package: \tab RandVar \cr Version: \tab 1.1.0 \cr -Date: \tab 2018-07-25 \cr +Date: \tab 2018-08-01 \cr Depends: \tab R (>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5)\cr Imports: \tab startupmsg \cr ByteCompile: \tab yes \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1057 \cr +VCS/SVNRevision: \tab 1081 \cr } } \author{ Modified: pkg/RobAStBase/DESCRIPTION =================================================================== --- pkg/RobAStBase/DESCRIPTION 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/RobAStBase/DESCRIPTION 2018-08-01 03:06:49 UTC (rev 1083) @@ -1,21 +1,22 @@ Package: RobAStBase Version: 1.1.0 -Date: 2018-07-25 +Date: 2018-08-01 Title: Robust Asymptotic Statistics Description: Base S4-classes and functions for robust asymptotic statistics. -Depends: R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), RandVar(>= - 0.9.2) +Depends: R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), + RandVar(>= 0.9.2) Suggests: ROptEst(>=1.1.0), RUnit(>= 0.4.26) Imports: startupmsg, graphics, grDevices, stats -Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), email="Matthias.Kohl at stamats.de"), - person("Peter", "Ruckdeschel",role=c("aut", "cph")), person("Mykhailo", "Pupashenko", role="ctb", - comment="contributed wrapper functions for diagnostic plots"), person("Gerald", "Kroisandt", - role="ctb", comment="contributed testing routines"), person("R Core Team", role = c("ctb", "cph"), - comment="for source file 'format.perc'")) +Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), + email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel",role=c("aut", "cph")), + person("Mykhailo", "Pupashenko", role="ctb", comment="contributed wrapper functions for + diagnostic plots"), person("Gerald", "Kroisandt", role="ctb", comment="contributed + testing routines"), person("R Core Team", role = c("ctb", "cph"), comment="for source + file 'format.perc'")) ByteCompile: yes License: LGPL-3 Encoding: latin1 URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1057 +VCS/SVNRevision: 1081 Modified: pkg/RobAStBase/man/0RobAStBase-package.Rd =================================================================== --- pkg/RobAStBase/man/0RobAStBase-package.Rd 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/RobAStBase/man/0RobAStBase-package.Rd 2018-08-01 03:06:49 UTC (rev 1083) @@ -12,7 +12,7 @@ \tabular{ll}{ Package: \tab RobAStBase \cr Version: \tab 1.1.0 \cr -Date: \tab 2018-07-25 \cr +Date: \tab 2018-08-01 \cr Depends: \tab R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), RandVar(>= 0.9.2)\cr Suggests: \tab ROptEst, RUnit (>= 0.4.26)\cr @@ -21,7 +21,7 @@ Encoding: \tab latin1 \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1057 \cr +VCS/SVNRevision: \tab 1081 \cr } } \author{ Modified: pkg/RobAStRDA/DESCRIPTION =================================================================== --- pkg/RobAStRDA/DESCRIPTION 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/RobAStRDA/DESCRIPTION 2018-08-01 03:06:49 UTC (rev 1083) @@ -1,24 +1,25 @@ Package: RobAStRDA Version: 1.1.0 -Date: 2018-07-25 +Date: 2018-08-01 Title: Interpolation Grids for Packages of the 'RobASt' - Family of Packages -Description: Includes 'sysdata.rda' file for packages of the 'RobASt' - family of packages; is currently used - by package 'RobExtremes' only. +Description: Includes 'sysdata.rda' file for packages of the 'RobASt' - family of packages; is + currently used by package 'RobExtremes' only. Depends: R (>= 2.3.0) -Authors at R: c(person("Matthias", "Kohl", role=c("aut", "cph")), person("Bernhard", "Spangl",role="ctb", - comment="contributed smoothed grid values of the Lagrange multipliers"), person("Sascha", - "Desmettre", role="ctb", comment="contributed smoothed grid values of the Lagrange multipliers"), - person("Eugen", "Massini", role="ctb", comment="contributed an interactive smoothing routine for - smoothing the Lagrange multipliers and smoothed grid values of the Lagrange multipliers"), - person("Mykhailo", "Pupashenko", role="ctb", comment="helped with manual smoothing of the - interpolators"), person("Daria", "Pupashenko", role="ctb", comment="helped with manual smoothing of - the interpolators"), person("Gerald", "Kroisandt", role="ctb", comment="helped with manual smoothing - of the interpolators"), person("Peter", "Ruckdeschel", role=c("cre", "cph", "aut"), - email="peter.ruckdeschel at uni-oldenburg.de")) +Authors at R: c(person("Matthias", "Kohl", role=c("aut", "cph")), person("Bernhard", + "Spangl",role="ctb", comment="contributed smoothed grid values of the Lagrange + multipliers"), person("Sascha", "Desmettre", role="ctb", comment="contributed smoothed + grid values of the Lagrange multipliers"), person("Eugen", "Massini", role="ctb", + comment="contributed an interactive smoothing routine for smoothing the Lagrange + multipliers and smoothed grid values of the Lagrange multipliers"), person("Mykhailo", + "Pupashenko", role="ctb", comment="helped with manual smoothing of the interpolators"), + person("Daria", "Pupashenko", role="ctb", comment="helped with manual smoothing of the + interpolators"), person("Gerald", "Kroisandt", role="ctb", comment="helped with manual + smoothing of the interpolators"), person("Peter", "Ruckdeschel", role=c("cre", "cph", + "aut"), email="peter.ruckdeschel at uni-oldenburg.de")) LazyData: yes ByteCompile: yes License: LGPL-3 URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1057 +VCS/SVNRevision: 1081 Modified: pkg/RobAStRDA/man/0RobRDA-package.Rd =================================================================== --- pkg/RobAStRDA/man/0RobRDA-package.Rd 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/RobAStRDA/man/0RobRDA-package.Rd 2018-08-01 03:06:49 UTC (rev 1083) @@ -32,13 +32,13 @@ \tabular{ll}{ Package: \tab RobAStRDA \cr Version: \tab 1.1.0 \cr -Date: \tab 2018-07-25 \cr +Date: \tab 2018-08-01 \cr Depends: \tab R (>= 2.3.0) \cr LazyData: \tab yes \cr ByteCompile: \tab yes \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1057 \cr +VCS/SVNRevision: \tab 1081 \cr } } Modified: pkg/RobExtremes/DESCRIPTION =================================================================== --- pkg/RobExtremes/DESCRIPTION 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/RobExtremes/DESCRIPTION 2018-08-01 03:06:49 UTC (rev 1083) @@ -1,22 +1,24 @@ Package: RobExtremes Version: 1.1.0 -Date: 2018-07-25 +Date: 2018-08-01 Title: Optimally Robust Estimation for Extreme Value Distributions Description: Optimally robust estimation for extreme value distributions using S4 classes and - methods (based on packages 'distr', 'distrEx', 'distrMod', 'RobAStBase', and 'ROptEst'). + methods (based on packages 'distr', 'distrEx', 'distrMod', 'RobAStBase', and + 'ROptEst'). Depends: R (>= 2.14.0), methods, distrMod(>= 2.5.2), ROptEst(>= 1.0), robustbase, evd Suggests: RUnit (>= 0.4.26), ismev (>= 1.39) Imports: RobAStRDA, distr, distrEx, RandVar, RobAStBase, startupmsg, actuar -Authors at R: c(person("Nataliya", "Horbenko", role=c("aut","cph")), person("Bernhard", "Spangl", role="ctb", - comment="contributed smoothed grid values of the Lagrange multipliers"), person("Sascha", - "Desmettre", role="ctb", comment="contributed smoothed grid values of the Lagrange multipliers"), - person("Eugen", "Massini", role="ctb", comment="contributed an interactive smoothing routine for - smoothing the Lagrange multipliers and smoothed grid values of the Lagrange multipliers"), - person("Daria", "Pupashenko", role="ctb", comment="contributed MDE-estimation for GEV distribution - in the framework of her PhD thesis 2011--14"), person("Gerald", "Kroisandt", role="ctb", - comment="contributed testing routines"), person("Matthias", "Kohl", role=c("aut", "cph")), - person("Peter", "Ruckdeschel", role=c("cre", "aut", "cph"), - email="peter.ruckdeschel at uni-oldenburg.de")) +Authors at R: c(person("Nataliya", "Horbenko", role=c("aut","cph")), person("Bernhard", "Spangl", + role="ctb", comment="contributed smoothed grid values of the Lagrange multipliers"), + person("Sascha", "Desmettre", role="ctb", comment="contributed smoothed grid values of + the Lagrange multipliers"), person("Eugen", "Massini", role="ctb", comment="contributed + an interactive smoothing routine for smoothing the Lagrange multipliers and smoothed + grid values of the Lagrange multipliers"), person("Daria", "Pupashenko", role="ctb", + comment="contributed MDE-estimation for GEV distribution in the framework of her PhD + thesis 2011--14"), person("Gerald", "Kroisandt", role="ctb", comment="contributed + testing routines"), person("Matthias", "Kohl", role=c("aut", "cph")), person("Peter", + "Ruckdeschel", role=c("cre", "aut", "cph"), + email="peter.ruckdeschel at uni-oldenburg.de")) ByteCompile: yes LazyLoad: yes License: LGPL-3 @@ -24,4 +26,4 @@ URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1057 +VCS/SVNRevision: 1081 Modified: pkg/RobLox/DESCRIPTION =================================================================== --- pkg/RobLox/DESCRIPTION 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/RobLox/DESCRIPTION 2018-08-01 03:06:49 UTC (rev 1083) @@ -1,18 +1,19 @@ Package: RobLox Version: 1.1.0 -Date: 2018-07-25 +Date: 2018-08-01 Title: Optimally Robust Influence Curves and Estimators for Location and Scale -Description: Functions for the determination of optimally robust influence curves and estimators in case of - normal location and/or scale. +Description: Functions for the determination of optimally robust influence curves and + estimators in case of normal location and/or scale. Depends: R(>= 2.14.0), stats, distrMod(>= 2.5.2), RobAStBase(>= 0.9) Imports: methods, lattice, RColorBrewer, Biobase, RandVar(>= 0.9.2), distr(>= 2.5.2) Suggests: MASS -Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph"), email="Matthias.Kohl at stamats.de"), - person("Peter", "Ruckdeschel", role=c("aut", "cph"))) +Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph"), + email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", role=c("aut", + "cph"))) ByteCompile: yes License: LGPL-3 Encoding: latin1 URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1057 +VCS/SVNRevision: 1081 Modified: pkg/RobLox/man/0RobLox-package.Rd =================================================================== --- pkg/RobLox/man/0RobLox-package.Rd 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/RobLox/man/0RobLox-package.Rd 2018-08-01 03:06:49 UTC (rev 1083) @@ -13,14 +13,14 @@ \tabular{ll}{ Package: \tab RobLox \cr Version: \tab 1.1.0 \cr -Date: \tab 2018-07-25 \cr +Date: \tab 2018-08-01 \cr Depends: \tab R(>= 2.14.0), stats, distrMod(>= 2.5.2), RobAStBase(>= 0.9) \cr Imports: \tab lattice, RColorBrewer, Biobase, RandVar(>= 0.9.2), distr(>= 2.5.2) \cr Suggests: \tab MASS\cr ByteCompile: \tab yes \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1057 \cr +VCS/SVNRevision: \tab 1081 \cr } } \author{Matthias Kohl \email{matthias.kohl at stamats.de}} Modified: pkg/RobLoxBioC/DESCRIPTION =================================================================== --- pkg/RobLoxBioC/DESCRIPTION 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/RobLoxBioC/DESCRIPTION 2018-08-01 03:06:49 UTC (rev 1083) @@ -1,18 +1,19 @@ Package: RobLoxBioC Version: 1.1.0 -Date: 2018-07-25 +Date: 2018-08-01 Title: Infinitesimally Robust Estimators for Preprocessing -Omics Data -Description: Functions for the determination of optimally robust influence curves and estimators for - preprocessing omics data, in particular gene expression data. +Description: Functions for the determination of optimally robust influence curves and + estimators for preprocessing omics data, in particular gene expression data. Depends: R(>= 2.14.0), methods, distr(>= 2.5.2), affy -Imports: Biobase, BiocGenerics, beadarray, RobLox(>= 0.9.2), distrMod(>= 2.5.2), lattice, RColorBrewer, - AnnotationDbi +Imports: Biobase, BiocGenerics, beadarray, RobLox(>= 0.9.2), distrMod(>= 2.5.2), lattice, + RColorBrewer, AnnotationDbi Suggests: affydata, hgu95av2cdf, beadarrayExampleData, illuminaHumanv3.db -Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), email="Matthias.Kohl at stamats.de") +Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), + email="Matthias.Kohl at stamats.de") ByteCompile: yes License: LGPL-3 URL: http://robast.r-forge.r-project.org/ Encoding: latin1 LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1057 +VCS/SVNRevision: 1081 Modified: pkg/RobLoxBioC/man/0RobLoxBioC-package.Rd =================================================================== --- pkg/RobLoxBioC/man/0RobLoxBioC-package.Rd 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/RobLoxBioC/man/0RobLoxBioC-package.Rd 2018-08-01 03:06:49 UTC (rev 1083) @@ -13,14 +13,14 @@ \tabular{ll}{ Package: \tab RobLoxBioC \cr Version: \tab 1.1.0 \cr -Date: \tab 2018-07-25 \cr +Date: \tab 2018-08-01 \cr Depends:\tab R(>= 2.14.0), methods, distr(>= 2.5.2), affy \cr Imports:\tab Biobase, BiocGenerics, beadarray, RobLox(>= 0.9.2), distrMod(>= 2.5.2), lattice, RColorBrewer \cr Suggests:\tab affydata, hgu95av2cdf, beadarrayExampleData, illuminaHumanv3.db \cr ByteCompile: \tab yes \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1057 \cr +VCS/SVNRevision: \tab 1081 \cr Encoding: \tab latin1 \cr } } Modified: pkg/RobRex/DESCRIPTION =================================================================== --- pkg/RobRex/DESCRIPTION 2018-08-01 03:02:30 UTC (rev 1082) +++ pkg/RobRex/DESCRIPTION 2018-08-01 03:06:49 UTC (rev 1083) @@ -1,16 +1,18 @@ Package: RobRex Version: 1.1.0 -Date: 2018-07-25 +Date: 2018-08-01 Title: Optimally Robust Influence Curves for Regression and Scale -Description: Functions for the determination of optimally robust influence curves in case of linear - regression with unknown scale and standard normal distributed errors where the regressor is random. +Description: Functions for the determination of optimally robust influence curves in case of + linear regression with unknown scale and standard normal distributed errors where the + regressor is random. Depends: R (>= 2.14.0), ROptRegTS(>= 0.9.2) Imports: distr(>= 2.5.2), RandVar(>= 0.9.2), RobAStBase(>= 0.9), methods -Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), email="Matthias.Kohl at stamats.de") +Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), + email="Matthias.Kohl at stamats.de") ByteCompile: yes License: LGPL-3 Encoding: latin1 URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1057 +VCS/SVNRevision: 1081 From noreply at r-forge.r-project.org Wed Aug 1 21:23:00 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 1 Aug 2018 21:23:00 +0200 (CEST) Subject: [Robast-commits] r1084 - pkg/RobAStBase Message-ID: <20180801192300.3FD511870D0@r-forge.r-project.org> Author: stamats Date: 2018-08-01 21:22:59 +0200 (Wed, 01 Aug 2018) New Revision: 1084 Modified: pkg/RobAStBase/DESCRIPTION Log: check complained about a missing white space Modified: pkg/RobAStBase/DESCRIPTION =================================================================== --- pkg/RobAStBase/DESCRIPTION 2018-08-01 03:06:49 UTC (rev 1083) +++ pkg/RobAStBase/DESCRIPTION 2018-08-01 19:22:59 UTC (rev 1084) @@ -5,7 +5,7 @@ Description: Base S4-classes and functions for robust asymptotic statistics. Depends: R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), RandVar(>= 0.9.2) -Suggests: ROptEst(>=1.1.0), RUnit(>= 0.4.26) +Suggests: ROptEst(>= 1.1.0), RUnit(>= 0.4.26) Imports: startupmsg, graphics, grDevices, stats Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel",role=c("aut", "cph")), From noreply at r-forge.r-project.org Thu Aug 2 00:29:36 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 2 Aug 2018 00:29:36 +0200 (CEST) Subject: [Robast-commits] r1085 - pkg/RobAStBase/R Message-ID: <20180801222936.A46D718A27C@r-forge.r-project.org> Author: stamats Date: 2018-08-02 00:29:36 +0200 (Thu, 02 Aug 2018) New Revision: 1085 Modified: pkg/RobAStBase/R/AllPlot.R pkg/RobAStBase/R/comparePlot.R Log: minor changes: condition length > 1 Modified: pkg/RobAStBase/R/AllPlot.R =================================================================== --- pkg/RobAStBase/R/AllPlot.R 2018-08-01 19:22:59 UTC (rev 1084) +++ pkg/RobAStBase/R/AllPlot.R 2018-08-01 22:29:36 UTC (rev 1085) @@ -243,11 +243,11 @@ y.vec1 <- resc$Y finiteEndpoints <- rep(FALSE,4) - if(scaleX){ + if(scaleX[i]){ finiteEndpoints[1] <- is.finite(scaleX.inv[[i]](min(x.vec1, xlim[1,i]))) finiteEndpoints[2] <- is.finite(scaleX.inv[[i]](max(x.vec1, xlim[2,i]))) } - if(scaleY){ + if(scaleY[i]){ finiteEndpoints[3] <- is.finite(scaleY.inv[[i]](min(y.vec1, ylim[1,i]))) finiteEndpoints[4] <- is.finite(scaleY.inv[[i]](max(y.vec1, ylim[2,i]))) } Modified: pkg/RobAStBase/R/comparePlot.R =================================================================== --- pkg/RobAStBase/R/comparePlot.R 2018-08-01 19:22:59 UTC (rev 1084) +++ pkg/RobAStBase/R/comparePlot.R 2018-08-01 22:29:36 UTC (rev 1085) @@ -592,11 +592,11 @@ y0[1:2] <- c(ym,yM) finiteEndpoints <- rep(FALSE,4) - if(scaleX){ + if(scaleX[i]){ finiteEndpoints[1] <- is.finite(scaleX.inv[[i]](min(x.vec[[i]], xlim[1,i],na.rm=TRUE))) finiteEndpoints[2] <- is.finite(scaleX.inv[[i]](max(x.vec[[i]], xlim[2,i],na.rm=TRUE))) } - if(scaleY){ + if(scaleY[i]){ finiteEndpoints[3] <- is.finite(scaleY.inv[[i]](min(ym, ylim[1,i],na.rm=TRUE))) finiteEndpoints[4] <- is.finite(scaleY.inv[[i]](max(yM, ylim[2,i],na.rm=TRUE))) } From noreply at r-forge.r-project.org Thu Aug 2 00:42:10 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 2 Aug 2018 00:42:10 +0200 (CEST) Subject: [Robast-commits] r1086 - pkg/RobAStBase/R Message-ID: <20180801224210.A6E621870D0@r-forge.r-project.org> Author: stamats Date: 2018-08-02 00:42:10 +0200 (Thu, 02 Aug 2018) New Revision: 1086 Modified: pkg/RobAStBase/R/AllPlot.R pkg/RobAStBase/R/comparePlot.R Log: two more minor changes: condition length > 1 Modified: pkg/RobAStBase/R/AllPlot.R =================================================================== --- pkg/RobAStBase/R/AllPlot.R 2018-08-01 22:29:36 UTC (rev 1085) +++ pkg/RobAStBase/R/AllPlot.R 2018-08-01 22:42:10 UTC (rev 1086) @@ -284,7 +284,7 @@ x.ticks = x.ticks[[i]], y.ticks = y.ticks[[i]]) if(withMBR){ MBR.i <- MBRB[i,] - if(scaleY) MBR.i <- scaleY.fct[[i]](MBR.i) + if(scaleY[i]) MBR.i <- scaleY.fct[[i]](MBR.i) abline(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR) plotInfo$MBR[[i]] <- list(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR) } Modified: pkg/RobAStBase/R/comparePlot.R =================================================================== --- pkg/RobAStBase/R/comparePlot.R 2018-08-01 22:29:36 UTC (rev 1085) +++ pkg/RobAStBase/R/comparePlot.R 2018-08-01 22:42:10 UTC (rev 1086) @@ -639,7 +639,7 @@ x.ticks = x.ticks0, y.ticks = y.ticks0) if(withMBR){ MBR.i <- MBRB[i,] - if(scaleY) MBR.i <- scaleY.fct[[i]](MBR.i) + if(scaleY[i]) MBR.i <- scaleY.fct[[i]](MBR.i) abline(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR) plotInfo$MBR[[i]] <- list(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR) } From noreply at r-forge.r-project.org Thu Aug 2 12:28:38 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 2 Aug 2018 12:28:38 +0200 (CEST) Subject: [Robast-commits] r1087 - in branches: robast-1.1/pkg/RobAStBase robast-1.1/pkg/RobAStBase/R robast-1.2/pkg/RobAStBase/R Message-ID: <20180802102838.8C426189E37@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-02 12:28:38 +0200 (Thu, 02 Aug 2018) New Revision: 1087 Modified: branches/robast-1.1/pkg/RobAStBase/DESCRIPTION branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R branches/robast-1.2/pkg/RobAStBase/R/AllPlot.R branches/robast-1.2/pkg/RobAStBase/R/comparePlot.R Log: [RobAStBase] branches 1.1 and 1.2 merged changed from trunk Modified: branches/robast-1.1/pkg/RobAStBase/DESCRIPTION =================================================================== --- branches/robast-1.1/pkg/RobAStBase/DESCRIPTION 2018-08-01 22:42:10 UTC (rev 1086) +++ branches/robast-1.1/pkg/RobAStBase/DESCRIPTION 2018-08-02 10:28:38 UTC (rev 1087) @@ -5,7 +5,7 @@ Description: Base S4-classes and functions for robust asymptotic statistics. Depends: R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), RandVar(>= 0.9.2) -Suggests: ROptEst(>=1.1.0), RUnit(>= 0.4.26) +Suggests: ROptEst(>= 1.1.0), RUnit(>= 0.4.26) Imports: startupmsg, graphics, grDevices, stats Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel",role=c("aut", "cph")), Modified: branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R =================================================================== --- branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R 2018-08-01 22:42:10 UTC (rev 1086) +++ branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R 2018-08-02 10:28:38 UTC (rev 1087) @@ -243,11 +243,11 @@ y.vec1 <- resc$Y finiteEndpoints <- rep(FALSE,4) - if(scaleX){ + if(scaleX[i]){ finiteEndpoints[1] <- is.finite(scaleX.inv[[i]](min(x.vec1, xlim[1,i]))) finiteEndpoints[2] <- is.finite(scaleX.inv[[i]](max(x.vec1, xlim[2,i]))) } - if(scaleY){ + if(scaleY[i]){ finiteEndpoints[3] <- is.finite(scaleY.inv[[i]](min(y.vec1, ylim[1,i]))) finiteEndpoints[4] <- is.finite(scaleY.inv[[i]](max(y.vec1, ylim[2,i]))) } @@ -284,7 +284,7 @@ x.ticks = x.ticks[[i]], y.ticks = y.ticks[[i]]) if(withMBR){ MBR.i <- MBRB[i,] - if(scaleY) MBR.i <- scaleY.fct[[i]](MBR.i) + if(scaleY[i]) MBR.i <- scaleY.fct[[i]](MBR.i) abline(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR) plotInfo$MBR[[i]] <- list(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR) } Modified: branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R =================================================================== --- branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R 2018-08-01 22:42:10 UTC (rev 1086) +++ branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R 2018-08-02 10:28:38 UTC (rev 1087) @@ -592,11 +592,11 @@ y0[1:2] <- c(ym,yM) finiteEndpoints <- rep(FALSE,4) - if(scaleX){ + if(scaleX[i]){ finiteEndpoints[1] <- is.finite(scaleX.inv[[i]](min(x.vec[[i]], xlim[1,i],na.rm=TRUE))) finiteEndpoints[2] <- is.finite(scaleX.inv[[i]](max(x.vec[[i]], xlim[2,i],na.rm=TRUE))) } - if(scaleY){ + if(scaleY[i]){ finiteEndpoints[3] <- is.finite(scaleY.inv[[i]](min(ym, ylim[1,i],na.rm=TRUE))) finiteEndpoints[4] <- is.finite(scaleY.inv[[i]](max(yM, ylim[2,i],na.rm=TRUE))) } @@ -639,7 +639,7 @@ x.ticks = x.ticks0, y.ticks = y.ticks0) if(withMBR){ MBR.i <- MBRB[i,] - if(scaleY) MBR.i <- scaleY.fct[[i]](MBR.i) + if(scaleY[i]) MBR.i <- scaleY.fct[[i]](MBR.i) abline(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR) plotInfo$MBR[[i]] <- list(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR) } Modified: branches/robast-1.2/pkg/RobAStBase/R/AllPlot.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/AllPlot.R 2018-08-01 22:42:10 UTC (rev 1086) +++ branches/robast-1.2/pkg/RobAStBase/R/AllPlot.R 2018-08-02 10:28:38 UTC (rev 1087) @@ -243,11 +243,11 @@ y.vec1 <- resc$Y finiteEndpoints <- rep(FALSE,4) - if(scaleX){ + if(scaleX[i]){ finiteEndpoints[1] <- is.finite(scaleX.inv[[i]](min(x.vec1, xlim[1,i]))) finiteEndpoints[2] <- is.finite(scaleX.inv[[i]](max(x.vec1, xlim[2,i]))) } - if(scaleY){ + if(scaleY[i]){ finiteEndpoints[3] <- is.finite(scaleY.inv[[i]](min(y.vec1, ylim[1,i]))) finiteEndpoints[4] <- is.finite(scaleY.inv[[i]](max(y.vec1, ylim[2,i]))) } @@ -284,7 +284,7 @@ x.ticks = x.ticks[[i]], y.ticks = y.ticks[[i]]) if(withMBR){ MBR.i <- MBRB[i,] - if(scaleY) MBR.i <- scaleY.fct[[i]](MBR.i) + if(scaleY[i]) MBR.i <- scaleY.fct[[i]](MBR.i) abline(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR) plotInfo$MBR[[i]] <- list(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR) } Modified: branches/robast-1.2/pkg/RobAStBase/R/comparePlot.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/comparePlot.R 2018-08-01 22:42:10 UTC (rev 1086) +++ branches/robast-1.2/pkg/RobAStBase/R/comparePlot.R 2018-08-02 10:28:38 UTC (rev 1087) @@ -592,11 +592,11 @@ y0[1:2] <- c(ym,yM) finiteEndpoints <- rep(FALSE,4) - if(scaleX){ + if(scaleX[i]){ finiteEndpoints[1] <- is.finite(scaleX.inv[[i]](min(x.vec[[i]], xlim[1,i],na.rm=TRUE))) finiteEndpoints[2] <- is.finite(scaleX.inv[[i]](max(x.vec[[i]], xlim[2,i],na.rm=TRUE))) } - if(scaleY){ + if(scaleY[i]){ finiteEndpoints[3] <- is.finite(scaleY.inv[[i]](min(ym, ylim[1,i],na.rm=TRUE))) finiteEndpoints[4] <- is.finite(scaleY.inv[[i]](max(yM, ylim[2,i],na.rm=TRUE))) } @@ -639,7 +639,7 @@ x.ticks = x.ticks0, y.ticks = y.ticks0) if(withMBR){ MBR.i <- MBRB[i,] - if(scaleY) MBR.i <- scaleY.fct[[i]](MBR.i) + if(scaleY[i]) MBR.i <- scaleY.fct[[i]](MBR.i) abline(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR) plotInfo$MBR[[i]] <- list(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR) } From noreply at r-forge.r-project.org Fri Aug 3 00:43:02 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 3 Aug 2018 00:43:02 +0200 (CEST) Subject: [Robast-commits] r1088 - pkg/RobAStBase/man Message-ID: <20180802224302.A4C69187410@r-forge.r-project.org> Author: stamats Date: 2018-08-03 00:43:01 +0200 (Fri, 03 Aug 2018) New Revision: 1088 Modified: pkg/RobAStBase/man/kStepEstimator.Rd pkg/RobAStBase/man/qqplot.Rd Log: In view of the check results on CRAN move more example code to \donttest Modified: pkg/RobAStBase/man/kStepEstimator.Rd =================================================================== --- pkg/RobAStBase/man/kStepEstimator.Rd 2018-08-02 10:28:38 UTC (rev 1087) +++ pkg/RobAStBase/man/kStepEstimator.Rd 2018-08-02 22:43:01 UTC (rev 1088) @@ -87,6 +87,8 @@ %\note{} \seealso{\code{\link{IC-class}}, \code{\link{kStepEstimate-class}} } \examples{ +## don't run to reduce check time on CRAN +\donttest{ if(require(ROptEst)){ ## 1. generate a contaminated sample ind <- rbinom(100, size=1, prob=0.05) @@ -105,8 +107,6 @@ pICList(est1) start(est1) -## don't run to reduce check time on CRAN -\donttest{ ## a transformed model tfct <- function(x){ nms0 <- c("mean","sd") Modified: pkg/RobAStBase/man/qqplot.Rd =================================================================== --- pkg/RobAStBase/man/qqplot.Rd 2018-08-02 10:28:38 UTC (rev 1087) +++ pkg/RobAStBase/man/qqplot.Rd 2018-08-02 22:43:01 UTC (rev 1088) @@ -125,11 +125,12 @@ } \examples{ +## \donttest to reduce check time +\donttest{ qqplot(rnorm(40, mean = 15, sd = sqrt(30)), Chisq(df=15)) RobM <- InfRobModel(center = NormLocationFamily(mean=13,sd=sqrt(28)), neighbor = ContNeighborhood(radius = 0.4)) -\donttest{ -## \donttest to reduce check time + x <- rnorm(20, mean = 15, sd = sqrt(30)) qqplot(x, RobM) qqplot(x, RobM, alpha.CI=0.9, add.points.CI=FALSE) From noreply at r-forge.r-project.org Fri Aug 3 08:37:28 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 3 Aug 2018 08:37:28 +0200 (CEST) Subject: [Robast-commits] r1089 - pkg/ROptEst/man Message-ID: <20180803063728.EDC5B180311@r-forge.r-project.org> Author: stamats Date: 2018-08-03 08:37:28 +0200 (Fri, 03 Aug 2018) New Revision: 1089 Modified: pkg/ROptEst/man/0ROptEst-package.Rd Log: In view of the check results on CRAN moved some example code to \donttest Modified: pkg/ROptEst/man/0ROptEst-package.Rd =================================================================== --- pkg/ROptEst/man/0ROptEst-package.Rd 2018-08-02 22:43:01 UTC (rev 1088) +++ pkg/ROptEst/man/0ROptEst-package.Rd 2018-08-03 06:37:28 UTC (rev 1089) @@ -51,6 +51,8 @@ information. } \examples{ +## don't run to reduce check time on CRAN +\donttest{ library(ROptEst) ## Example: Rutherford-Geiger (1910); cf. Feller~(1968), Section VI.7 (a) @@ -77,4 +79,5 @@ ## confidence interval based on LAN - including bias confint(robEst, method = symmetricBias()) } +} \keyword{package} From noreply at r-forge.r-project.org Fri Aug 3 08:39:21 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 3 Aug 2018 08:39:21 +0200 (CEST) Subject: [Robast-commits] r1090 - pkg/ROptEst/man Message-ID: <20180803063921.2E9D0180311@r-forge.r-project.org> Author: stamats Date: 2018-08-03 08:39:20 +0200 (Fri, 03 Aug 2018) New Revision: 1090 Modified: pkg/ROptEst/man/0ROptEst-package.Rd Log: just changed wording Modified: pkg/ROptEst/man/0ROptEst-package.Rd =================================================================== --- pkg/ROptEst/man/0ROptEst-package.Rd 2018-08-03 06:37:28 UTC (rev 1089) +++ pkg/ROptEst/man/0ROptEst-package.Rd 2018-08-03 06:39:20 UTC (rev 1090) @@ -51,7 +51,7 @@ information. } \examples{ -## don't run to reduce check time on CRAN +## don't test to reduce check time on CRAN \donttest{ library(ROptEst) From noreply at r-forge.r-project.org Fri Aug 3 10:24:30 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 3 Aug 2018 10:24:30 +0200 (CEST) Subject: [Robast-commits] r1091 - branches/robast-1.1/pkg/RobExtremes branches/robast-1.2/pkg/RobExtremes pkg/RobExtremes Message-ID: <20180803082430.61360189AE4@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-03 10:24:29 +0200 (Fri, 03 Aug 2018) New Revision: 1091 Modified: branches/robast-1.1/pkg/RobExtremes/DESCRIPTION branches/robast-1.2/pkg/RobExtremes/DESCRIPTION pkg/RobExtremes/DESCRIPTION Log: [RobExtremes] trunk & branch 1.1 & branch 1.2 DESCRIPTION: changed Depends version requirements Modified: branches/robast-1.1/pkg/RobExtremes/DESCRIPTION =================================================================== --- branches/robast-1.1/pkg/RobExtremes/DESCRIPTION 2018-08-03 06:39:20 UTC (rev 1090) +++ branches/robast-1.1/pkg/RobExtremes/DESCRIPTION 2018-08-03 08:24:29 UTC (rev 1091) @@ -4,7 +4,7 @@ Title: Optimally Robust Estimation for Extreme Value Distributions Description: Optimally robust estimation for extreme value distributions using S4 classes and methods (based on packages 'distr', 'distrEx', 'distrMod', 'RobAStBase', and 'ROptEst'). -Depends: R (>= 2.14.0), methods, distrMod(>= 2.5.2), ROptEst(>= 1.0), robustbase, evd +Depends: R (>= 2.14.0), methods, distrMod(>= 2.7.0), ROptEst(>= 1.1.0), robustbase, evd Suggests: RUnit (>= 0.4.26), ismev (>= 1.39) Imports: RobAStRDA, distr, distrEx, RandVar, RobAStBase, startupmsg, actuar Authors at R: c(person("Nataliya", "Horbenko", role=c("aut","cph")), person("Bernhard", "Spangl", Modified: branches/robast-1.2/pkg/RobExtremes/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobExtremes/DESCRIPTION 2018-08-03 06:39:20 UTC (rev 1090) +++ branches/robast-1.2/pkg/RobExtremes/DESCRIPTION 2018-08-03 08:24:29 UTC (rev 1091) @@ -4,7 +4,7 @@ Title: Optimally Robust Estimation for Extreme Value Distributions Description: Optimally robust estimation for extreme value distributions using S4 classes and methods (based on packages 'distr', 'distrEx', 'distrMod', 'RobAStBase', and 'ROptEst'). -Depends: R (>= 2.14.0), methods, distrMod(>= 2.5.2), ROptEst(>= 1.0), robustbase, evd +Depends: R (>= 2.14.0), methods, distrMod(>= 2.7.0), ROptEst(>= 1.1.0), robustbase, evd Suggests: RUnit (>= 0.4.26), ismev (>= 1.39) Imports: RobAStRDA, distr, distrEx, RandVar, RobAStBase, startupmsg, actuar Authors at R: c(person("Nataliya", "Horbenko", role=c("aut","cph")), person("Bernhard", "Spangl", role="ctb", comment="contributed smoothed grid Modified: pkg/RobExtremes/DESCRIPTION =================================================================== --- pkg/RobExtremes/DESCRIPTION 2018-08-03 06:39:20 UTC (rev 1090) +++ pkg/RobExtremes/DESCRIPTION 2018-08-03 08:24:29 UTC (rev 1091) @@ -5,7 +5,7 @@ Description: Optimally robust estimation for extreme value distributions using S4 classes and methods (based on packages 'distr', 'distrEx', 'distrMod', 'RobAStBase', and 'ROptEst'). -Depends: R (>= 2.14.0), methods, distrMod(>= 2.5.2), ROptEst(>= 1.0), robustbase, evd +Depends: R (>= 2.14.0), methods, distrMod(>= 2.7.0), ROptEst(>= 1.1.0), robustbase, evd Suggests: RUnit (>= 0.4.26), ismev (>= 1.39) Imports: RobAStRDA, distr, distrEx, RandVar, RobAStBase, startupmsg, actuar Authors at R: c(person("Nataliya", "Horbenko", role=c("aut","cph")), person("Bernhard", "Spangl", From noreply at r-forge.r-project.org Fri Aug 3 11:00:05 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 3 Aug 2018 11:00:05 +0200 (CEST) Subject: [Robast-commits] r1092 - in pkg/RobExtremes: . man Message-ID: <20180803090005.6E7BB188215@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-03 11:00:05 +0200 (Fri, 03 Aug 2018) New Revision: 1092 Modified: pkg/RobExtremes/DESCRIPTION pkg/RobExtremes/man/0RobExtremes-package.Rd Log: [RobExtremes] trunk updated Date and SVN info Modified: pkg/RobExtremes/DESCRIPTION =================================================================== --- pkg/RobExtremes/DESCRIPTION 2018-08-03 08:24:29 UTC (rev 1091) +++ pkg/RobExtremes/DESCRIPTION 2018-08-03 09:00:05 UTC (rev 1092) @@ -1,6 +1,6 @@ Package: RobExtremes Version: 1.1.0 -Date: 2018-08-01 +Date: 2018-08-03 Title: Optimally Robust Estimation for Extreme Value Distributions Description: Optimally robust estimation for extreme value distributions using S4 classes and methods (based on packages 'distr', 'distrEx', 'distrMod', 'RobAStBase', and @@ -26,4 +26,4 @@ URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1081 +VCS/SVNRevision: 1091 Modified: pkg/RobExtremes/man/0RobExtremes-package.Rd =================================================================== --- pkg/RobExtremes/man/0RobExtremes-package.Rd 2018-08-03 08:24:29 UTC (rev 1091) +++ pkg/RobExtremes/man/0RobExtremes-package.Rd 2018-08-03 09:00:05 UTC (rev 1092) @@ -103,7 +103,7 @@ \tabular{ll}{ Package: \tab RobExtremes \cr Version: \tab 1.1.0 \cr -Date: \tab 2018-07-19 \cr +Date: \tab 2018-08-03 \cr Title: \tab Optimally Robust Estimation for Extreme Value Distributions\cr Description: \tab Optimally robust estimation for extreme value distributions using S4 classes and methods \cr @@ -130,7 +130,7 @@ License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr Encoding: \tab latin1 \cr -VCS/SVNRevision: \tab 940 \cr +VCS/SVNRevision: \tab 1091 \cr } } From noreply at r-forge.r-project.org Fri Aug 3 11:18:28 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 3 Aug 2018 11:18:28 +0200 (CEST) Subject: [Robast-commits] r1093 - in branches/robast-1.2/pkg: ROptEst/man RobAStBase/man Message-ID: <20180803091828.1229918A25E@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-03 11:18:27 +0200 (Fri, 03 Aug 2018) New Revision: 1093 Modified: branches/robast-1.2/pkg/ROptEst/man/0ROptEst-package.Rd branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd branches/robast-1.2/pkg/RobAStBase/man/qqplot.Rd Log: branch 1.2: merged back Matthias changes from trunk Modified: branches/robast-1.2/pkg/ROptEst/man/0ROptEst-package.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/0ROptEst-package.Rd 2018-08-03 09:00:05 UTC (rev 1092) +++ branches/robast-1.2/pkg/ROptEst/man/0ROptEst-package.Rd 2018-08-03 09:18:27 UTC (rev 1093) @@ -12,9 +12,9 @@ \details{ \tabular{ll}{ Package: \tab ROptEst \cr -Version: \tab 1.2.0 \cr -Date: \tab 2018-07-25 \cr -Depends: \tab R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), +Version: \tab 1.1.0 \cr +Date: \tab 2018-08-01 \cr +Depends: \tab R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), RandVar(>= 0.9.2), RobAStBase(>= 1.0) \cr Suggests: \tab RobLox\cr Imports: \tab startupmsg, MASS, stats, graphics, utils, grDevices \cr @@ -22,7 +22,7 @@ Encoding: \tab latin1 \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1058 \cr +VCS/SVNRevision: \tab 1081 \cr } } \author{ @@ -51,6 +51,8 @@ information. } \examples{ +## don't test to reduce check time on CRAN +\donttest{ library(ROptEst) ## Example: Rutherford-Geiger (1910); cf. Feller~(1968), Section VI.7 (a) @@ -77,4 +79,5 @@ ## confidence interval based on LAN - including bias confint(robEst, method = symmetricBias()) } +} \keyword{package} Modified: branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd 2018-08-03 09:00:05 UTC (rev 1092) +++ branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd 2018-08-03 09:18:27 UTC (rev 1093) @@ -87,6 +87,8 @@ %\note{} \seealso{\code{\link{IC-class}}, \code{\link{kStepEstimate-class}} } \examples{ +## don't run to reduce check time on CRAN +\donttest{ if(require(ROptEst)){ ## 1. generate a contaminated sample ind <- rbinom(100, size=1, prob=0.05) @@ -105,8 +107,6 @@ pICList(est1) start(est1) -## don't run to reduce check time on CRAN -\donttest{ ## a transformed model tfct <- function(x){ nms0 <- c("mean","sd") Modified: branches/robast-1.2/pkg/RobAStBase/man/qqplot.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/qqplot.Rd 2018-08-03 09:00:05 UTC (rev 1092) +++ branches/robast-1.2/pkg/RobAStBase/man/qqplot.Rd 2018-08-03 09:18:27 UTC (rev 1093) @@ -125,11 +125,12 @@ } \examples{ +## \donttest to reduce check time +\donttest{ qqplot(rnorm(40, mean = 15, sd = sqrt(30)), Chisq(df=15)) RobM <- InfRobModel(center = NormLocationFamily(mean=13,sd=sqrt(28)), neighbor = ContNeighborhood(radius = 0.4)) -\donttest{ -## \donttest to reduce check time + x <- rnorm(20, mean = 15, sd = sqrt(30)) qqplot(x, RobM) qqplot(x, RobM, alpha.CI=0.9, add.points.CI=FALSE) From noreply at r-forge.r-project.org Fri Aug 3 11:20:11 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 3 Aug 2018 11:20:11 +0200 (CEST) Subject: [Robast-commits] r1094 - branches/robast-1.2/pkg/ROptEst/R Message-ID: <20180803092011.7998318A25F@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-03 11:20:11 +0200 (Fri, 03 Aug 2018) New Revision: 1094 Modified: branches/robast-1.2/pkg/ROptEst/R/comparePlot.R Log: [ROptEst] branch 1.2 some minor safety enhancement in comparePlot Modified: branches/robast-1.2/pkg/ROptEst/R/comparePlot.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/comparePlot.R 2018-08-03 09:18:27 UTC (rev 1093) +++ branches/robast-1.2/pkg/ROptEst/R/comparePlot.R 2018-08-03 09:20:11 UTC (rev 1094) @@ -73,9 +73,12 @@ MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T) if(withMBR && all(is.na(MBRB))){ - robModel <- InfRobModel(center = L2Fam, neighbor = + ICmbr <- try(getStartIC(model = L2Fam, risk = MBRRisk()), silent=TRUE) + if(is(ICmbr),"try-error"){ + robModel <- InfRobModel(center = L2Fam, neighbor = ContNeighborhood(radius = 0.5)) - ICmbr <- try(optIC(model = robModel, risk = asBias()), silent=TRUE) + ICmbr <- try(optIC(model = robModel, risk = asBias()), silent=TRUE) + } if(!is(ICmbr,"try-error")) MBRB <- .getExtremeCoordIC(ICmbr, distribution(L2Fam), to.draw, n=n.MBR) From noreply at r-forge.r-project.org Fri Aug 3 17:17:13 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 3 Aug 2018 17:17:13 +0200 (CEST) Subject: [Robast-commits] r1095 - branches/robast-1.1 branches/robast-1.2/pkg/RobExtremes/man pkg/RobExtremes/man Message-ID: <20180803151713.1BE2A188B9D@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-03 17:17:12 +0200 (Fri, 03 Aug 2018) New Revision: 1095 Added: branches/robast-1.1/20180803MessageToCRANRobExtremes.txt Modified: branches/robast-1.2/pkg/RobExtremes/man/LDEstimator.Rd branches/robast-1.2/pkg/RobExtremes/man/Var.Rd branches/robast-1.2/pkg/RobExtremes/man/ismevgpdgevdiag-methods.Rd pkg/RobExtremes/man/LDEstimator.Rd pkg/RobExtremes/man/Var.Rd pkg/RobExtremes/man/ismevgpdgevdiag-methods.Rd Log: [RobExtremes] branch 1.1 and trunk: moved some examples in LDEestimator.Rd, Var.Rd, and ismevgpdgevdiag-methods.Rd into \donttest Added: branches/robast-1.1/20180803MessageToCRANRobExtremes.txt =================================================================== --- branches/robast-1.1/20180803MessageToCRANRobExtremes.txt (rev 0) +++ branches/robast-1.1/20180803MessageToCRANRobExtremes.txt 2018-08-03 15:17:12 UTC (rev 1095) @@ -0,0 +1,94 @@ +Hi, + +this is the third part of a somewhat larger release block... + +For internal dependencies it has to be done step by step in four steps. All packages are already ready for submission, so this could be done within the next few days. + +We have started with distrMod (2.7.0) and RobAStRDA (1.1.0). In our second step, Matthias Kohl, Matthias.Kohl at stamats.de, has submitted RandVar, RobAStBase, ROptEst in version 1.1.0 to CRAN. + +In this third step, it is back to me, and I will submit RobExtremes. + +The final fourth step then will be Matthias again to release RobLox, RobLoxBioC, RobRex, ROptEstOld, and ROptRegTS. + +For RobExtremes, we still see (minor) timing NOTEs as to examples in Windows and in Linux (see below). As these timings are close to the bound of 5s, we have left them as is for the time being, but could also move some more examples to \donttest if requested: + +Best regards, Peter Ruckdeschel (and Matthias Kohl) + +%---------------------------------------------------- +Windows: +%---------------------------------------------------- +** running examples for arch 'i386' ... NOTE +Examples with CPU or elapsed time > 5s + user system elapsed +ismevgpdgevdiag-methods 5.37 0.58 6.6 +** running examples for arch 'x64' ... NOTE +Examples with CPU or elapsed time > 5s + user system elapsed +ismevgpdgevdiag-methods 6.12 0.45 7.89 + +> sessionInfo() +R version 3.5.1 RC (2018-06-24 r74935) +Platform: x86_64-w64-mingw32/x64 (64-bit) +Running under: Windows 10 x64 (build 17134) + +Matrix products: default + +locale: +[1] LC_COLLATE=German_Germany.1252 LC_CTYPE=German_Germany.1252 +[3] LC_MONETARY=German_Germany.1252 LC_NUMERIC=C +[5] LC_TIME=German_Germany.1252 + +attached base packages: +[1] stats4 stats graphics grDevices utils datasets methods +[8] base + +other attached packages: + [1] RobExtremes_1.1.0 evd_2.3-3 ROptEst_1.1.0 RobAStBase_1.1.0 + [5] rrcov_1.4-4 robustbase_0.93-1 distrMod_2.8.0 MASS_7.3-50 + [9] RandVar_1.1.0 distrEx_2.8.0 distr_2.8.0 sfsmisc_1.1-2 +[13] startupmsg_0.9.6 + +loaded via a namespace (and not attached): + [1] RobAStRDA_1.1.0 lattice_0.20-35 mvtnorm_1.0-8 grid_3.5.1 + [5] pcaPP_1.9-73 expint_0.1-5 actuar_2.3-1 tools_3.5.1 + [9] DEoptimR_1.0-8 compiler_3.5.1 cluster_2.0.7-1 +%---------------------------------------------------- +Linux: +%---------------------------------------------------- +Examples with CPU or elapsed time > 5s + user system elapsed +ismevgpdgevdiag-methods 8.512 0.517 9.342 +LDEstimator 4.430 0.199 5.210 + +> sessionInfo() +R Under development (unstable) (2018-08-02 r75051) +Platform: x86_64-pc-linux-gnu (64-bit) +Running under: openSUSE Leap 42.3 + +Matrix products: default +BLAS: /usr/local/lib64/R/lib/libRblas.so +LAPACK: /usr/local/lib64/R/lib/libRlapack.so + +locale: + [1] LC_CTYPE=de_DE.UTF-8 LC_NUMERIC=C + [3] LC_TIME=de_DE.UTF-8 LC_COLLATE=de_DE.UTF-8 + [5] LC_MONETARY=de_DE.UTF-8 LC_MESSAGES=de_DE.UTF-8 + [7] LC_PAPER=de_DE.UTF-8 LC_NAME=C + [9] LC_ADDRESS=C LC_TELEPHONE=C +[11] LC_MEASUREMENT=de_DE.UTF-8 LC_IDENTIFICATION=C + +attached base packages: +[1] stats4 stats graphics grDevices utils datasets methods +[8] base + +other attached packages: + [1] RobExtremes_1.1.0 evd_2.3-3 ROptEst_1.1.0 RobAStBase_1.1.0 + [5] rrcov_1.4-4 robustbase_0.93-2 distrMod_2.7.0 MASS_7.3-50 + [9] RandVar_1.1.0 distrEx_2.7.0 distr_2.7.0 sfsmisc_1.1-2 +[13] startupmsg_0.9.5 + +loaded via a namespace (and not attached): + [1] RobAStRDA_1.1.0 lattice_0.20-35 mvtnorm_1.0-8 grid_3.6.0 + [5] pcaPP_1.9-73 expint_0.1-5 actuar_2.3-1 DEoptimR_1.0-8 + [9] compiler_3.6.0 cluster_2.0.7-1 + Modified: branches/robast-1.2/pkg/RobExtremes/man/LDEstimator.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/LDEstimator.Rd 2018-08-03 09:20:11 UTC (rev 1094) +++ branches/robast-1.2/pkg/RobExtremes/man/LDEstimator.Rd 2018-08-03 15:17:12 UTC (rev 1095) @@ -145,10 +145,10 @@ LDEstimator(x, loc.est = median, disp.est = Sn, loc.fctal = median, disp.fctal = getMethod("Sn","UnivariateDistribution"), ParamFamily = G, disp.est.ctrl = list(constant=1)) -} medkMAD(x = x, ParamFamily = G) medkMADhybr(x = x, ParamFamily = G) +} medkMAD(x = x, k=10, ParamFamily = G) ##not at all robust: Modified: branches/robast-1.2/pkg/RobExtremes/man/Var.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/Var.Rd 2018-08-03 09:20:11 UTC (rev 1094) +++ branches/robast-1.2/pkg/RobExtremes/man/Var.Rd 2018-08-03 15:17:12 UTC (rev 1095) @@ -227,9 +227,10 @@ ## note the timing system.time(print(Sn(GPareto(shape=0.5,scale=2)))) +\donttest{ system.time(print(Sn(as(GPareto(shape=0.5,scale=2),"AbscontDistribution")))) - } +} \seealso{\code{\link[distrEx]{Var}},\cr \code{\link[stats]{sd}}, \code{\link[stats:cor]{var}}, \code{\link[stats]{IQR}},\cr \code{\link[stats]{median}}, \code{\link[stats]{mad}}, \code{\link[distr:sd-methods]{sd}},\cr Modified: branches/robast-1.2/pkg/RobExtremes/man/ismevgpdgevdiag-methods.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/ismevgpdgevdiag-methods.Rd 2018-08-03 09:20:11 UTC (rev 1094) +++ branches/robast-1.2/pkg/RobExtremes/man/ismevgpdgevdiag-methods.Rd 2018-08-03 15:17:12 UTC (rev 1095) @@ -120,9 +120,11 @@ ppfit <- ismev::gev.fit(portpirie[,2]) gev.diag(ppfit) ## - mlE <- MLEstimator(portpirie[,2], GEVFamilyMuUnknown(withPos=FALSE)) + (mlE <- MLEstimator(portpirie[,2], GEVFamilyMuUnknown(withPos=FALSE))) gev.diag(mlE) +\donttest{ + ## not tested on CRAN because it takes some time... gev.prof(mlE, m = 10, 4.1, 5) gev.profxi(mlE, -0.3, 0.3) @@ -132,11 +134,11 @@ mlE2 <- MLEstimator(rain[rain>10], GParetoFamily(loc=10)) gpd.diag(mlE2) - ## not tested on CRAN because it takes some time... gpd.prof(mlE2, m = 10, 55, 77) gpd.profxi(mlE2, -0.02, 0.02) } } +} \keyword{graphics} Modified: pkg/RobExtremes/man/LDEstimator.Rd =================================================================== --- pkg/RobExtremes/man/LDEstimator.Rd 2018-08-03 09:20:11 UTC (rev 1094) +++ pkg/RobExtremes/man/LDEstimator.Rd 2018-08-03 15:17:12 UTC (rev 1095) @@ -145,10 +145,10 @@ LDEstimator(x, loc.est = median, disp.est = Sn, loc.fctal = median, disp.fctal = getMethod("Sn","UnivariateDistribution"), ParamFamily = G, disp.est.ctrl = list(constant=1)) -} medkMAD(x = x, ParamFamily = G) medkMADhybr(x = x, ParamFamily = G) +} medkMAD(x = x, k=10, ParamFamily = G) ##not at all robust: Modified: pkg/RobExtremes/man/Var.Rd =================================================================== --- pkg/RobExtremes/man/Var.Rd 2018-08-03 09:20:11 UTC (rev 1094) +++ pkg/RobExtremes/man/Var.Rd 2018-08-03 15:17:12 UTC (rev 1095) @@ -227,9 +227,10 @@ ## note the timing system.time(print(Sn(GPareto(shape=0.5,scale=2)))) +\donttest{ system.time(print(Sn(as(GPareto(shape=0.5,scale=2),"AbscontDistribution")))) - } +} \seealso{\code{\link[distrEx]{Var}},\cr \code{\link[stats]{sd}}, \code{\link[stats:cor]{var}}, \code{\link[stats]{IQR}},\cr \code{\link[stats]{median}}, \code{\link[stats]{mad}}, \code{\link[distr:sd-methods]{sd}},\cr Modified: pkg/RobExtremes/man/ismevgpdgevdiag-methods.Rd =================================================================== --- pkg/RobExtremes/man/ismevgpdgevdiag-methods.Rd 2018-08-03 09:20:11 UTC (rev 1094) +++ pkg/RobExtremes/man/ismevgpdgevdiag-methods.Rd 2018-08-03 15:17:12 UTC (rev 1095) @@ -120,9 +120,11 @@ ppfit <- ismev::gev.fit(portpirie[,2]) gev.diag(ppfit) ## - mlE <- MLEstimator(portpirie[,2], GEVFamilyMuUnknown(withPos=FALSE)) + (mlE <- MLEstimator(portpirie[,2], GEVFamilyMuUnknown(withPos=FALSE))) gev.diag(mlE) +\donttest{ + ## not tested on CRAN because it takes some time... gev.prof(mlE, m = 10, 4.1, 5) gev.profxi(mlE, -0.3, 0.3) @@ -132,11 +134,11 @@ mlE2 <- MLEstimator(rain[rain>10], GParetoFamily(loc=10)) gpd.diag(mlE2) - ## not tested on CRAN because it takes some time... gpd.prof(mlE2, m = 10, 55, 77) gpd.profxi(mlE2, -0.02, 0.02) } } +} \keyword{graphics} From noreply at r-forge.r-project.org Fri Aug 3 18:11:26 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 3 Aug 2018 18:11:26 +0200 (CEST) Subject: [Robast-commits] r1096 - branches/robast-1.1 Message-ID: <20180803161126.6C883188B9D@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-03 18:11:26 +0200 (Fri, 03 Aug 2018) New Revision: 1096 Modified: branches/robast-1.1/20180726ReleaseNote.txt branches/robast-1.1/20180803MessageToCRANRobExtremes.txt Log: minor changes to release notes 1.1 Modified: branches/robast-1.1/20180726ReleaseNote.txt =================================================================== --- branches/robast-1.1/20180726ReleaseNote.txt 2018-08-03 15:17:12 UTC (rev 1095) +++ branches/robast-1.1/20180726ReleaseNote.txt 2018-08-03 16:11:26 UTC (rev 1096) @@ -24,7 +24,8 @@ Updates for the packages of the RobASt family are now avaialable on CRAN in version >= 1.1.0 -Most importantly, we have (finally) released on CRAN a new package +Most importantly, we have (finally) released on CRAN a (long announced) new +package "RobExtremes" @@ -117,3 +118,7 @@ For details please see the NEWS files in the packages, available as NEWS(""). + +Best regards from the main developpers & maintainers, +Peter Ruckdeschel (peter.ruckdeschel at uni-oldenburg.de) & +Matthias Kohl (matthias.kohl at stamats.de) Modified: branches/robast-1.1/20180803MessageToCRANRobExtremes.txt =================================================================== --- branches/robast-1.1/20180803MessageToCRANRobExtremes.txt 2018-08-03 15:17:12 UTC (rev 1095) +++ branches/robast-1.1/20180803MessageToCRANRobExtremes.txt 2018-08-03 16:11:26 UTC (rev 1096) @@ -10,10 +10,10 @@ The final fourth step then will be Matthias again to release RobLox, RobLoxBioC, RobRex, ROptEstOld, and ROptRegTS. -For RobExtremes, we still see (minor) timing NOTEs as to examples in Windows and in Linux (see below). As these timings are close to the bound of 5s, we have left them as is for the time being, but could also move some more examples to \donttest if requested: - Best regards, Peter Ruckdeschel (and Matthias Kohl) +obsolete: + %---------------------------------------------------- Windows: %---------------------------------------------------- From noreply at r-forge.r-project.org Fri Aug 3 19:17:39 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 3 Aug 2018 19:17:39 +0200 (CEST) Subject: [Robast-commits] r1097 - branches/robast-1.2/pkg/ROptEstOld branches/robast-1.2/pkg/ROptRegTS branches/robast-1.2/pkg/RobLoxBioC branches/robast-1.2/pkg/RobRex pkg/ROptEstOld pkg/ROptRegTS pkg/RobLoxBioC pkg/RobRex Message-ID: <20180803171739.D9993187F8C@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-03 19:17:39 +0200 (Fri, 03 Aug 2018) New Revision: 1097 Modified: branches/robast-1.2/pkg/ROptEstOld/DESCRIPTION branches/robast-1.2/pkg/ROptRegTS/DESCRIPTION branches/robast-1.2/pkg/RobLoxBioC/DESCRIPTION branches/robast-1.2/pkg/RobRex/DESCRIPTION pkg/ROptEstOld/DESCRIPTION pkg/ROptRegTS/DESCRIPTION pkg/RobLoxBioC/DESCRIPTION pkg/RobRex/DESCRIPTION Log: in branch 1.2 and trunk: enforced more recent package versions in distr and robast family in RobLoxBioC, RobRex, ROptEstOld, ROptRegTS Modified: branches/robast-1.2/pkg/ROptEstOld/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/ROptEstOld/DESCRIPTION 2018-08-03 16:11:26 UTC (rev 1096) +++ branches/robast-1.2/pkg/ROptEstOld/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) @@ -3,7 +3,7 @@ Date: 2018-07-25 Title: Optimally Robust Estimation - Old Version Description: Optimally robust estimation using S4 classes and methods. Old version still needed for current versions of ROptRegTS and RobRex. -Depends: R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.2), RandVar(>= 0.9.2), evd +Depends: R(>= 2.14.0), methods, distr(>= 2.7.0), distrEx(>= 2.7.0), RandVar(>= 1.1.0), evd Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), email="Matthias.Kohl at stamats.de") ByteCompile: yes License: LGPL-3 Modified: branches/robast-1.2/pkg/ROptRegTS/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/DESCRIPTION 2018-08-03 16:11:26 UTC (rev 1096) +++ branches/robast-1.2/pkg/ROptRegTS/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) @@ -1,16 +1,18 @@ Package: ROptRegTS Version: 1.2.0 -Date: 2018-07-25 +Date: 2018-08-01 Title: Optimally Robust Estimation for Regression-Type Models -Description: Optimally robust estimation for regression-type models using S4 classes and methods. -Depends: R (>= 2.14.0), methods, ROptEstOld(>= 0.9.1) -Imports: distr(>= 2.5.2), distrEx(>= 2.5), RandVar(>= 0.9.2) -Authors at R: c(person("Matthias", "Kohl", role=c("cre", "aut", "cph"), email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", - role=c("aut", "cph"))) +Description: Optimally robust estimation for regression-type models using S4 classes and + methods. +Depends: R (>= 2.14.0), methods, ROptEstOld(>= 1.1.0) +Imports: distr(>= 2.7.0), distrEx(>= 2.7.0), RandVar(>= 1.1.0) +Authors at R: c(person("Matthias", "Kohl", role=c("cre", "aut", "cph"), + email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", role=c("aut", + "cph"))) ByteCompile: yes License: LGPL-3 Encoding: latin1 URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1058 +VCS/SVNRevision: 1081 Modified: branches/robast-1.2/pkg/RobLoxBioC/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobLoxBioC/DESCRIPTION 2018-08-03 16:11:26 UTC (rev 1096) +++ branches/robast-1.2/pkg/RobLoxBioC/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) @@ -4,8 +4,8 @@ Title: Infinitesimally Robust Estimators for Preprocessing -Omics Data Description: Functions for the determination of optimally robust influence curves and estimators for preprocessing omics data, in particular gene expression data. -Depends: R(>= 2.14.0), methods, distr(>= 2.5.2), affy -Imports: Biobase, BiocGenerics, beadarray, RobLox(>= 0.9.2), distrMod(>= 2.5.2), lattice, RColorBrewer, AnnotationDbi +Depends: R(>= 2.14.0), methods, distr(>= 2.7.0), affy +Imports: Biobase, BiocGenerics, beadarray, RobLox(>= 1.1.0), distrMod(>= 2.7.0), lattice, RColorBrewer, AnnotationDbi Suggests: affydata, hgu95av2cdf, beadarrayExampleData, illuminaHumanv3.db Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), email="Matthias.Kohl at stamats.de") ByteCompile: yes Modified: branches/robast-1.2/pkg/RobRex/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobRex/DESCRIPTION 2018-08-03 16:11:26 UTC (rev 1096) +++ branches/robast-1.2/pkg/RobRex/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) @@ -4,8 +4,8 @@ Title: Optimally Robust Influence Curves for Regression and Scale Description: Functions for the determination of optimally robust influence curves in case of linear regression with unknown scale and standard normal distributed errors where the regressor is random. -Depends: R (>= 2.14.0), ROptRegTS(>= 0.9.2) -Imports: distr(>= 2.5.2), RandVar(>= 0.9.2), RobAStBase(>= 0.9), methods +Depends: R (>= 2.14.0), ROptRegTS(>= 1.1.0) +Imports: distr(>= 2.7.0), RandVar(>= 1.1.0), RobAStBase(>= 1.1.0), methods Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), email="Matthias.Kohl at stamats.de") ByteCompile: yes License: LGPL-3 Modified: pkg/ROptEstOld/DESCRIPTION =================================================================== --- pkg/ROptEstOld/DESCRIPTION 2018-08-03 16:11:26 UTC (rev 1096) +++ pkg/ROptEstOld/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) @@ -4,7 +4,7 @@ Title: Optimally Robust Estimation - Old Version Description: Optimally robust estimation using S4 classes and methods. Old version still needed for current versions of ROptRegTS and RobRex. -Depends: R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.2), RandVar(>= 0.9.2), evd +Depends: R(>= 2.14.0), methods, distr(>= 2.7.0), distrEx(>= 2.7.0), RandVar(>= 1.1.0), evd Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), email="Matthias.Kohl at stamats.de") ByteCompile: yes Modified: pkg/ROptRegTS/DESCRIPTION =================================================================== --- pkg/ROptRegTS/DESCRIPTION 2018-08-03 16:11:26 UTC (rev 1096) +++ pkg/ROptRegTS/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) @@ -4,8 +4,8 @@ Title: Optimally Robust Estimation for Regression-Type Models Description: Optimally robust estimation for regression-type models using S4 classes and methods. -Depends: R (>= 2.14.0), methods, ROptEstOld(>= 0.9.1) -Imports: distr(>= 2.5.2), distrEx(>= 2.5), RandVar(>= 0.9.2) +Depends: R (>= 2.14.0), methods, ROptEstOld(>= 1.1.0) +Imports: distr(>= 2.7.0), distrEx(>= 2.7.0), RandVar(>= 1.1.0) Authors at R: c(person("Matthias", "Kohl", role=c("cre", "aut", "cph"), email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", role=c("aut", "cph"))) Modified: pkg/RobLoxBioC/DESCRIPTION =================================================================== --- pkg/RobLoxBioC/DESCRIPTION 2018-08-03 16:11:26 UTC (rev 1096) +++ pkg/RobLoxBioC/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) @@ -4,8 +4,8 @@ Title: Infinitesimally Robust Estimators for Preprocessing -Omics Data Description: Functions for the determination of optimally robust influence curves and estimators for preprocessing omics data, in particular gene expression data. -Depends: R(>= 2.14.0), methods, distr(>= 2.5.2), affy -Imports: Biobase, BiocGenerics, beadarray, RobLox(>= 0.9.2), distrMod(>= 2.5.2), lattice, +Depends: R(>= 2.14.0), methods, distr(>= 2.7.0), affy +Imports: Biobase, BiocGenerics, beadarray, RobLox(>= 1.1.0), distrMod(>= 2.7.0), lattice, RColorBrewer, AnnotationDbi Suggests: affydata, hgu95av2cdf, beadarrayExampleData, illuminaHumanv3.db Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), Modified: pkg/RobRex/DESCRIPTION =================================================================== --- pkg/RobRex/DESCRIPTION 2018-08-03 16:11:26 UTC (rev 1096) +++ pkg/RobRex/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) @@ -5,8 +5,8 @@ Description: Functions for the determination of optimally robust influence curves in case of linear regression with unknown scale and standard normal distributed errors where the regressor is random. -Depends: R (>= 2.14.0), ROptRegTS(>= 0.9.2) -Imports: distr(>= 2.5.2), RandVar(>= 0.9.2), RobAStBase(>= 0.9), methods +Depends: R (>= 2.14.0), ROptRegTS(>= 1.1.0) +Imports: distr(>= 2.7.0), RandVar(>= 1.1.0), RobAStBase(>= 1.1.0), methods Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), email="Matthias.Kohl at stamats.de") ByteCompile: yes From noreply at r-forge.r-project.org Fri Aug 3 19:19:23 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 3 Aug 2018 19:19:23 +0200 (CEST) Subject: [Robast-commits] r1098 - in branches/robast-1.2/pkg: ROptEst ROptEst/man ROptEstOld ROptRegTS RandVar RandVar/man RobAStBase RobAStBase/man RobAStRDA RobAStRDA/man RobExtremes RobExtremes/man RobLox RobLox/man RobLoxBioC RobLoxBioC/man RobRex Message-ID: <20180803171923.D3015187F8C@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-03 19:19:23 +0200 (Fri, 03 Aug 2018) New Revision: 1098 Modified: branches/robast-1.2/pkg/ROptEst/DESCRIPTION branches/robast-1.2/pkg/ROptEst/man/0ROptEst-package.Rd branches/robast-1.2/pkg/ROptEstOld/DESCRIPTION branches/robast-1.2/pkg/ROptRegTS/DESCRIPTION branches/robast-1.2/pkg/RandVar/DESCRIPTION branches/robast-1.2/pkg/RandVar/man/0RandVar-package.Rd branches/robast-1.2/pkg/RobAStBase/DESCRIPTION branches/robast-1.2/pkg/RobAStBase/man/0RobAStBase-package.Rd branches/robast-1.2/pkg/RobAStRDA/DESCRIPTION branches/robast-1.2/pkg/RobAStRDA/man/0RobRDA-package.Rd branches/robast-1.2/pkg/RobExtremes/DESCRIPTION branches/robast-1.2/pkg/RobExtremes/man/0RobExtremes-package.Rd branches/robast-1.2/pkg/RobLox/DESCRIPTION branches/robast-1.2/pkg/RobLox/man/0RobLox-package.Rd branches/robast-1.2/pkg/RobLoxBioC/DESCRIPTION branches/robast-1.2/pkg/RobLoxBioC/man/0RobLoxBioC-package.Rd branches/robast-1.2/pkg/RobRex/DESCRIPTION Log: in branch 1.2 updated date and SVN rev Modified: branches/robast-1.2/pkg/ROptEst/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/ROptEst/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/ROptEst/DESCRIPTION 2018-08-03 17:19:23 UTC (rev 1098) @@ -1,18 +1,22 @@ Package: ROptEst Version: 1.2.0 -Date: 2018-07-25 +Date: 2018-08-03 Title: Optimally Robust Estimation -Description: Optimally robust estimation in general smoothly parameterized models using S4 classes and methods. -Depends: R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), RandVar(>= 0.9.2), RobAStBase(>= 1.0) -Imports: startupmsg, MASS, stats, graphics, utils, grDevices +Description: Optimally robust estimation in general smoothly parameterized models using S4 + classes and methods. +Depends: R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), + RandVar(>= 0.9.2), RobAStBase(>= 1.0) +Imports: startupmsg, MASS, stats, graphics, utils, grDevices Suggests: RobLox -Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph"), email="Matthias.Kohl at stamats.de"), person("Mykhailo", "Pupashenko", role="ctb", - comment="contributed wrapper functions for diagnostic plots"), person("Gerald", "Kroisandt", role="ctb", comment="contributed - testing routines"), person("Peter", "Ruckdeschel", role=c("aut", "cph"))) +Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph"), + email="Matthias.Kohl at stamats.de"), person("Mykhailo", "Pupashenko", role="ctb", + comment="contributed wrapper functions for diagnostic plots"), person("Gerald", + "Kroisandt", role="ctb", comment="contributed testing routines"), person("Peter", + "Ruckdeschel", role=c("aut", "cph"))) ByteCompile: yes License: LGPL-3 URL: http://robast.r-forge.r-project.org/ Encoding: latin1 LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1058 +VCS/SVNRevision: 1097 Modified: branches/robast-1.2/pkg/ROptEst/man/0ROptEst-package.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/0ROptEst-package.Rd 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/ROptEst/man/0ROptEst-package.Rd 2018-08-03 17:19:23 UTC (rev 1098) @@ -12,8 +12,8 @@ \details{ \tabular{ll}{ Package: \tab ROptEst \cr -Version: \tab 1.1.0 \cr -Date: \tab 2018-08-01 \cr +Version: \tab 1.2.0 \cr +Date: \tab 2018-08-03 \cr Depends: \tab R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), RandVar(>= 0.9.2), RobAStBase(>= 1.0) \cr Suggests: \tab RobLox\cr @@ -22,7 +22,7 @@ Encoding: \tab latin1 \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1081 \cr +VCS/SVNRevision: \tab 1097 \cr } } \author{ Modified: branches/robast-1.2/pkg/ROptEstOld/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/ROptEstOld/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/ROptEstOld/DESCRIPTION 2018-08-03 17:19:23 UTC (rev 1098) @@ -1,14 +1,16 @@ Package: ROptEstOld Version: 1.2.0 -Date: 2018-07-25 +Date: 2018-08-03 Title: Optimally Robust Estimation - Old Version -Description: Optimally robust estimation using S4 classes and methods. Old version still needed for current versions of ROptRegTS and RobRex. +Description: Optimally robust estimation using S4 classes and methods. Old version still needed + for current versions of ROptRegTS and RobRex. Depends: R(>= 2.14.0), methods, distr(>= 2.7.0), distrEx(>= 2.7.0), RandVar(>= 1.1.0), evd -Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), email="Matthias.Kohl at stamats.de") +Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), + email="Matthias.Kohl at stamats.de") ByteCompile: yes License: LGPL-3 URL: http://robast.r-forge.r-project.org/ Encoding: latin1 LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1058 +VCS/SVNRevision: 1097 Modified: branches/robast-1.2/pkg/ROptRegTS/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/ROptRegTS/DESCRIPTION 2018-08-03 17:19:23 UTC (rev 1098) @@ -1,6 +1,6 @@ Package: ROptRegTS Version: 1.2.0 -Date: 2018-08-01 +Date: 2018-08-03 Title: Optimally Robust Estimation for Regression-Type Models Description: Optimally robust estimation for regression-type models using S4 classes and methods. @@ -15,4 +15,4 @@ URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1081 +VCS/SVNRevision: 1097 Modified: branches/robast-1.2/pkg/RandVar/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RandVar/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RandVar/DESCRIPTION 2018-08-03 17:19:23 UTC (rev 1098) @@ -1,12 +1,13 @@ Package: RandVar Version: 1.2.0 -Date: 2018-07-25 +Date: 2018-08-03 Title: Implementation of Random Variables Description: Implements random variables by means of S4 classes and methods. Depends: R (>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5) Imports: startupmsg -Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", - role=c("aut", "cph"))) +Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), + email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", role=c("aut", + "cph"))) ByteCompile: yes LazyLoad: yes License: LGPL-3 @@ -14,4 +15,4 @@ URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1058 +VCS/SVNRevision: 1097 Modified: branches/robast-1.2/pkg/RandVar/man/0RandVar-package.Rd =================================================================== --- branches/robast-1.2/pkg/RandVar/man/0RandVar-package.Rd 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RandVar/man/0RandVar-package.Rd 2018-08-03 17:19:23 UTC (rev 1098) @@ -12,14 +12,14 @@ \tabular{ll}{ Package: \tab RandVar \cr Version: \tab 1.2.0 \cr -Date: \tab 2018-07-25 \cr +Date: \tab 2018-08-03 \cr Depends: \tab R (>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5)\cr Imports: \tab startupmsg \cr ByteCompile: \tab yes \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1058 \cr +VCS/SVNRevision: \tab 1097 \cr } } \author{ Modified: branches/robast-1.2/pkg/RobAStBase/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobAStBase/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RobAStBase/DESCRIPTION 2018-08-03 17:19:23 UTC (rev 1098) @@ -1,19 +1,22 @@ Package: RobAStBase Version: 1.2.0 -Date: 2018-07-25 +Date: 2018-08-03 Title: Robust Asymptotic Statistics Description: Base S4-classes and functions for robust asymptotic statistics. -Depends: R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), RandVar(>= 0.9.2) +Depends: R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), + RandVar(>= 0.9.2) Suggests: ROptEst(>= 1.1.0), RUnit(>= 0.4.26) Imports: startupmsg, graphics, grDevices, stats -Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), email="Matthias.Kohl at stamats.de"), person("Peter", - "Ruckdeschel",role=c("aut", "cph")), person("Mykhailo", "Pupashenko", role="ctb", comment="contributed wrapper functions for - diagnostic plots"), person("Gerald", "Kroisandt", role="ctb", comment="contributed testing routines"), person("R Core Team", role = - c("ctb", "cph"), comment="for source file 'format.perc'")) +Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), + email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel",role=c("aut", "cph")), + person("Mykhailo", "Pupashenko", role="ctb", comment="contributed wrapper functions for + diagnostic plots"), person("Gerald", "Kroisandt", role="ctb", comment="contributed + testing routines"), person("R Core Team", role = c("ctb", "cph"), comment="for source + file 'format.perc'")) ByteCompile: yes License: LGPL-3 Encoding: latin1 URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1058 +VCS/SVNRevision: 1097 Modified: branches/robast-1.2/pkg/RobAStBase/man/0RobAStBase-package.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/0RobAStBase-package.Rd 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RobAStBase/man/0RobAStBase-package.Rd 2018-08-03 17:19:23 UTC (rev 1098) @@ -12,7 +12,7 @@ \tabular{ll}{ Package: \tab RobAStBase \cr Version: \tab 1.2.0 \cr -Date: \tab 2018-07-25 \cr +Date: \tab 2018-08-03 \cr Depends: \tab R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), RandVar(>= 0.9.2)\cr Suggests: \tab ROptEst, RUnit (>= 0.4.26)\cr @@ -21,7 +21,7 @@ Encoding: \tab latin1 \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1058 \cr +VCS/SVNRevision: \tab 1097 \cr } } \author{ Modified: branches/robast-1.2/pkg/RobAStRDA/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobAStRDA/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RobAStRDA/DESCRIPTION 2018-08-03 17:19:23 UTC (rev 1098) @@ -1,20 +1,25 @@ Package: RobAStRDA Version: 1.2.0 -Date: 2018-07-25 +Date: 2018-08-03 Title: Interpolation Grids for Packages of the 'RobASt' - Family of Packages -Description: Includes 'sysdata.rda' file for packages of the 'RobASt' - family of packages; is currently used by package 'RobExtremes' only. +Description: Includes 'sysdata.rda' file for packages of the 'RobASt' - family of packages; is + currently used by package 'RobExtremes' only. Depends: R (>= 2.3.0) -Authors at R: c(person("Matthias", "Kohl", role=c("aut", "cph")), person("Bernhard", "Spangl",role="ctb", comment="contributed smoothed grid values - of the Lagrange multipliers"), person("Sascha", "Desmettre", role="ctb", comment="contributed smoothed grid values of the Lagrange - multipliers"), person("Eugen", "Massini", role="ctb", comment="contributed an interactive smoothing routine for smoothing the - Lagrange multipliers and smoothed grid values of the Lagrange multipliers"), person("Mykhailo", "Pupashenko", role="ctb", - comment="helped with manual smoothing of the interpolators"), person("Daria", "Pupashenko", role="ctb", comment="helped with manual - smoothing of the interpolators"), person("Gerald", "Kroisandt", role="ctb", comment="helped with manual smoothing of the - interpolators"), person("Peter", "Ruckdeschel", role=c("cre", "cph", "aut"), email="peter.ruckdeschel at uni-oldenburg.de")) +Authors at R: c(person("Matthias", "Kohl", role=c("aut", "cph")), person("Bernhard", + "Spangl",role="ctb", comment="contributed smoothed grid values of the Lagrange + multipliers"), person("Sascha", "Desmettre", role="ctb", comment="contributed smoothed + grid values of the Lagrange multipliers"), person("Eugen", "Massini", role="ctb", + comment="contributed an interactive smoothing routine for smoothing the Lagrange + multipliers and smoothed grid values of the Lagrange multipliers"), person("Mykhailo", + "Pupashenko", role="ctb", comment="helped with manual smoothing of the interpolators"), + person("Daria", "Pupashenko", role="ctb", comment="helped with manual smoothing of the + interpolators"), person("Gerald", "Kroisandt", role="ctb", comment="helped with manual + smoothing of the interpolators"), person("Peter", "Ruckdeschel", role=c("cre", "cph", + "aut"), email="peter.ruckdeschel at uni-oldenburg.de")) LazyData: yes ByteCompile: yes License: LGPL-3 URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1058 +VCS/SVNRevision: 1097 Modified: branches/robast-1.2/pkg/RobAStRDA/man/0RobRDA-package.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStRDA/man/0RobRDA-package.Rd 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RobAStRDA/man/0RobRDA-package.Rd 2018-08-03 17:19:23 UTC (rev 1098) @@ -32,13 +32,13 @@ \tabular{ll}{ Package: \tab RobAStRDA \cr Version: \tab 1.2.0 \cr -Date: \tab 2018-07-25 \cr +Date: \tab 2018-08-03 \cr Depends: \tab R (>= 2.3.0) \cr LazyData: \tab yes \cr ByteCompile: \tab yes \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1058 \cr +VCS/SVNRevision: \tab 1097 \cr } } Modified: branches/robast-1.2/pkg/RobExtremes/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobExtremes/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RobExtremes/DESCRIPTION 2018-08-03 17:19:23 UTC (rev 1098) @@ -1,19 +1,24 @@ Package: RobExtremes Version: 1.2.0 -Date: 2018-07-25 +Date: 2018-08-03 Title: Optimally Robust Estimation for Extreme Value Distributions Description: Optimally robust estimation for extreme value distributions using S4 classes and - methods (based on packages 'distr', 'distrEx', 'distrMod', 'RobAStBase', and 'ROptEst'). + methods (based on packages 'distr', 'distrEx', 'distrMod', 'RobAStBase', and + 'ROptEst'). Depends: R (>= 2.14.0), methods, distrMod(>= 2.7.0), ROptEst(>= 1.1.0), robustbase, evd Suggests: RUnit (>= 0.4.26), ismev (>= 1.39) Imports: RobAStRDA, distr, distrEx, RandVar, RobAStBase, startupmsg, actuar -Authors at R: c(person("Nataliya", "Horbenko", role=c("aut","cph")), person("Bernhard", "Spangl", role="ctb", comment="contributed smoothed grid - values of the Lagrange multipliers"), person("Sascha", "Desmettre", role="ctb", comment="contributed smoothed grid values of the - Lagrange multipliers"), person("Eugen", "Massini", role="ctb", comment="contributed an interactive smoothing routine for smoothing - the Lagrange multipliers and smoothed grid values of the Lagrange multipliers"), person("Daria", "Pupashenko", role="ctb", - comment="contributed MDE-estimation for GEV distribution in the framework of her PhD thesis 2011--14"), person("Gerald", - "Kroisandt", role="ctb", comment="contributed testing routines"), person("Matthias", "Kohl", role=c("aut", "cph")), person("Peter", - "Ruckdeschel", role=c("cre", "aut", "cph"), email="peter.ruckdeschel at uni-oldenburg.de")) +Authors at R: c(person("Nataliya", "Horbenko", role=c("aut","cph")), person("Bernhard", "Spangl", + role="ctb", comment="contributed smoothed grid values of the Lagrange multipliers"), + person("Sascha", "Desmettre", role="ctb", comment="contributed smoothed grid values of + the Lagrange multipliers"), person("Eugen", "Massini", role="ctb", comment="contributed + an interactive smoothing routine for smoothing the Lagrange multipliers and smoothed + grid values of the Lagrange multipliers"), person("Daria", "Pupashenko", role="ctb", + comment="contributed MDE-estimation for GEV distribution in the framework of her PhD + thesis 2011--14"), person("Gerald", "Kroisandt", role="ctb", comment="contributed + testing routines"), person("Matthias", "Kohl", role=c("aut", "cph")), person("Peter", + "Ruckdeschel", role=c("cre", "aut", "cph"), + email="peter.ruckdeschel at uni-oldenburg.de")) ByteCompile: yes LazyLoad: yes License: LGPL-3 @@ -21,4 +26,4 @@ URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1058 +VCS/SVNRevision: 1097 Modified: branches/robast-1.2/pkg/RobExtremes/man/0RobExtremes-package.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/0RobExtremes-package.Rd 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RobExtremes/man/0RobExtremes-package.Rd 2018-08-03 17:19:23 UTC (rev 1098) @@ -102,8 +102,8 @@ \details{ \tabular{ll}{ Package: \tab RobExtremes \cr -Version: \tab 1.1.0 \cr -Date: \tab 2018-07-19 \cr +Version: \tab 1.2.0 \cr +Date: \tab 2018-08-03 \cr Title: \tab Optimally Robust Estimation for Extreme Value Distributions\cr Description: \tab Optimally robust estimation for extreme value distributions using S4 classes and methods \cr @@ -130,7 +130,7 @@ License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr Encoding: \tab latin1 \cr -VCS/SVNRevision: \tab 940 \cr +VCS/SVNRevision: \tab 1097 \cr } } Modified: branches/robast-1.2/pkg/RobLox/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobLox/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RobLox/DESCRIPTION 2018-08-03 17:19:23 UTC (rev 1098) @@ -1,17 +1,19 @@ Package: RobLox Version: 1.2.0 -Date: 2018-07-25 +Date: 2018-08-03 Title: Optimally Robust Influence Curves and Estimators for Location and Scale -Description: Functions for the determination of optimally robust influence curves and estimators in case of normal location and/or scale. +Description: Functions for the determination of optimally robust influence curves and + estimators in case of normal location and/or scale. Depends: R(>= 2.14.0), stats, distrMod(>= 2.5.2), RobAStBase(>= 0.9) Imports: methods, lattice, RColorBrewer, Biobase, RandVar(>= 0.9.2), distr(>= 2.5.2) Suggests: MASS -Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph"), email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", role=c("aut", - "cph"))) +Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph"), + email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", role=c("aut", + "cph"))) ByteCompile: yes License: LGPL-3 Encoding: latin1 URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1058 +VCS/SVNRevision: 1097 Modified: branches/robast-1.2/pkg/RobLox/man/0RobLox-package.Rd =================================================================== --- branches/robast-1.2/pkg/RobLox/man/0RobLox-package.Rd 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RobLox/man/0RobLox-package.Rd 2018-08-03 17:19:23 UTC (rev 1098) @@ -13,14 +13,14 @@ \tabular{ll}{ Package: \tab RobLox \cr Version: \tab 1.2.0 \cr -Date: \tab 2018-07-25 \cr +Date: \tab 2018-08-03 \cr Depends: \tab R(>= 2.14.0), stats, distrMod(>= 2.5.2), RobAStBase(>= 0.9) \cr Imports: \tab lattice, RColorBrewer, Biobase, RandVar(>= 0.9.2), distr(>= 2.5.2) \cr Suggests: \tab MASS\cr ByteCompile: \tab yes \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1058 \cr +VCS/SVNRevision: \tab 1097 \cr } } \author{Matthias Kohl \email{matthias.kohl at stamats.de}} Modified: branches/robast-1.2/pkg/RobLoxBioC/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobLoxBioC/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RobLoxBioC/DESCRIPTION 2018-08-03 17:19:23 UTC (rev 1098) @@ -1,17 +1,19 @@ Package: RobLoxBioC Version: 1.2.0 -Date: 2018-07-25 +Date: 2018-08-03 Title: Infinitesimally Robust Estimators for Preprocessing -Omics Data -Description: Functions for the determination of optimally robust influence curves and estimators for preprocessing omics data, in particular - gene expression data. +Description: Functions for the determination of optimally robust influence curves and + estimators for preprocessing omics data, in particular gene expression data. Depends: R(>= 2.14.0), methods, distr(>= 2.7.0), affy -Imports: Biobase, BiocGenerics, beadarray, RobLox(>= 1.1.0), distrMod(>= 2.7.0), lattice, RColorBrewer, AnnotationDbi +Imports: Biobase, BiocGenerics, beadarray, RobLox(>= 1.1.0), distrMod(>= 2.7.0), lattice, + RColorBrewer, AnnotationDbi Suggests: affydata, hgu95av2cdf, beadarrayExampleData, illuminaHumanv3.db -Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), email="Matthias.Kohl at stamats.de") +Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), + email="Matthias.Kohl at stamats.de") ByteCompile: yes License: LGPL-3 URL: http://robast.r-forge.r-project.org/ Encoding: latin1 LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1058 +VCS/SVNRevision: 1097 Modified: branches/robast-1.2/pkg/RobLoxBioC/man/0RobLoxBioC-package.Rd =================================================================== --- branches/robast-1.2/pkg/RobLoxBioC/man/0RobLoxBioC-package.Rd 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RobLoxBioC/man/0RobLoxBioC-package.Rd 2018-08-03 17:19:23 UTC (rev 1098) @@ -13,14 +13,14 @@ \tabular{ll}{ Package: \tab RobLoxBioC \cr Version: \tab 1.2.0 \cr -Date: \tab 2018-07-25 \cr +Date: \tab 2018-08-03 \cr Depends:\tab R(>= 2.14.0), methods, distr(>= 2.5.2), affy \cr Imports:\tab Biobase, BiocGenerics, beadarray, RobLox(>= 0.9.2), distrMod(>= 2.5.2), lattice, RColorBrewer \cr Suggests:\tab affydata, hgu95av2cdf, beadarrayExampleData, illuminaHumanv3.db \cr ByteCompile: \tab yes \cr License: \tab LGPL-3 \cr URL: \tab http://robast.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1058 \cr +VCS/SVNRevision: \tab 1097 \cr Encoding: \tab latin1 \cr } } Modified: branches/robast-1.2/pkg/RobRex/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobRex/DESCRIPTION 2018-08-03 17:17:39 UTC (rev 1097) +++ branches/robast-1.2/pkg/RobRex/DESCRIPTION 2018-08-03 17:19:23 UTC (rev 1098) @@ -1,16 +1,18 @@ Package: RobRex Version: 1.2.0 -Date: 2018-07-25 +Date: 2018-08-03 Title: Optimally Robust Influence Curves for Regression and Scale -Description: Functions for the determination of optimally robust influence curves in case of linear regression with unknown scale and standard - normal distributed errors where the regressor is random. +Description: Functions for the determination of optimally robust influence curves in case of + linear regression with unknown scale and standard normal distributed errors where the + regressor is random. Depends: R (>= 2.14.0), ROptRegTS(>= 1.1.0) Imports: distr(>= 2.7.0), RandVar(>= 1.1.0), RobAStBase(>= 1.1.0), methods -Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), email="Matthias.Kohl at stamats.de") +Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), + email="Matthias.Kohl at stamats.de") ByteCompile: yes License: LGPL-3 Encoding: latin1 URL: http://robast.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1058 +VCS/SVNRevision: 1097 From noreply at r-forge.r-project.org Sat Aug 4 11:52:24 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 4 Aug 2018 11:52:24 +0200 (CEST) Subject: [Robast-commits] r1099 - branches/robast-1.2/pkg/RobRex/man Message-ID: <20180804095224.4DD8A18A1EE@r-forge.r-project.org> Author: stamats Date: 2018-08-04 11:52:23 +0200 (Sat, 04 Aug 2018) New Revision: 1099 Modified: branches/robast-1.2/pkg/RobRex/man/rgsOptIC.ALc.Rd Log: don't test to reduce check time Modified: branches/robast-1.2/pkg/RobRex/man/rgsOptIC.ALc.Rd =================================================================== --- branches/robast-1.2/pkg/RobRex/man/rgsOptIC.ALc.Rd 2018-08-03 17:19:23 UTC (rev 1098) +++ branches/robast-1.2/pkg/RobRex/man/rgsOptIC.ALc.Rd 2018-08-04 09:52:23 UTC (rev 1099) @@ -49,11 +49,14 @@ %\note{} \seealso{\code{Av1CondContIC-class}} \examples{ +## don't test to reduce check time +\donttest{ K <- DiscreteDistribution(1:5) # = Unif({1,2,3,4,5}) IC1 <- rgsOptIC.ALc(r = 0.1, K = K) checkIC(IC1) Risks(IC1) } +} \concept{regression and scale} \concept{influence curve} \keyword{robust} From noreply at r-forge.r-project.org Sat Aug 4 11:56:01 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 4 Aug 2018 11:56:01 +0200 (CEST) Subject: [Robast-commits] r1100 - in pkg: RobLoxBioC RobRex/man Message-ID: <20180804095601.5DF8A18A1EE@r-forge.r-project.org> Author: stamats Date: 2018-08-04 11:56:01 +0200 (Sat, 04 Aug 2018) New Revision: 1100 Modified: pkg/RobLoxBioC/DESCRIPTION pkg/RobRex/man/rgsOptIC.ALc.Rd Log: added doi and donttest Modified: pkg/RobLoxBioC/DESCRIPTION =================================================================== --- pkg/RobLoxBioC/DESCRIPTION 2018-08-04 09:52:23 UTC (rev 1099) +++ pkg/RobLoxBioC/DESCRIPTION 2018-08-04 09:56:01 UTC (rev 1100) @@ -3,13 +3,14 @@ Date: 2018-08-01 Title: Infinitesimally Robust Estimators for Preprocessing -Omics Data Description: Functions for the determination of optimally robust influence curves and - estimators for preprocessing omics data, in particular gene expression data. + estimators for preprocessing omics data, in particular gene expression data; + see Kohl and Deigner (2019) . Depends: R(>= 2.14.0), methods, distr(>= 2.7.0), affy Imports: Biobase, BiocGenerics, beadarray, RobLox(>= 1.1.0), distrMod(>= 2.7.0), lattice, RColorBrewer, AnnotationDbi Suggests: affydata, hgu95av2cdf, beadarrayExampleData, illuminaHumanv3.db Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), - email="Matthias.Kohl at stamats.de") + email="Matthias.Kohl at stamats.de", comment = c(ORCID = "0000-0001-9514-8910")) ByteCompile: yes License: LGPL-3 URL: http://robast.r-forge.r-project.org/ Modified: pkg/RobRex/man/rgsOptIC.ALc.Rd =================================================================== --- pkg/RobRex/man/rgsOptIC.ALc.Rd 2018-08-04 09:52:23 UTC (rev 1099) +++ pkg/RobRex/man/rgsOptIC.ALc.Rd 2018-08-04 09:56:01 UTC (rev 1100) @@ -49,11 +49,14 @@ %\note{} \seealso{\code{Av1CondContIC-class}} \examples{ +## don't test to reduce check time +\donttest{ K <- DiscreteDistribution(1:5) # = Unif({1,2,3,4,5}) IC1 <- rgsOptIC.ALc(r = 0.1, K = K) checkIC(IC1) Risks(IC1) } +} \concept{regression and scale} \concept{influence curve} \keyword{robust} From noreply at r-forge.r-project.org Mon Aug 6 08:35:45 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 08:35:45 +0200 (CEST) Subject: [Robast-commits] r1101 - in branches/robast-1.2/pkg/RobAStBase: . R inst man Message-ID: <20180806063545.5075C18420B@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 08:35:44 +0200 (Mon, 06 Aug 2018) New Revision: 1101 Added: branches/robast-1.2/pkg/RobAStBase/R/getPIC.R Modified: branches/robast-1.2/pkg/RobAStBase/DESCRIPTION branches/robast-1.2/pkg/RobAStBase/NAMESPACE branches/robast-1.2/pkg/RobAStBase/R/AllClass.R branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R branches/robast-1.2/pkg/RobAStBase/R/bALEstimate.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd branches/robast-1.2/pkg/RobAStBase/man/OptionalInfluenceCurve-Class.Rd Log: [RobAStBase] branch 1.2: + new S4 (estimator) class "MCALEstimate" containing both "MCEstimate" and "ALEstimate" to make accessible pIC-methods to CvMMDEstimators... + new .checkEstClassForParamFamily method to force (expost) casting to MCALEstimate (with pIC) + to speed up things slot pIC is filled with a promise only which is only forced when called through accessor pIC (and then the slot is filled with the actual pIC) + technically this is realized by a slot pIC of class OptionalInfluenceCurveOrCall + internal function .getPIC is the workhorse: it takes the estimator evaluates its argument ParamFamily from slot estimate.call and moves it to the parameter value which was estimated; at this parameter value, the IC is constructed + new internal helper method getPIC to get hand on the pIC --> for MLE it computes it by optIC --> for CvMMDEstimators -- it uses the name of the estimator; more specifically it relies on tag * "( mu = emp. cdf )" => this uses .CvMMDCovarianceWithMux * "( mu = model distr. )" => this uses .CvMMDCovariance with no argument mu * "( mu = )" => this uses .CvMMDCovariance with argument mu to get the pIC Modified: branches/robast-1.2/pkg/RobAStBase/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobAStBase/DESCRIPTION 2018-08-04 09:56:01 UTC (rev 1100) +++ branches/robast-1.2/pkg/RobAStBase/DESCRIPTION 2018-08-06 06:35:44 UTC (rev 1101) @@ -3,8 +3,8 @@ Date: 2018-08-03 Title: Robust Asymptotic Statistics Description: Base S4-classes and functions for robust asymptotic statistics. -Depends: R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), - RandVar(>= 0.9.2) +Depends: R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.8.0), distrMod(>= 2.8.0), + RandVar(>= 1.1.0) Suggests: ROptEst(>= 1.1.0), RUnit(>= 0.4.26) Imports: startupmsg, graphics, grDevices, stats Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-04 09:56:01 UTC (rev 1100) +++ branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-06 06:35:44 UTC (rev 1101) @@ -25,10 +25,11 @@ "TotalVarIC") exportClasses("RobAStControl", "RobWeight", "BoundedWeight", "BdStWeight", "HampelWeight") -exportClasses("ALEstimate", "kStepEstimate", "MEstimate") +exportClasses("ALEstimate", "MCALEstimate", "kStepEstimate", "MEstimate") exportClasses("cutoff") exportClasses("interpolRisk", "OMSRRisk","MBRRisk","RMXRRisk") -exportClasses("StartClass", "pICList", "OptionalpICList", "OptionalCall") +exportClasses("StartClass", "pICList", "OptionalpICList", "OptionalCall", + "OptionalInfluenceCurveOrCall") exportMethods("show", "plot") exportMethods("type", "radius", "radius<-") @@ -73,7 +74,7 @@ exportMethods("ddPlot", "qqplot", "returnlevelplot") exportMethods("cutoff.quantile", "cutoff.quantile<-") exportMethods("samplesize<-", "samplesize") -exportMethods("getRiskFctBV", "getFiRisk") +exportMethods("getRiskFctBV", "getFiRisk", "getPIC") export("oneStepEstimator", "kStepEstimator") export("ContNeighborhood", "TotalVarNeighborhood") export("FixRobModel", "InfRobModel") Modified: branches/robast-1.2/pkg/RobAStBase/R/AllClass.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/AllClass.R 2018-08-04 09:56:01 UTC (rev 1100) +++ branches/robast-1.2/pkg/RobAStBase/R/AllClass.R 2018-08-06 06:35:44 UTC (rev 1101) @@ -216,6 +216,7 @@ ## ALEstimate setClassUnion("OptionalCall", c("call","NULL")) setClassUnion("OptionalInfluenceCurve", c("InfluenceCurve", "NULL")) +setClassUnion("OptionalInfluenceCurveOrCall", c("InfluenceCurve", "NULL", "call")) setClassUnion("StartClass", c("numeric", "matrix", "function", "Estimate")) setClass("pICList", prototype = prototype(list()), @@ -231,7 +232,7 @@ }) setClassUnion("OptionalpICList", c("pICList", "NULL")) setClass("ALEstimate", - representation(pIC = "OptionalInfluenceCurve", + representation(pIC = "OptionalInfluenceCurveOrCall", #"OptionalInfluenceCurve", asbias = "OptionalNumeric"), prototype(name = "Asymptotically linear estimate", estimate = numeric(0), @@ -250,6 +251,16 @@ untransformed.estimate = NULL, untransformed.asvar = NULL), contains = "Estimate") + +setClass("MCALEstimate", + representation(pIC = "OptionalInfluenceCurveOrCall", + asbias = "OptionalNumeric"), + prototype(name = "Minimum criterion estimate (which is asy. linear)", + asbias = NULL, + pIC = NULL), + contains = c("ALEstimate","MCEstimate") +) + setClass("kStepEstimate", representation(steps = "integer", pICList = "OptionalpICList", Modified: branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R 2018-08-04 09:56:01 UTC (rev 1100) +++ branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R 2018-08-06 06:35:44 UTC (rev 1101) @@ -247,3 +247,6 @@ setGeneric("getFiRisk", function(risk, Distr, neighbor, ...) standardGeneric("getFiRisk")) } +if(!isGeneric("getPIC")){ + setGeneric("getPIC", function(estimator) standardGeneric("getPIC")) +} Modified: branches/robast-1.2/pkg/RobAStBase/R/bALEstimate.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/bALEstimate.R 2018-08-04 09:56:01 UTC (rev 1100) +++ branches/robast-1.2/pkg/RobAStBase/R/bALEstimate.R 2018-08-06 06:35:44 UTC (rev 1101) @@ -2,7 +2,24 @@ ## Functions and methods for "ALEstimate" classes and subclasses ############################################################################### -setMethod("pIC", "ALEstimate", function(object) object at pIC) + +setMethod("pIC", "ALEstimate", function(object){ + pIC0 <- .getPIC(object) + eval.parent(substitute(object at pIC <- pIC0)) + return(pIC0) +}) + +setMethod("pIC", "MCEstimate", function(object){ + if("pIC" %in% slotNames(class(object))){ + pIC0 <- .getPIC(object) + eval.parent(substitute(object at pIC <- pIC0)) + return(pIC0) + }else{ + return(getPIC(object)) + }}) + +setMethod("pIC", "MCALEstimate", getMethod("pIC", "ALEstimate")) + setMethod("asbias", "ALEstimate", function(object) object at asbias) setMethod("steps", "kStepEstimate", function(object) object at steps) setMethod("Mroot", "MEstimate", function(object) object at Mroot) @@ -161,3 +178,11 @@ fixed.estimate = fixed(object), confint = ci) }) + + +#setAs("MCEstimate", "MCALEstimate", def = function(from){ +# fromSlotNames <- slotNames(class(from)) +# to <- new("MCALEstimate") +# for(item in fromSlotNames) slot(to, item) <- slot(from,item) +# to at pIC <- .getPIC(from) +# to}) Added: branches/robast-1.2/pkg/RobAStBase/R/getPIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getPIC.R (rev 0) +++ branches/robast-1.2/pkg/RobAStBase/R/getPIC.R 2018-08-06 06:35:44 UTC (rev 1101) @@ -0,0 +1,77 @@ +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="ANY",estimator="MCEstimate"), + function(PFam, estimator)estimator) + + +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="ANY",estimator="MCEstimate"), + function(PFam, estimator){ + fromSlotNames <- slotNames(class(estimator)) + to <- new("MCALEstimate") + for(item in fromSlotNames) slot(to, item) <- slot(estimator,item) + to at pIC <- substitute(getPIC(estimator0), list(estimator0=estimator)) + to + } ) + +.getPIC <- function(object){ + if(is.null(object at pIC)) return(NULL) + pIC0 <- object at pIC + if(is(pIC0, "InfluenceCurve")) return(pIC0) + if(is.call(pIC0)) pIC0 <- eval(pIC0) + return(pIC0) +} + +.getL2Fam <- function(estimator){ + ecl <- as.list(estimator at estimate.call)[-1] + L2Fam0 <- eval(ecl[["ParamFamily"]]) + param.0 <- param(L2Fam0) + theta <- untransformed.estimate(estimator) + idx <- idx.m <- seq(length(theta)) + if(!is.null(nuisance(param.0))){ + lnx <- length(nuisance(param.0)) + idx.n <- rev(rev(idx)[1:lnx]) + idx.m <- idx[-idx.n] + param.0 at nuisance <- theta[idx.m] + } + param.0 at main <- theta[idx.m] + param.0 at trafo <- trafo(estimator)$mat + L2Fam <- modifyModel(L2Fam0, param.0) + return(L2Fam) +} + + +setMethod("getPIC","ANY", function(estimator)NULL) + +setMethod("getPIC","MLEstimate", function(estimator){ + L2Fam <- .getL2Fam(estimator) + pIC <- optIC(L2Fam, risk=asCov()) + return(pIC) + }) + +setMethod("getPIC","CvMMDEstimate", function(estimator){ + L2Fam <- .getL2Fam(estimator) + param.0 <- param(L2Fam) + ecl <- as.list(estimator at estimate.call)[-1] + print(system.time({ + if(grepl("mu = model distr",name(estimator))){ + res <- .CvMMDCovariance(L2Fam=L2Fam, param=param.0,withpreIC=TRUE, N = 2000) + }else{ + if(grepl("mu = emp\\. cdf",name(estimator))){ + x <- eval(ecl$x) + res <- .CvMMDCovarianceWithMux(L2Fam = L2Fam, param=param.0,x=x,withpreIC=TRUE, N = 2000) + }else{ + mu <- eval(ecl$mu) + res <- .CvMMDCovariance(L2Fam=L2Fam, param=param.0,x=x,withpreIC=TRUE, mu=mu, N = 2000) + } + } + })) + ICCurve <- res$preIC + ICname <- "IC of CvM MDE" + ICCallL2Fam <- L2Fam at fam.call + ICRisks <- list(asCov = estimator at asvar) + ICInfos = matrix(c("pIC-CvM-MDE","computed by .CvMMDCovariance[WithMux]"), ncol=2, + dimnames=list(character(0), c("method", "message"))) + pIC <- IC(name = ICname, Curve = ICCurve, Risks=ICRisks, + Infos = ICInfos, CallL2Fam = ICCallL2Fam, modifyIC = NULL) + return(pIC) + }) Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-04 09:56:01 UTC (rev 1100) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-06 06:35:44 UTC (rev 1101) @@ -177,10 +177,15 @@ as(projker %*% IC.UpdateInKer at Curve, "EuclRandVariable") IC.tot.0 <- IC.tot1 + IC.tot2 - }else{ - IC.tot.0 <- if(!is.null(IC.UpdateInKer.0)) - IC.tot1 + as(projker %*% IC.UpdateInKer.0 at Curve, - "EuclRandVariable") else NULL + }else{ if(!is.null(IC.UpdateInKer.0)){ + IC.tot.0 <- NULL + }else{ + if(is.call(IC.UpdateInKer.0)) + IC.UpdateInKer.0 <- eval(IC.UpdateInKer.0) + IC.tot.0 <- IC.tot1 + as(projker %*% + IC.UpdateInKer.0 at Curve, + "EuclRandVariable") + } } IC.tot <- IC.tot1 + IC.tot2 correct <- rowMeans(evalRandVar(IC.tot, x0), na.rm = na.rm) Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-04 09:56:01 UTC (rev 1100) +++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-06 06:35:44 UTC (rev 1101) @@ -8,6 +8,36 @@ information) ####################################### +version 1.2 +####################################### + + + +under the hood ++ new S4 (estimator) class "MCALEstimate" containing both + "MCEstimate" and "ALEstimate" to make accessible pIC-methods + to CvMMDEstimators... ++ new .checkEstClassForParamFamily method to force (expost) + casting to MCALEstimate (with pIC) ++ to speed up things slot pIC is filled with a promise only + which is only forced when called through accessor pIC + (and then the slot is filled with the actual pIC) ++ technically this is realized by a slot pIC of + class OptionalInfluenceCurveOrCall ++ internal function .getPIC is the workhorse: it takes the + estimator evaluates its argument ParamFamily from slot estimate.call + and moves it to the parameter value which was estimated; + at this parameter value, the IC is constructed ++ new internal helper method getPIC to get hand on the pIC + --> for MLE it computes it by optIC + --> for CvMMDEstimators -- it uses the name of the estimator; + more specifically it relies on tag + * "( mu = emp. cdf )" => this uses .CvMMDCovarianceWithMux + * "( mu = model distr. )" => this uses .CvMMDCovariance with no argument mu + * "( mu = )" => this uses .CvMMDCovariance with argument mu + to get the pIC + +####################################### version 1.1 ####################################### Modified: branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd 2018-08-04 09:56:01 UTC (rev 1100) +++ branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd 2018-08-06 06:35:44 UTC (rev 1101) @@ -1,8 +1,11 @@ \name{ALEstimate-class} \docType{class} \alias{ALEstimate-class} +\alias{MCALEstimate-class} \alias{pIC} \alias{pIC,ALEstimate-method} +\alias{pIC,MCEstimate-method} +\alias{pIC,MCALEstimate-method} \alias{asbias} \alias{asbias,ALEstimate-method} \alias{show,ALEstimate-method} @@ -10,6 +13,11 @@ \alias{confint,ALEstimate,symmetricBias-method} \alias{confint,ALEstimate,onesidedBias-method} \alias{confint,ALEstimate,asymmetricBias-method} +\alias{.checkEstClassForParamFamily,ANY,MCEstimate-method} +\alias{getPIC} +\alias{getPIC,ANY-method} +\alias{getPIC,MLEstimate-method} +\alias{getPIC,CvMMDEstimate-method} \title{ALEstimate-class.} \description{Class of asymptotically linear estimates.} @@ -52,7 +60,9 @@ } } \section{Extends}{ -Class \code{"Estimate"}, directly. +Class \code{ALEstimate} extends class \code{"Estimate"}, directly. +Class \code{MCALEstimate} extends classes +\code{"ALEstimate"}, and \code{"MCEstimate"} directly. } \section{Methods}{ \describe{ @@ -77,13 +87,68 @@ asymmetrically. } } } +\details{The (return value) class of an estimator is of class \code{ALEstimate} + if it is asymptotically linear; then it has an influence function + (implemented in slot \code{pIC}) and so all the diagnostics for influence + functions are available; in addition it is asymptotically normal, so + we can (easily) deduce asymptotic covariances, hence may use these + in confidence intervals; in particular, the return values of \code{kStepEstimator} + \code{oneStepEstimator} (and \code{roptest}, \code{robest}, \code{RMXEstimator}, + \code{MBREstimator}, \code{OBREstimator}, \code{OMSEstimator} in package + 'ROptEst') are objects of (subclasses of) this class. + + As the return value of \code{CvMMDEEstimator} (or \code{MDEstimator} with + \code{CvMDist} or \code{CvMDist2} as distance) is asymptotically linear, + there is class \code{MCALEstimate} extending \code{MCEstimate} by + extra slots \code{pIC} and \code{asbias} (only filled optionally with + non-\code{NULL} values). Again all the diagnostics for influence + functions are then available. + + Helper method \code{getPIC} by means of the estimator class, and, in + case of estimators of class \code{CvMMDEstimate}, also the name + (in slot \code{name}) produces the (partial) influence function: + + calling + \code{.CvMMDCovariance} -- either directly or through wrapper + \code{.CvMMDCovarianceWithMux}. This is used in the corresponding + \code{coerce} / \code{setAs} method, which by + \code{setAs(object, "MCALEstimate")} coerces \code{object} from + class \code{"MCEstimate"} to \code{"MCALEstimate"}. + } + %\references{} -\author{Matthias Kohl \email{Matthias.Kohl at stamats.de}} +\author{Matthias Kohl \email{Matthias.Kohl at stamats.de} and +Peter Ruckdeschel \email{Peter.Ruckdeschel at uni-oldenburg.de}} %\note{} \seealso{\code{\link[distrMod]{Estimate-class}}} \examples{ ## prototype new("ALEstimate") + +## data example +set.seed(123) +x <- rgamma(50, scale = 0.5, shape = 3) + +## parametric family of probability measures +G <- GammaFamily(scale = 1, shape = 2) + +mle <- MLEstimator(x,G) +(picM <- pIC(mle)) + +## Kolmogorov(-Smirnov) minimum distance estimator +ke <- KolmogorovMDEstimator(x = x, ParamFamily = G) +pIC(ke) ## gives NULL + +## von Mises minimum distance estimator with default mu + +\donttest{ ## to save time for CRAN +system.time(me <- CvMMDEstimator(x = x, ParamFamily = G)) +str(me at pIC) ## a call +system.time(pIC0 <- pIC(me)) +str(me at pIC) ## now filled } + + +} \concept{estimate} \keyword{classes} Modified: branches/robast-1.2/pkg/RobAStBase/man/OptionalInfluenceCurve-Class.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/OptionalInfluenceCurve-Class.Rd 2018-08-04 09:56:01 UTC (rev 1100) +++ branches/robast-1.2/pkg/RobAStBase/man/OptionalInfluenceCurve-Class.Rd 2018-08-06 06:35:44 UTC (rev 1101) @@ -1,6 +1,7 @@ \name{OptionalInfluenceCurve-class} \docType{class} \alias{OptionalInfluenceCurve-class} +\alias{OptionalInfluenceCurveOrCall-class} \alias{OptionalpICList-class} \alias{StartClass-class} \alias{pICList-class} @@ -13,7 +14,9 @@ \code{StartClass}, \code{pICList}} \section{Class Unions}{ \code{OptionalInfluenceCurve} is a class union of classes - \code{InfluenceCurve} and \code{NULL} --- it is the slot + \code{InfluenceCurve} and \code{NULL}; + \code{OptionalInfluenceCurveOrCall} is a class union of classes + \code{InfluenceCurve}, \code{call}, and \code{NULL} --- it is the slot class of slot \code{pIC} in \code{ALEstimate}; \code{OptionalpICList} is a class union of classes \code{pICList} and \code{NULL} --- it is the slot From noreply at r-forge.r-project.org Mon Aug 6 14:48:26 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 14:48:26 +0200 (CEST) Subject: [Robast-commits] r1102 - branches/robast-1.2/pkg/RobAStBase/R Message-ID: <20180806124826.70E8F186FB1@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 14:48:26 +0200 (Mon, 06 Aug 2018) New Revision: 1102 Modified: branches/robast-1.2/pkg/RobAStBase/R/AllShow.R branches/robast-1.2/pkg/RobAStBase/R/getPIC.R Log: [RobAStBase]: branch 2.8 + some unnecessary coercions (with informatino loss) in show methods + commented out a timing done while checking Modified: branches/robast-1.2/pkg/RobAStBase/R/AllShow.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/AllShow.R 2018-08-06 06:35:44 UTC (rev 1101) +++ branches/robast-1.2/pkg/RobAStBase/R/AllShow.R 2018-08-06 12:48:26 UTC (rev 1102) @@ -95,7 +95,7 @@ setMethod("show", "ALEstimate", function(object){ digits <- getOption("digits") - show(as(object,"Estimate")) + getMethod("show","Estimate")(object) if(getdistrModOption("show.details") != "minimal"){ cat("asymptotic bias:\n") print(asbias(object), quote = FALSE) @@ -108,7 +108,7 @@ setMethod("show", "kStepEstimate", function(object){ digits <- getOption("digits") - show(as(object,"ALEstimate")) + getMethod("show","kStepEstimate")(object) if(getdistrModOption("show.details") != "minimal"){ cat("steps:\n") print(steps(object), quote = FALSE) @@ -117,7 +117,7 @@ setMethod("show", "MEstimate", function(object){ digits <- getOption("digits") - show(as(object,"ALEstimate")) + getMethod("show","ALEstimate")(object) if(getdistrModOption("show.details") != "minimal"){ cat("value of M equation:\n") print(Mroot(object), quote = FALSE) Modified: branches/robast-1.2/pkg/RobAStBase/R/getPIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getPIC.R 2018-08-06 06:35:44 UTC (rev 1101) +++ branches/robast-1.2/pkg/RobAStBase/R/getPIC.R 2018-08-06 12:48:26 UTC (rev 1102) @@ -52,7 +52,7 @@ L2Fam <- .getL2Fam(estimator) param.0 <- param(L2Fam) ecl <- as.list(estimator at estimate.call)[-1] - print(system.time({ +# print(system.time({ if(grepl("mu = model distr",name(estimator))){ res <- .CvMMDCovariance(L2Fam=L2Fam, param=param.0,withpreIC=TRUE, N = 2000) }else{ @@ -64,7 +64,7 @@ res <- .CvMMDCovariance(L2Fam=L2Fam, param=param.0,x=x,withpreIC=TRUE, mu=mu, N = 2000) } } - })) +# })) ICCurve <- res$preIC ICname <- "IC of CvM MDE" ICCallL2Fam <- L2Fam at fam.call From noreply at r-forge.r-project.org Mon Aug 6 14:57:21 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 14:57:21 +0200 (CEST) Subject: [Robast-commits] r1103 - in branches/robast-1.2/pkg/ROptEst: . R man Message-ID: <20180806125721.239EC186FB1@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 14:57:20 +0200 (Mon, 06 Aug 2018) New Revision: 1103 Modified: branches/robast-1.2/pkg/ROptEst/DESCRIPTION branches/robast-1.2/pkg/ROptEst/NAMESPACE branches/robast-1.2/pkg/ROptEst/R/comparePlot.R branches/robast-1.2/pkg/ROptEst/R/getStartIC.R branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R branches/robast-1.2/pkg/ROptEst/R/roptest.new.R branches/robast-1.2/pkg/ROptEst/man/getStartIC-methods.Rd Log: [ROptEst] branch 1.2: this was harder than thought: + require more recent versions in DESCRIPTION + L2LocationFamily, L2LocationScaleFamily, and L2LocationScaleFamily gain methods for interpolRisk ~> speed up is prepared (only need to store the reference LMs in sysdata.rda) => due to affine equivariance, we only have to store one set of LM's + comparePlot has a try catch now for MBRE + some buglets in getStartIC + some tedious debugging in getStartIClcsc.R + clarified if clauses in roptest.new (and removed .with.checkEstClassForParamFamily from dots to be sure) Modified: branches/robast-1.2/pkg/ROptEst/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/ROptEst/DESCRIPTION 2018-08-06 12:48:26 UTC (rev 1102) +++ branches/robast-1.2/pkg/ROptEst/DESCRIPTION 2018-08-06 12:57:20 UTC (rev 1103) @@ -4,8 +4,8 @@ Title: Optimally Robust Estimation Description: Optimally robust estimation in general smoothly parameterized models using S4 classes and methods. -Depends: R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), - RandVar(>= 0.9.2), RobAStBase(>= 1.0) +Depends: R(>= 2.14.0), methods, distr(>= 2.7.0), distrEx(>= 2.8.0), distrMod(>= 2.8.0), + RandVar(>= 1.1.0), RobAStBase(>= 1.2.0) Imports: startupmsg, MASS, stats, graphics, utils, grDevices Suggests: RobLox Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph"), Modified: branches/robast-1.2/pkg/ROptEst/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/ROptEst/NAMESPACE 2018-08-06 12:48:26 UTC (rev 1102) +++ branches/robast-1.2/pkg/ROptEst/NAMESPACE 2018-08-06 12:57:20 UTC (rev 1103) @@ -11,7 +11,8 @@ "title") importFrom("stats", "complete.cases", "dnorm", "na.omit", "optim", "optimize", "pnorm", "qnorm", "uniroot") -importFrom("utils", "read.csv", "read.table", "str", "write.table") +importFrom("utils", "read.csv", "read.table", "str", "write.table", + "getFromNamespace") importFrom("graphics", "abline") importFrom("MASS", "ginv") Modified: branches/robast-1.2/pkg/ROptEst/R/comparePlot.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/comparePlot.R 2018-08-06 12:48:26 UTC (rev 1102) +++ branches/robast-1.2/pkg/ROptEst/R/comparePlot.R 2018-08-06 12:57:20 UTC (rev 1103) @@ -74,7 +74,7 @@ MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T) if(withMBR && all(is.na(MBRB))){ ICmbr <- try(getStartIC(model = L2Fam, risk = MBRRisk()), silent=TRUE) - if(is(ICmbr),"try-error"){ + if(is(ICmbr,"try-error")){ robModel <- InfRobModel(center = L2Fam, neighbor = ContNeighborhood(radius = 0.5)) ICmbr <- try(optIC(model = robModel, risk = asBias()), silent=TRUE) Modified: branches/robast-1.2/pkg/ROptEst/R/getStartIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getStartIC.R 2018-08-06 12:48:26 UTC (rev 1102) +++ branches/robast-1.2/pkg/ROptEst/R/getStartIC.R 2018-08-06 12:57:20 UTC (rev 1103) @@ -13,6 +13,7 @@ }else fsCor <- 1 if("eps" %in% names(dots)){ eps <- dots[["eps"]] + names(eps) <- gsub("eps\\.","",names(eps)) dots$eps <- NULL }else eps <- NULL if("neighbor" %in% names(dots)){ @@ -20,6 +21,7 @@ dots$neighbor <- NULL }else neighbor <- ContNeighborhood() +# cat("......\n");print(eps);cat(":......\n") if(is.null(eps[["e"]])){ sm.rmx <- selectMethod("radiusMinimaxIC", signature( @@ -82,13 +84,19 @@ mc <- match.call(expand.dots=FALSE, call = sys.call(sys.parent(1))) dots <- as.list(mc$"...") + #print(mc) + #print(dots) + if("neighbor" %in% names(dots)){ neighbor <- eval(dots[["neighbor"]]) dots$neighbor <- NULL }else neighbor <- ContNeighborhood() + if("warn" %in% names(dots)) dots$warn <- NULL infMod <- InfRobModel(center = model, neighbor = neighbor) + #print(list(c(list(infMod, risk), dots, list(warn = FALSE, + # withMakeIC = withMakeIC, modifyICwarn = modifyICwarn)))) return(do.call(optIC, c(list(infMod, risk), dots, list(warn = FALSE, withMakeIC = withMakeIC, modifyICwarn = modifyICwarn)), envir=parent.frame(2))) Modified: branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R 2018-08-06 12:48:26 UTC (rev 1102) +++ branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R 2018-08-06 12:57:20 UTC (rev 1103) @@ -2,7 +2,7 @@ setMethod("getStartIC",signature(model = "L2LocationFamily", risk = "interpolRisk"), function(model, risk, ...) .getStIC(model, risk, ..., intfct=.getPsi.loc, pkg="ROptEst")) -setMethod("getStartIC",signature(model = "L2LocationFamily", risk = "interpolRisk"), +setMethod("getStartIC",signature(model = "L2ScaleFamily", risk = "interpolRisk"), function(model, risk, ...) .getStIC(model, risk, ..., intfct=.getPsi.sca, pkg="ROptEst")) setMethod("getStartIC",signature(model = "L2LocationScaleFamily", risk = "interpolRisk"), @@ -10,8 +10,8 @@ .getStIC <- function(model,risk, ..., intfct, pkg="ROptEst"){ - mc <- match.call(call = sys.call(sys.parent(2))) - dots <- match.call(call = sys.call(sys.parent(2)), + mc <- match.call(call = sys.call(sys.parent(1))) + dots <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)$"..." gridn <- gsub("\\.","",type(risk)) @@ -44,9 +44,22 @@ return(IC0) } } - IC <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2)) - mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias() - mc$neighbor <- ContNeighborhood(radius=0.5) + mc1 <- as.list(mc)[-1] + mc1[["risk"]] <- if(type(risk)==".MBRE") asBias() else asMSE() + mc1[["neighbor"]] <- ContNeighborhood(radius=0.5) + mc1[["verbose"]] <- FALSE + if(type(risk)==".MBRE") mc1[["eps"]] <- list(e=40) + if(type(risk)==".OMSE"){ + n <- length(get("x", envir=parent.frame(2))) + eps <- list("e" =0.5/sqrt(n), "sqn"= sqrt(n)) + mc1[["eps"]] <- eps + } + if(type(risk)==".RMXE"){ + n <- length(get("x", envir=parent.frame(2))) + eps <- list("eps.lower"=0, "eps.upper"=20, "sqn"= sqrt(n)) + mc1[["eps"]] <- eps + } + IC <- do.call(getStartIC, mc1, envir=parent.frame(2)) return(IC) } Modified: branches/robast-1.2/pkg/ROptEst/R/roptest.new.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-06 12:48:26 UTC (rev 1102) +++ branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-06 12:57:20 UTC (rev 1103) @@ -220,6 +220,7 @@ .isOKsteps(steps) + dots$.with.checkEstClassForParamFamily <- NULL if(debug){ if(is.null(startCtrl$initial.est)){ print(substitute(MDEstimator(x = x0, ParamFamily = L2Fam0, @@ -235,13 +236,16 @@ L2Fam at startPar else startCtrl$startPar wMDE <- if(is.null(startCtrl$withMDE)) L2Fam at .withMDE else startCtrl$withMDE - if(is(startPar0, "function")) if(!wMDE){ - startCtrl$initial.est <- function(x,...)startPar0(x) - }else - startCtrl$initial.est <- MDEstimator(x = x, ParamFamily = L2Fam, - distance = startCtrl$distance, - startPar = startCtrl$startPar, ...) - + if(is(startPar0, "function") && (!wMDE)){ + startCtrl$initial.est <- function(x,...)startPar0(x) + }else{ + if(is(startPar0, "function")) startPar0 <- startPar0(x) + argListMDE <- c(list(x = x, ParamFamily = L2Fam, + distance = startCtrl$distance, + startPar = startPar0), dots, + list(.with.checkEstClassForParamFamily = FALSE)) + startCtrl$initial.est <- do.call(MDEstimator, argListMDE) + } } } nrvalues <- length(L2Fam at param) Modified: branches/robast-1.2/pkg/ROptEst/man/getStartIC-methods.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/getStartIC-methods.Rd 2018-08-06 12:48:26 UTC (rev 1102) +++ branches/robast-1.2/pkg/ROptEst/man/getStartIC-methods.Rd 2018-08-06 12:57:20 UTC (rev 1103) @@ -8,6 +8,9 @@ \alias{getStartIC,L2ParamFamily,asCov-method} \alias{getStartIC,L2ParamFamily,asAnscombe-method} \alias{getStartIC,L2ParamFamily,trAsCov-method} +\alias{getStartIC,L2LocationFamily,interpolRisk-method} +\alias{getStartIC,L2ScaleFamily,interpolRisk-method} +\alias{getStartIC,L2LocationScaleFamily,interpolRisk-method} \title{Methods for Function getStartIC in Package `ROptEst' } @@ -28,6 +31,9 @@ \S4method{getStartIC}{L2ParamFamily,asAnscombe}(model, risk, ..., withEvalAsVar = TRUE, withMakeIC = FALSE, ..debug=FALSE, modifyICwarn = NULL) +\S4method{getStartIC}{L2LocationFamily,interpolRisk}(model, risk, ...) +\S4method{getStartIC}{L2ScaleFamily,interpolRisk}(model, risk, ...) +\S4method{getStartIC}{L2LocationScaleFamily,interpolRisk}(model, risk, ...) } \arguments{ From noreply at r-forge.r-project.org Mon Aug 6 16:42:33 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 16:42:33 +0200 (CEST) Subject: [Robast-commits] r1104 - branches/robast-1.2/pkg/RobAStBase/R Message-ID: <20180806144233.72507183ACB@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 16:42:33 +0200 (Mon, 06 Aug 2018) New Revision: 1104 Modified: branches/robast-1.2/pkg/RobAStBase/R/AllShow.R Log: [RobAStBase] branch 1.2: Some bug in show methods Modified: branches/robast-1.2/pkg/RobAStBase/R/AllShow.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/AllShow.R 2018-08-06 12:57:20 UTC (rev 1103) +++ branches/robast-1.2/pkg/RobAStBase/R/AllShow.R 2018-08-06 14:42:33 UTC (rev 1104) @@ -108,7 +108,7 @@ setMethod("show", "kStepEstimate", function(object){ digits <- getOption("digits") - getMethod("show","kStepEstimate")(object) + getMethod("show","ALEstimate")(object) if(getdistrModOption("show.details") != "minimal"){ cat("steps:\n") print(steps(object), quote = FALSE) From noreply at r-forge.r-project.org Mon Aug 6 20:30:48 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 20:30:48 +0200 (CEST) Subject: [Robast-commits] r1105 - in branches/robast-1.2/pkg/RobAStBase: R inst man Message-ID: <20180806183048.9408F189C1F@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 20:30:48 +0200 (Mon, 06 Aug 2018) New Revision: 1105 Modified: branches/robast-1.2/pkg/RobAStBase/R/IC.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R branches/robast-1.2/pkg/RobAStBase/R/move2bckRefParam.R branches/robast-1.2/pkg/RobAStBase/R/optIC.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS branches/robast-1.2/pkg/RobAStBase/man/ContIC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/ContIC.Rd branches/robast-1.2/pkg/RobAStBase/man/HampIC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/IC.Rd branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC.Rd branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd Log: [RobAStBase] branch 1.2: + slot function modifyIC of the different IC classes gains an argument withMakeIC to be able to adjust this to a higher granularity Modified: branches/robast-1.2/pkg/RobAStBase/R/IC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-06 14:42:33 UTC (rev 1104) +++ branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-06 18:30:48 UTC (rev 1105) @@ -146,25 +146,23 @@ Y <- as(stand %*% IC1, "EuclRandVariable") #ICfct <- vector(mode = "list", length = dims) #ICfct[[1]] <- function(x){Y(x)} - ..modifnew <- function(L2Fam, IC) return(makeIC(IC,L2Fam)) - if(! ("modifyIC" %in% names(getSlots(class(IC))))){ - modifyIC <- ..modifnew - }else{ - if(!is.function(IC at modifyIC)){ - modifyIC <- ..modifnew - }else{ - .modifyIC <- IC at modifyIC - if(!is.null(attr(IC at modifyIC,"hasMakeICin.modifyIC"))){ - modifyIC <- .modifyIC - }else{ - modifyIC <- function(L2Fam, IC){ IC. <- .modifyIC(L2Fam, IC) - return(makeIC(IC., L2Fam)) } - } - } - } - attr(modifyIC,"hasMakeICin.modifyIC") <- TRUE + if(!is.function(IC at modifyIC)) + IC at modifyIC <- function(L2Fam, IC, withMakeIC) return(makeIC(IC,L2Fam)) +# modifyIC <- ..modifnew +# }else{ +# .modifyIC <- IC at modifyIC +# if(!is.null(attr(IC at modifyIC,"hasMakeICin.modifyIC"))){ +# modifyIC <- .modifyIC +# }else{ +# modifyIC <- function(L2Fam, IC){ IC. <- .modifyIC(L2Fam, IC) +# return(makeIC(IC., L2Fam)) } +# } +# } +# } +# attr(modifyIC,"hasMakeICin.modifyIC") <- TRUE + CallL2Fam <- L2Fam at fam.call return(IC(name = name(IC), @@ -174,7 +172,7 @@ "generated by affine linear trafo to enforce consistency"), ncol=2, dimnames=list(character(0), c("method", "message"))), CallL2Fam = CallL2Fam, - modifyIC = modifyIC)) + modifyIC = IC at modifyIC)) }) Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-06 14:42:33 UTC (rev 1104) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-06 18:30:48 UTC (rev 1105) @@ -145,10 +145,10 @@ L2Fam <- modifyModel(L2Fam, Param, .withL2derivDistr = L2Fam at .withEvalL2derivDistr) # print(L2Fam) - IC <- modifyIC(IC)(L2Fam, IC) + IC <- modifyIC(IC)(L2Fam, IC, withMakeIC = FALSE) if(steps==1L &&withMakeIC){ IC <- makeIC(IC, L2Fam) - IC at modifyIC <- oldmodifIC +# IC at modifyIC <- oldmodifIC } # print(IC) } @@ -246,7 +246,7 @@ L2Fam <- modifyModel(L2Fam, Param, .withL2derivDistr = L2Fam at .withEvalL2derivDistr) # print(L2Fam) - IC <- modifyIC(IC)(L2Fam, IC) + IC <- modifyIC(IC)(L2Fam, IC, withMakeIC = withMakeIC) # print(IC) } @@ -278,7 +278,7 @@ L2Fam <- upd$L2Fam if((i==steps)&&withMakeIC){ IC <- makeIC(IC,L2Fam) - IC at modifyIC <- modif.old +# IC at modifyIC <- modif.old } Param <- upd$Param tf <- trafo(L2Fam, Param) Modified: branches/robast-1.2/pkg/RobAStBase/R/move2bckRefParam.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/move2bckRefParam.R 2018-08-06 14:42:33 UTC (rev 1104) +++ branches/robast-1.2/pkg/RobAStBase/R/move2bckRefParam.R 2018-08-06 18:30:48 UTC (rev 1105) @@ -109,6 +109,6 @@ setMethod("moveICBackFromRefParam", signature(IC = "HampIC", L2Fam = "L2ParamFamily"), function(IC, L2Fam, ...){ IC <- moveICBackFromRefParam(as(IC,"IC"), L2Fam,...) - IC at modifyIC(L2Fam, IC) + IC at modifyIC(L2Fam, IC, withMakeIC = FALSE) return(IC)}) Modified: branches/robast-1.2/pkg/RobAStBase/R/optIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/optIC.R 2018-08-06 14:42:33 UTC (rev 1104) +++ branches/robast-1.2/pkg/RobAStBase/R/optIC.R 2018-08-06 18:30:48 UTC (rev 1105) @@ -6,7 +6,7 @@ Curve <- as((trafo(model at param) %*% solve(model at FisherInfo)) %*% model at L2deriv, "EuclRandVariable") asCov <- trafo(model at param) %*% solve(model at FisherInfo) %*% t(trafo(model at param)) - modifyIC <- function(L2Fam, IC){ optIC(L2Fam, asCov()) } + modifyIC <- function(L2Fam, IC, withMakeIC=FALSE){ optIC(L2Fam, asCov()) } L2call <- model at fam.call L2call$trafo <- trafo(model) IC.o <- IC( Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-06 14:42:33 UTC (rev 1104) +++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-06 18:30:48 UTC (rev 1105) @@ -11,8 +11,11 @@ version 1.2 ####################################### +user-visible CHANGES: ++ slot function modifyIC of the different IC classes gains + an argument withMakeIC to be able to adjust this to a + higher granularity - under the hood + new S4 (estimator) class "MCALEstimate" containing both "MCEstimate" and "ALEstimate" to make accessible pIC-methods Modified: branches/robast-1.2/pkg/RobAStBase/man/ContIC-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/ContIC-class.Rd 2018-08-06 14:42:33 UTC (rev 1104) +++ branches/robast-1.2/pkg/RobAStBase/man/ContIC-class.Rd 2018-08-06 18:30:48 UTC (rev 1105) @@ -41,11 +41,14 @@ \item{\code{Curve}:}{ object of class \code{"EuclRandVarList"}} + + \item{\code{modifyIC}:}{ Object of class \code{"OptionalFunction"}: - function of two arguments, which are an L2 parametric family - and an optional influence curve. Returns an object of - class \code{"IC"}. This slot is mainly used for internal - computations! } + function of three arguments, which are an L2 parametric family + and an optional influence curve, and a logical argument + whether to enforce the IC side conditions by \code{makeIC}. Returns an object of + class \code{"IC"}. This function is mainly used for internal + computations! } \item{\code{Risks}:}{ object of class \code{"list"}: list of risks; cf. \code{\link[distrMod]{RiskType-class}}. } Modified: branches/robast-1.2/pkg/RobAStBase/man/ContIC.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/ContIC.Rd 2018-08-06 14:42:33 UTC (rev 1104) +++ branches/robast-1.2/pkg/RobAStBase/man/ContIC.Rd 2018-08-06 18:30:48 UTC (rev 1105) @@ -40,8 +40,9 @@ \item{biastype}{ BiasType: type of the bias} \item{normtype}{ NormType: type of the norm} \item{modifyIC}{ object of class \code{"OptionalFunction"}: - function of two arguments, which are an L2 parametric family - and an optional influence curve. Returns an object of + function of three arguments, which are an L2 parametric family + and an optional influence curve, and a logical argument + whether to enforce the IC side conditions by \code{makeIC}. Returns an object of class \code{"IC"}. This function is mainly used for internal computations! } } Modified: branches/robast-1.2/pkg/RobAStBase/man/HampIC-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/HampIC-class.Rd 2018-08-06 14:42:33 UTC (rev 1104) +++ branches/robast-1.2/pkg/RobAStBase/man/HampIC-class.Rd 2018-08-06 18:30:48 UTC (rev 1105) @@ -32,10 +32,11 @@ \item{\code{Curve}}{ object of class \code{"EuclRandVarList"}} \item{\code{modifyIC}}{ Object of class \code{"OptionalFunction"}: - function of two arguments, which are an L2 parametric family - and an optional influence curve. Returns an object of - class \code{"IC"}. This slot is mainly used for internal - computations! } + function of three arguments, which are an L2 parametric family + and an optional influence curve, and a logical argument + whether to enforce the IC side conditions by \code{makeIC}. Returns an object of + class \code{"IC"}. This function is mainly used for internal + computations! } \item{\code{Risks}}{ object of class \code{"list"}: list of risks; cf. \code{\link[distrMod]{RiskType-class}}. } Modified: branches/robast-1.2/pkg/RobAStBase/man/IC.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/IC.Rd 2018-08-06 14:42:33 UTC (rev 1104) +++ branches/robast-1.2/pkg/RobAStBase/man/IC.Rd 2018-08-06 18:30:48 UTC (rev 1105) @@ -21,12 +21,12 @@ \item{Infos}{ matrix of characters with two columns named \code{method} and \code{message}: additional informations. } \item{modifyIC}{ Object of class \code{"OptionalFunction"}: - function of two arguments, which are an L2 parametric family - and an optional influence curve. Returns an object of - class \code{"IC"} at the parameter value of the L2 parametric - family. This function is mainly used for internal + function of three arguments, which are an L2 parametric family + and an optional influence curve, and a logical argument + whether to enforce the IC side conditions by \code{makeIC}. Returns an object of + class \code{"IC"}. This function is mainly used for internal computations! } -} + } %\details{} \value{Object of class \code{"IC"}} \references{ Modified: branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC-class.Rd 2018-08-06 14:42:33 UTC (rev 1104) +++ branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC-class.Rd 2018-08-06 18:30:48 UTC (rev 1105) @@ -42,10 +42,11 @@ \item{\code{Curve}}{ object of class \code{"EuclRandVarList"}.} \item{\code{modifyIC}}{ Object of class \code{"OptionalFunction"}: - function of two arguments, which are an L2 parametric family - and an optional influence curve. Returns an object of - class \code{"IC"}. This slot is mainly used for internal - computations! } + function of three arguments, which are an L2 parametric family + and an optional influence curve, and a logical argument + whether to enforce the IC side conditions by \code{makeIC}. Returns an object of + class \code{"IC"}. This function is mainly used for internal + computations! } \item{\code{Risks}}{ object of class \code{"list"}: list of risks; cf. \code{\link[distrMod]{RiskType-class}}. } Modified: branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC.Rd 2018-08-06 14:42:33 UTC (rev 1104) +++ branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC.Rd 2018-08-06 18:30:48 UTC (rev 1105) @@ -40,8 +40,9 @@ \item{biastype}{ BiasType: type of the bias} \item{normtype}{ NormType: type of the norm} \item{modifyIC}{ object of class \code{"OptionalFunction"}: - function of two arguments, which are an L2 parametric family - and an optional influence curve. Returns an object of + function of three arguments, which are an L2 parametric family + and an optional influence curve, and a logical argument + whether to enforce the IC side conditions by \code{makeIC}. Returns an object of class \code{"IC"}. This function is mainly used for internal computations! } } Modified: branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd 2018-08-06 14:42:33 UTC (rev 1104) +++ branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd 2018-08-06 18:30:48 UTC (rev 1105) @@ -33,10 +33,10 @@ \item{Infos}{ matrix of characters with two columns named \code{method} and \code{message}: additional informations. } \item{modifyIC}{ Object of class \code{"OptionalFunction"}: - function of two arguments, which are an L2 parametric family - and an optional influence curve. Returns an object of - class \code{"IC"} at the parameter value of the L2 parametric - family. This function is mainly used for internal + function of three arguments, which are an L2 parametric family + and an optional influence curve, and a logical argument + whether to enforce the IC side conditions by \code{makeIC}. Returns an object of + class \code{"IC"}. This function is mainly used for internal computations! } \item{\dots}{ additional parameters } } From noreply at r-forge.r-project.org Mon Aug 6 20:37:21 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 20:37:21 +0200 (CEST) Subject: [Robast-commits] r1106 - in branches/robast-1.2/pkg: ROptEst/R ROptEst/inst RobAStBase/inst Message-ID: <20180806183721.D364A18A253@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 20:37:21 +0200 (Mon, 06 Aug 2018) New Revision: 1106 Modified: branches/robast-1.2/pkg/ROptEst/R/getModifyIC.R branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R branches/robast-1.2/pkg/ROptEst/inst/NEWS branches/robast-1.2/pkg/RobAStBase/inst/NEWS Log: [ROptEst] branch 1.2 + slot function modifyIC of the different IC classes gains an argument withMakeIC to be able to adjust this to a higher granularity Modified: branches/robast-1.2/pkg/ROptEst/R/getModifyIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getModifyIC.R 2018-08-06 18:30:48 UTC (rev 1105) +++ branches/robast-1.2/pkg/ROptEst/R/getModifyIC.R 2018-08-06 18:37:21 UTC (rev 1106) @@ -10,11 +10,14 @@ dots <- mcl[["..."]] dots$verbose <- NULL dots$warn <- FALSE - modIC <- function(L2Fam, IC){} + modIC <- function(L2Fam, IC, withMakeIC){} body(modIC) <- substitute({ verbose <- getRobAStBaseOption("all.verbose") infMod <- InfRobModel(L2Fam, nghb) - do.call(optIC, args = c(list(infMod, risk=R), - dots0)) }, + IC.0 <- do.call(optIC, args = c(list(infMod, risk=R), + dots0)) + if(withMakeIC) IC.0 <- makeIC(IC.0, L2Fam) + return(IC.0) + }, list(nghb = neighbor, R = risk, dots0 = eval(dots, envir=parent.frame(2)))) return(modIC) @@ -23,7 +26,7 @@ setMethod("getModifyIC", signature(L2FamIC = "L2LocationFamily", neighbor = "UncondNeighborhood", risk = "asGRisk"), function(L2FamIC, neighbor, risk, ...){ - modIC <- function(L2Fam, IC){ + modIC <- function(L2Fam, IC, withMakeIC){ D <- distribution(eval(CallL2Fam(IC))) if(is(L2Fam, "L2LocationFamily") && is(distribution(L2Fam), class(D))){ CallL2Fam(IC) <- fam.call(L2Fam) @@ -111,7 +114,7 @@ function(L2FamIC, neighbor, risk, ..., modifyICwarn = NULL){ if(missing(modifyICwarn)|| is.null(modifyICwarn)) modifyICwarn <- getRobAStBaseOption("modifyICwarn") - modIC <- function(L2Fam, IC){ + modIC <- function(L2Fam, IC, withMakeIC){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), class(distribution(ICL2Fam)))){ res <- scaleUpdateIC(sdneu = main(L2Fam), @@ -136,7 +139,7 @@ if(missing(modifyICwarn)|| is.null(modifyICwarn)) modifyICwarn <- getRobAStBaseOption("modifyICwarn") - modIC <- function(L2Fam, IC){ + modIC <- function(L2Fam, IC, withMakeIC){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2LocationScaleFamily") && is(distribution(L2Fam), class(distribution(ICL2Fam)))){ Modified: branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R 2018-08-06 18:30:48 UTC (rev 1105) +++ branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R 2018-08-06 18:37:21 UTC (rev 1106) @@ -25,20 +25,17 @@ if(length(nsng)){ if(gridn %in% nsng){ LMref <- famg[[gridn]] - .modifyIC0 <- function(L2Fam, IC){ + .modifyIC0 <- function(L2Fam, IC, withMakeIC){ para <- param(L2Fam) return(intfct(para, LMref, L2Fam, type(risk))) } - attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE - .modifyIC <- function(L2Fam,IC){ - psi.0 <- .modifyIC0(L2Fam,IC) - psi.0 at modifyIC <- .modifyIC + .modifyIC <- function(L2Fam,IC, withMakeIC){ + psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC) + psi.0 at modifyIC <- .modifyIC0 return(psi.0) } - attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE - IC0 <- intfct(param1, LMref, model, type(risk)) IC0 at modifyIC <- .modifyIC return(IC0) Modified: branches/robast-1.2/pkg/ROptEst/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-06 18:30:48 UTC (rev 1105) +++ branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-06 18:37:21 UTC (rev 1106) @@ -8,6 +8,26 @@ information) ####################################### +version 1.2 +####################################### + +user-visible CHANGES: ++ slot function modifyIC of the different IC classes gains + an argument withMakeIC to be able to adjust this to a + higher granularity ++ require more recent versions in DESCRIPTION + +under the hood + ++ L2LocationFamily, L2LocationScaleFamily, and L2LocationScaleFamily gain methods for interpolRisk + ~> speed up is prepared (only need to store the reference LMs in sysdata.rda) + => due to affine equivariance, we only have to store one set of LM's ++ comparePlot has a try catch now for MBRE ++ some buglets in getStartIC ++ some tedious debugging in getStartIClcsc.R ++ clarified if clauses in roptest.new (and removed .with.checkEstClassForParamFamily from dots to be sure) + +####################################### version 1.1 ####################################### Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-06 18:30:48 UTC (rev 1105) +++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-06 18:37:21 UTC (rev 1106) @@ -20,6 +20,7 @@ + new S4 (estimator) class "MCALEstimate" containing both "MCEstimate" and "ALEstimate" to make accessible pIC-methods to CvMMDEstimators... ++ some unnecessary coercions (with informatino loss) in show methods + new .checkEstClassForParamFamily method to force (expost) casting to MCALEstimate (with pIC) + to speed up things slot pIC is filled with a promise only From noreply at r-forge.r-project.org Mon Aug 6 20:39:39 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 20:39:39 +0200 (CEST) Subject: [Robast-commits] r1107 - in branches/robast-1.2/pkg/RobExtremes: . R inst man Message-ID: <20180806183939.DD62C18A167@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 20:39:39 +0200 (Mon, 06 Aug 2018) New Revision: 1107 Modified: branches/robast-1.2/pkg/RobExtremes/DESCRIPTION branches/robast-1.2/pkg/RobExtremes/NAMESPACE branches/robast-1.2/pkg/RobExtremes/R/AllClass.R branches/robast-1.2/pkg/RobExtremes/R/AllShow.R branches/robast-1.2/pkg/RobExtremes/R/Expectation.R branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R branches/robast-1.2/pkg/RobExtremes/inst/NEWS branches/robast-1.2/pkg/RobExtremes/man/E.Rd branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd Log: [RobExtremes] branch 1.2 under the hood + moved quantile integration methods for expectation for Weibull and Gamma distribution to pkg distrEx (>= 2.8.0) + made a helper function .qtlIntegrate out of existing code in RobExtremes 1.1.0 and moved it to distrEx where it is exported from version 2.8.0; it is reused in RobExtremes for the GEV methods + adopted new MCALEestimate return type for extreme value distributions (and further coercion methods...) + slot function modifyIC of the different IC classes gains an argument withMakeIC to be able to adjust this to a higher granularity (and to gain speed again) Modified: branches/robast-1.2/pkg/RobExtremes/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobExtremes/DESCRIPTION 2018-08-06 18:37:21 UTC (rev 1106) +++ branches/robast-1.2/pkg/RobExtremes/DESCRIPTION 2018-08-06 18:39:39 UTC (rev 1107) @@ -5,9 +5,9 @@ Description: Optimally robust estimation for extreme value distributions using S4 classes and methods (based on packages 'distr', 'distrEx', 'distrMod', 'RobAStBase', and 'ROptEst'). -Depends: R (>= 2.14.0), methods, distrMod(>= 2.7.0), ROptEst(>= 1.1.0), robustbase, evd -Suggests: RUnit (>= 0.4.26), ismev (>= 1.39) -Imports: RobAStRDA, distr, distrEx, RandVar, RobAStBase, startupmsg, actuar +Depends: R(>= 2.14.0), methods, distrMod(>= 2.8.0), ROptEst(>= 1.1.0), robustbase, evd +Suggests: RUnit(>= 0.4.26), ismev(>= 1.39) +Imports: RobAStRDA, distr, distrEx(>= 2.8.0), RandVar, RobAStBase(>= 1.2.0), startupmsg, actuar Authors at R: c(person("Nataliya", "Horbenko", role=c("aut","cph")), person("Bernhard", "Spangl", role="ctb", comment="contributed smoothed grid values of the Lagrange multipliers"), person("Sascha", "Desmettre", role="ctb", comment="contributed smoothed grid values of Modified: branches/robast-1.2/pkg/RobExtremes/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/RobExtremes/NAMESPACE 2018-08-06 18:37:21 UTC (rev 1106) +++ branches/robast-1.2/pkg/RobExtremes/NAMESPACE 2018-08-06 18:39:39 UTC (rev 1107) @@ -29,9 +29,9 @@ exportClasses("DistributionsIntegratingByQuantiles") exportClasses("ParamWithLocAndScaleAndShapeFamParameter") exportClasses("L2LocScaleShapeUnion") -exportClasses("GPDEstimate","GPDMCEstimate","GPDLDEstimate", +exportClasses("GPDEstimate","GPDMCEstimate","GPDMCALEstimate","GPDLDEstimate", "GPDkStepEstimate","GEVEstimate","GEVLDEstimate", - "GEVkStepEstimate","GEVMCEstimate", + "GEVkStepEstimate","GEVMCEstimate", "GEVMCALEstimate", "GPDORobEstimate","GEVORobEstimate") exportMethods("initialize", "show", "rescaleFunction") exportMethods("loc", "loc<-", "kMAD", "Sn", "Qn") @@ -45,7 +45,7 @@ exportMethods(".checkEstClassForParamFamily") exportMethods("locscaleshapename","locscalename","scaleshapename", "locationname","scalename","shapename","locscaleshapename<-") -exportMethods("modifyModel", "getStartIC") +exportMethods("modifyModel", "getStartIC", "coerce") exportMethods("moveL2Fam2RefParam", "moveICBackFromRefParam") exportMethods("checkIC", "makeIC") Modified: branches/robast-1.2/pkg/RobExtremes/R/AllClass.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/AllClass.R 2018-08-06 18:37:21 UTC (rev 1106) +++ branches/robast-1.2/pkg/RobExtremes/R/AllClass.R 2018-08-06 18:39:39 UTC (rev 1107) @@ -286,6 +286,7 @@ setOldClass("gpd.fit") setClass("GPDEstimate", contains="Estimate") setClass("GPDMCEstimate", contains=c("MCEstimate", "GPDEstimate")) +setClass("GPDMCALEstimate", contains=c("MCALEstimate", "GPDEstimate")) setClass("GPDLDEstimate", contains=c("LDEstimate", "GPDEstimate")) setClass("GPDkStepEstimate", contains=c("kStepEstimate", "GPDEstimate")) setClass("GPDORobEstimate", contains=c("ORobEstimate", "GPDkStepEstimate")) @@ -294,3 +295,4 @@ setClass("GEVkStepEstimate", contains=c("kStepEstimate", "GEVEstimate")) setClass("GEVORobEstimate", contains=c("ORobEstimate", "GEVkStepEstimate")) setClass("GEVMCEstimate", contains=c("MCEstimate", "GEVEstimate")) +setClass("GEVMCALEstimate", contains=c("MCALEstimate", "GEVEstimate")) Modified: branches/robast-1.2/pkg/RobExtremes/R/AllShow.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/AllShow.R 2018-08-06 18:37:21 UTC (rev 1106) +++ branches/robast-1.2/pkg/RobExtremes/R/AllShow.R 2018-08-06 18:39:39 UTC (rev 1107) @@ -2,7 +2,7 @@ setMethod("show", "LDEstimate", function(object){ digits <- getOption("digits") - show(as(object,"Estimate")) + getMethod("show","Estimate")(object) if(getdistrModOption("show.details")!="minimal"){ cat("Location:", object at location, "\n") cat("Dispersion:", object at dispersion, "\n") Modified: branches/robast-1.2/pkg/RobExtremes/R/Expectation.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/Expectation.R 2018-08-06 18:37:21 UTC (rev 1106) +++ branches/robast-1.2/pkg/RobExtremes/R/Expectation.R 2018-08-06 18:39:39 UTC (rev 1107) @@ -1,4 +1,9 @@ +## copied form distrEx from distrEx 2.8.0 and branch 1.2.0 on +## .qtlIntegrate is moved from RobExtremes (slightly modified) to distrEx +# as of versions distrEx 2.8.0 and RobExtremes 1.2.0 + + setMethod("E", signature(object = "Pareto", fun = "missing", cond = "missing"), @@ -52,56 +57,11 @@ upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ... ){ - - dots <- list(...) - dots.withoutUseApply <- dots - useApply <- TRUE - if(!is.null(dots$useApply)) useApply <- dots$useApply - - dots.withoutUseApply$useApply <- NULL - dots.withoutUseApply$stop.on.error <- NULL - - integrand <- function(x, dfun, ...){ di <- dim(x) - y <- q.l(object)(x)##quantile transformation - if(useApply){ - funy <- sapply(y,fun, ...) - dim(y) <- di - dim(funy) <- di - }else funy <- fun(y,...) - return(funy) } - - if(is.null(low)) low <- -Inf - if(is.null(upp)) upp <- Inf - - Ib <- .getIntbounds(object, low, upp, lowerTruncQuantile, - upperTruncQuantile, IQR.fac) - low <- p(object)(Ib["low"]) - upp <- p(object)(Ib["upp"]) - if(is.nan(low)) low <- 0 - if(is.nan(upp)) upp <- 1 - - if(upp < 0.98){ - int <- do.call(distrExIntegrate, c(list(f = integrand, - lower = low, - upper = upp, - rel.tol = rel.tol, stop.on.error = FALSE, - distr = object, dfun = dunif), dots.withoutUseApply)) - }else{ - int1 <- do.call(distrExIntegrate, c(list(f = integrand, - lower = low, - upper = 0.98, - rel.tol = rel.tol, stop.on.error = FALSE, - distr = object, dfun = dunif), dots.withoutUseApply)) - int2 <- do.call(distrExIntegrate, c(list(f = integrand, - lower = 0.98, - upper = upp, - rel.tol = rel.tol, stop.on.error = FALSE, - distr = object, dfun = dunif), dots.withoutUseApply)) - int <- int1+int2 - } - - return(int) - + .qtlIntegrate(object = object, fun = fun, low = low, upp = upp, + rel.tol= rel.tol, lowerTruncQuantile = lowerTruncQuantile, + upperTruncQuantile = upperTruncQuantile, + IQR.fac = IQR.fac, ..., + .withLeftTail = FALSE, .withRightTail = TRUE) }) setMethod("E", signature(object = "GPareto", @@ -165,12 +125,15 @@ signature(object = "DistributionsIntegratingByQuantiles", fun = "function", cond = "missing"))) -setMethod("E", signature(object = "Weibull", fun = "function", cond = "missing"), - getMethod("E", - signature(object = "DistributionsIntegratingByQuantiles", - fun = "function", cond = "missing"))) +## these routines are moved back to package distrEx from distrEx 2.8.0 / RobExtremes 1.2.0 on -setMethod("E", signature(object = "Gammad", fun = "function", cond = "missing"), - getMethod("E", - signature(object = "DistributionsIntegratingByQuantiles", - fun = "function", cond = "missing"))) +#setMethod("E", signature(object = "Weibull", fun = "function", cond = "missing"), +# getMethod("E", +# signature(object = "DistributionsIntegratingByQuantiles", +# fun = "function", cond = "missing"))) + +#setMethod("E", signature(object = "Gammad", fun = "function", cond = "missing"), +# getMethod("E", +# signature(object = "DistributionsIntegratingByQuantiles", +# fun = "function", cond = "missing"))) +# \ No newline at end of file Modified: branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-08-06 18:37:21 UTC (rev 1106) +++ branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-08-06 18:39:39 UTC (rev 1107) @@ -12,8 +12,31 @@ function(PFam, estimator) as(estimator,"GPDORobEstimate")) setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GParetoFamily",estimator="MCEstimate"), - function(PFam, estimator) as(estimator,"GPDMCEstimate")) + function(PFam, estimator){# ret0 <- as(estimator,"GPDMCEstimate") + fromSlotNames <- slotNames(class(estimator)) + to <- new("GPDMCALEstimate") + for(item in fromSlotNames) slot(to, item) <- slot(estimator,item) + to at pIC <- substitute(getPIC(estimator0), list(estimator0=estimator)) + return(to) + }) setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GParetoFamily",estimator="MLEstimate"), + getMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GParetoFamily",estimator="MCEstimate"))) +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GParetoFamily",estimator="MDEstimate"), + getMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GParetoFamily",estimator="MCEstimate"))) +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GParetoFamily",estimator="CvMMDEstimate"), + getMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GParetoFamily",estimator="MCEstimate"))) +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GParetoFamily",estimator="MCALEstimate"), + function(PFam, estimator) as(estimator,"GPDMCALEstimate")) + + +setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamily",estimator="Estimate"), function(PFam, estimator) as(estimator,"GEVEstimate")) setMethod(".checkEstClassForParamFamily", @@ -27,8 +50,31 @@ function(PFam, estimator) as(estimator,"GEVORobEstimate")) setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamily",estimator="MCEstimate"), - function(PFam, estimator) as(estimator,"GEVMCEstimate")) + function(PFam, estimator){ #ret0 <- as(estimator,"GEVMCEstimate") + fromSlotNames <- slotNames(class(estimator)) + to <- new("GEVMCALEstimate") + for(item in fromSlotNames) slot(to, item) <- slot(estimator,item) + to at pIC <- substitute(getPIC(estimator0), list(estimator0=estimator)) + return(to) + }) setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamily",estimator="MLEstimate"), + getMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamily",estimator="MCEstimate"))) +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamily",estimator="MDEstimate"), + getMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamily",estimator="MCEstimate"))) +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamily",estimator="CvMMDEstimate"), + getMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamily",estimator="MCEstimate"))) +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamily",estimator="MCALEstimate"), + function(PFam, estimator) as(estimator,"GEVMCALEstimate")) + + +setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamilyMuUnknown",estimator="Estimate"), function(PFam, estimator) as(estimator,"GEVEstimate")) setMethod(".checkEstClassForParamFamily", @@ -42,4 +88,25 @@ function(PFam, estimator) as(estimator,"GEVORobEstimate")) setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCEstimate"), - function(PFam, estimator) as(estimator,"GEVMCEstimate")) + function(PFam, estimator){ #ret0 <- as(estimator,"GEVMCEstimate") + fromSlotNames <- slotNames(class(estimator)) + to <- new("GEVMCALEstimate") + for(item in fromSlotNames) slot(to, item) <- slot(estimator,item) + to at pIC <- substitute(getPIC(estimator0), list(estimator0=estimator)) + return(to) + }) +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamilyMuUnknown",estimator="MLEstimate"), + getMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCEstimate"))) +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamilyMuUnknown",estimator="MDEstimate"), + getMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCEstimate"))) +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamilyMuUnknown",estimator="CvMMDEstimate"), + getMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCEstimate"))) +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCALEstimate"), + function(PFam, estimator) as(estimator,"GEVMCALEstimate")) Modified: branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R 2018-08-06 18:37:21 UTC (rev 1106) +++ branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R 2018-08-06 18:39:39 UTC (rev 1107) @@ -26,38 +26,22 @@ if(length(nsng)){ if(gridn %in% nsng){ interpolfct <- famg[[gridn]][[.versionSuff("fun")]] - if(withMakeIC){ - .modifyIC0 <- function(L2Fam, IC){ + .modifyIC0 <- function(L2Fam, IC, withMakeIC){ para <- param(L2Fam) if(!.is.na.Psi(para, interpolfct, shnam)) return(.getPsi(para, interpolfct, L2Fam, type(risk), withMakeIC)) else{ IC0 <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2)) - IC0 <- makeIC(IC0, L2Fam) + if(withMakeIC) IC0 <- makeIC(IC0, L2Fam) return(IC0) } - } - }else{ - .modifyIC0 <- function(L2Fam, IC){ - para <- param(L2Fam) - if(!.is.na.Psi(para, interpolfct, shnam)) - return(.getPsi(para, interpolfct, L2Fam, type(risk), withMakeIC)) - else{ - IC0 <- do.call(getStartIC, as.list(mc[-1]), - envir=parent.frame(2)) - return(IC0) - } - } } - if(withMakeIC) attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE - - .modifyIC <- function(L2Fam,IC){ - psi.0 <- .modifyIC0(L2Fam,IC) - psi.0 at modifyIC <- .modifyIC + .modifyIC <- function(L2Fam,IC, withMakeIC){ + psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC) + psi.0 at modifyIC <- .modifyIC0 return(psi.0) } - if(withMakeIC) attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE if(!.is.na.Psi(param1, interpolfct, shnam)){ IC0 <- .getPsi(param1, interpolfct, model, type(risk), withMakeIC) Modified: branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R 2018-08-06 18:37:21 UTC (rev 1106) +++ branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R 2018-08-06 18:39:39 UTC (rev 1107) @@ -3,14 +3,14 @@ param1 <- param(model) xi <- main(param1) - .modifyIC0 <- function(L2Fam, IC){ + .modifyIC0 <- function(L2Fam, IC, withMakeIC){ xi0 <- main(param(L2Fam)) return(.getPsi.P(xi0, L2Fam, type(risk), withMakeIC)) } attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE - .modifyIC <- function(L2Fam,IC){ - psi.0 <- .modifyIC0(L2Fam,IC) - psi.0 at modifyIC <- .modifyIC + .modifyIC <- function(L2Fam,IC, withMakeIC){ + psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC) + psi.0 at modifyIC <- .modifyIC0 return(psi.0) } attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE Modified: branches/robast-1.2/pkg/RobExtremes/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobExtremes/inst/NEWS 2018-08-06 18:37:21 UTC (rev 1106) +++ branches/robast-1.2/pkg/RobExtremes/inst/NEWS 2018-08-06 18:39:39 UTC (rev 1107) @@ -8,6 +8,17 @@ information) ####################################### +version 1.2 +####################################### + +under the hood ++ moved quantile integration methods for expectation for Weibull and + Gamma distribution to pkg distrEx (>= 2.8.0) ++ made a helper function .qtlIntegrate out of existing code in + RobExtremes 1.1.0 and moved it to distrEx where it is exported + from version 2.8.0; it is reused in RobExtremes for the GEV methods + +####################################### version 1.1 ####################################### Modified: branches/robast-1.2/pkg/RobExtremes/man/E.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/E.Rd 2018-08-06 18:37:21 UTC (rev 1106) +++ branches/robast-1.2/pkg/RobExtremes/man/E.Rd 2018-08-06 18:39:39 UTC (rev 1107) @@ -7,10 +7,10 @@ \alias{E,GPareto,missing,missing-method} \alias{E,GPareto,function,missing-method} \alias{E,GEV,function,missing-method} -\alias{E,Weibull,function,missing-method} +%\alias{E,Weibull,function,missing-method} % moved to distrEx \alias{E,GEV,missing,missing-method} \alias{E,Pareto,missing,missing-method} -\alias{E,Gammad,function,missing-method} +%\alias{E,Gammad,function,missing-method} % moved to distrEx \alias{E,Pareto,function,missing-method} \title{Generic Function for the Computation of (Conditional) Expectations} @@ -84,7 +84,7 @@ \item{object = "Pareto", fun = "missing", cond = "missing":}{ exact evaluation using explicit expressions.} }} -\author{Matthias Kohl \email{Matthias.Kohl at stamats.de} and Peter Ruckdeschel \email{peter.ruckdeschel at uni-bayreuth.de}} +\author{Matthias Kohl \email{Matthias.Kohl at stamats.de} and Peter Ruckdeschel \email{peter.ruckdeschel at uni-oldenburg.de}} \seealso{\code{\link{distrExIntegrate}}, \code{\link{m1df}}, \code{\link{m2df}}, \code{\link[distr]{Distribution-class}}} \examples{ Modified: branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd 2018-08-06 18:37:21 UTC (rev 1106) +++ branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd 2018-08-06 18:39:39 UTC (rev 1107) @@ -7,16 +7,28 @@ \alias{.checkEstClassForParamFamily,GParetoFamily,MCEstimate-method} \alias{.checkEstClassForParamFamily,GParetoFamily,kStepEstimate-method} \alias{.checkEstClassForParamFamily,GParetoFamily,ORobEstimate-method} +\alias{.checkEstClassForParamFamily,GParetoFamily,MCALEstimate-method} +\alias{.checkEstClassForParamFamily,GParetoFamily,MLEstimate-method} +\alias{.checkEstClassForParamFamily,GParetoFamily,MDEstimate-method} +\alias{.checkEstClassForParamFamily,GParetoFamily,CvMMDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,Estimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,MCEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,LDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,kStepEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,ORobEstimate-method} +\alias{.checkEstClassForParamFamily,GEVFamily,MCALEstimate-method} +\alias{.checkEstClassForParamFamily,GEVFamily,MLEstimate-method} +\alias{.checkEstClassForParamFamily,GEVFamily,MDEstimate-method} +\alias{.checkEstClassForParamFamily,GEVFamily,CvMMDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,Estimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,MCEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,LDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,kStepEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,ORobEstimate-method} +\alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,MCALEstimate-method} +\alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,MLEstimate-method} +\alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,MDEstimate-method} +\alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,CvMMDEstimate-method} \title{ Methods for Function .checkEstClassForParamFamily in Package `RobExtremes' } \description{.checkEstClassForParamFamily-methods} %\usage{.checkEstClassForParamFamily(PFam, estimator) @@ -48,7 +60,7 @@ the \code{GParetoFamily,LDEstimate}-method cast to S4 class \code{GPDLDEstimate},\cr the \code{GParetoFamily,MCEstimate}-method cast to -S4 class \code{GPDMCEstimate},\cr +S4 class \code{GPDMCALEstimate},\cr the \code{GParetoFamily,kStepEstimate}-method cast to S4 class \code{GPDkStepstimate},\cr the \code{GEVFamily,Estimate}-method cast to @@ -56,7 +68,7 @@ the \code{GEVFamily,LDEstimate}-method cast to S4 class \code{GEVLDEstimate},\cr the \code{GEVFamily,MCEstimate}-method cast to -S4 class \code{GEVMCEstimate},\cr +S4 class \code{GEVMCALEstimate},\cr the \code{GEVFamily,kStepEstimate}-method cast to S4 class \code{GEVkStepstimate},\cr the \code{GEVFamilyMuUnknown,Estimate}-method cast to @@ -64,7 +76,7 @@ the \code{GEVFamilyMuUnknown,LDEstimate}-method cast to S4 class \code{GEVLDEstimate},\cr the \code{GEVFamilyMuUnknown,MCEstimate}-method cast to -S4 class \code{GEVMCEstimate},\cr +S4 class \code{GEVMCALEstimate},\cr the \code{GEVFamilyMuUnknown,kStepEstimate}-method cast to S4 class \code{GEVkStepstimate}.\cr } Modified: branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd 2018-08-06 18:37:21 UTC (rev 1106) +++ branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd 2018-08-06 18:39:39 UTC (rev 1107) @@ -5,6 +5,8 @@ \alias{GEVEstimate-class} \alias{GPDMCEstimate-class} \alias{GEVMCEstimate-class} +\alias{GPDMCALEstimate-class} +\alias{GEVMCALEstimate-class} \alias{GPDLDEstimate-class} \alias{GEVLDEstimate-class} \alias{GPDkStepEstimate-class} @@ -19,6 +21,7 @@ \section{Described classes}{ The S4 classes described here are \code{GPDEstimate}, \code{GEVEstimate}, \code{GPDMCEstimate}, \code{GEVMCEstimate}, + \code{GPDMCALEstimate}, \code{GEVMCALEstimate}, \code{GPDLDEstimate}, \code{GEVLDEstimate}, \code{GPDkStepEstimate}, \code{GEVkStepEstimate} \code{GPDORobEstimate}, \code{GEVORobEstimate}.} @@ -36,6 +39,10 @@ \code{MCEstimate}, directly.\cr Class \code{GEVMCEstimate} extends classes \code{GEVEstimate}, \code{MCEstimate}, directly.\cr +Class \code{GPDMCALEstimate} extends classes \code{GPDEstimate}, +\code{MCALEstimate}, directly.\cr +Class \code{GEVMCALEstimate} extends classes \code{GEVEstimate}, +\code{MCALEstimate}, directly.\cr Class \code{GPDLDEstimate} extends classes \code{GPDEstimate}, \code{LDEstimate}, directly.\cr Class \code{GEVLDEstimate} extends classes \code{GEVEstimate}, From noreply at r-forge.r-project.org Mon Aug 6 22:51:33 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 22:51:33 +0200 (CEST) Subject: [Robast-commits] r1108 - in branches/robast-1.2/pkg: ROptEst/R RobAStBase/R RobExtremes/R Message-ID: <20180806205133.E358418A73C@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 22:51:33 +0200 (Mon, 06 Aug 2018) New Revision: 1108 Modified: branches/robast-1.2/pkg/ROptEst/R/getModifyIC.R branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R branches/robast-1.2/pkg/RobAStBase/R/IC.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R branches/robast-1.2/pkg/RobExtremes/R/gevgpddiag.R Log: [RobAStBase,ROptEst,RobExtremes] branch 2.8 some bug fixes and defaults in withMakeIC to FALSE Modified: branches/robast-1.2/pkg/ROptEst/R/getModifyIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getModifyIC.R 2018-08-06 18:39:39 UTC (rev 1107) +++ branches/robast-1.2/pkg/ROptEst/R/getModifyIC.R 2018-08-06 20:51:33 UTC (rev 1108) @@ -10,7 +10,7 @@ dots <- mcl[["..."]] dots$verbose <- NULL dots$warn <- FALSE - modIC <- function(L2Fam, IC, withMakeIC){} + modIC <- function(L2Fam, IC, withMakeIC = FALSE){} body(modIC) <- substitute({ verbose <- getRobAStBaseOption("all.verbose") infMod <- InfRobModel(L2Fam, nghb) IC.0 <- do.call(optIC, args = c(list(infMod, risk=R), @@ -26,7 +26,7 @@ setMethod("getModifyIC", signature(L2FamIC = "L2LocationFamily", neighbor = "UncondNeighborhood", risk = "asGRisk"), function(L2FamIC, neighbor, risk, ...){ - modIC <- function(L2Fam, IC, withMakeIC){ + modIC <- function(L2Fam, IC, withMakeIC = FALSE){ D <- distribution(eval(CallL2Fam(IC))) if(is(L2Fam, "L2LocationFamily") && is(distribution(L2Fam), class(D))){ CallL2Fam(IC) <- fam.call(L2Fam) @@ -114,7 +114,7 @@ function(L2FamIC, neighbor, risk, ..., modifyICwarn = NULL){ if(missing(modifyICwarn)|| is.null(modifyICwarn)) modifyICwarn <- getRobAStBaseOption("modifyICwarn") - modIC <- function(L2Fam, IC, withMakeIC){ + modIC <- function(L2Fam, IC, withMakeIC = FALSE){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), class(distribution(ICL2Fam)))){ res <- scaleUpdateIC(sdneu = main(L2Fam), @@ -139,7 +139,7 @@ if(missing(modifyICwarn)|| is.null(modifyICwarn)) modifyICwarn <- getRobAStBaseOption("modifyICwarn") - modIC <- function(L2Fam, IC, withMakeIC){ + modIC <- function(L2Fam, IC, withMakeIC = FALSE){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2LocationScaleFamily") && is(distribution(L2Fam), class(distribution(ICL2Fam)))){ Modified: branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R 2018-08-06 18:39:39 UTC (rev 1107) +++ branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R 2018-08-06 20:51:33 UTC (rev 1108) @@ -25,14 +25,14 @@ if(length(nsng)){ if(gridn %in% nsng){ LMref <- famg[[gridn]] - .modifyIC0 <- function(L2Fam, IC, withMakeIC){ + .modifyIC0 <- function(L2Fam, IC, withMakeIC = FALSE){ para <- param(L2Fam) return(intfct(para, LMref, L2Fam, type(risk))) } - .modifyIC <- function(L2Fam,IC, withMakeIC){ - psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC) - psi.0 at modifyIC <- .modifyIC0 + .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE){ + psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC = withMakeIC) + psi.0 at modifyIC <- .modifyIC return(psi.0) } Modified: branches/robast-1.2/pkg/RobAStBase/R/IC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-06 18:39:39 UTC (rev 1107) +++ branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-06 20:51:33 UTC (rev 1108) @@ -149,7 +149,7 @@ if(!is.function(IC at modifyIC)) - IC at modifyIC <- function(L2Fam, IC, withMakeIC) return(makeIC(IC,L2Fam)) + IC at modifyIC <- function(L2Fam, IC, withMakeIC = FALSE) return(makeIC(IC,L2Fam)) # modifyIC <- ..modifnew # }else{ # .modifyIC <- IC at modifyIC Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-06 18:39:39 UTC (rev 1107) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-06 20:51:33 UTC (rev 1108) @@ -132,8 +132,7 @@ ### update - function updateStep <- function(u.theta, theta, IC, L2Fam, Param, withPreModif = FALSE, - withPostModif = TRUE, with.u.var = FALSE, - oldmodifIC = NULL + withPostModif = TRUE, with.u.var = FALSE ){ if(withPreModif){ @@ -146,7 +145,7 @@ .withL2derivDistr = L2Fam at .withEvalL2derivDistr) # print(L2Fam) IC <- modifyIC(IC)(L2Fam, IC, withMakeIC = FALSE) - if(steps==1L &&withMakeIC){ + if(steps==1L && withMakeIC){ IC <- makeIC(IC, L2Fam) # IC at modifyIC <- oldmodifIC } @@ -272,14 +271,13 @@ rownames(uksteps) <- u.est.names if(!is(modifyIC(IC), "NULL") ){ for(i in 1:steps){ - modif.old <- modifyIC(IC) +# modif.old <- modifyIC(IC) if(i>1){ IC <- upd$IC L2Fam <- upd$L2Fam - if((i==steps)&&withMakeIC){ - IC <- makeIC(IC,L2Fam) + if((i==steps)&&withMakeIC) IC <- makeIC(IC,L2Fam) # IC at modifyIC <- modif.old - } + Param <- upd$Param tf <- trafo(L2Fam, Param) withPre <- FALSE @@ -287,7 +285,7 @@ upd <- updateStep(u.theta,theta,IC, L2Fam, Param, withPreModif = withPre, withPostModif = (steps>i) | useLast, - with.u.var = i==steps, oldmodifIC = modif.old) + with.u.var = (i==steps), oldmodifIC = modif.old) uksteps[,i] <- u.theta <- upd$u.theta # print(str(upd$theta)) # print(nrow(ksteps)) Modified: branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R 2018-08-06 18:39:39 UTC (rev 1107) +++ branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R 2018-08-06 20:51:33 UTC (rev 1108) @@ -26,10 +26,11 @@ if(length(nsng)){ if(gridn %in% nsng){ interpolfct <- famg[[gridn]][[.versionSuff("fun")]] - .modifyIC0 <- function(L2Fam, IC, withMakeIC){ + .modifyIC0 <- function(L2Fam, IC, withMakeIC = FALSE){ para <- param(L2Fam) if(!.is.na.Psi(para, interpolfct, shnam)) - return(.getPsi(para, interpolfct, L2Fam, type(risk), withMakeIC)) + return(.getPsi(para, interpolfct, L2Fam, type(risk), + withMakeIC = withMakeIC)) else{ IC0 <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2)) @@ -37,14 +38,14 @@ return(IC0) } } - .modifyIC <- function(L2Fam,IC, withMakeIC){ - psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC) - psi.0 at modifyIC <- .modifyIC0 + .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE){ + psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC = withMakeIC) + psi.0 at modifyIC <- .modifyIC return(psi.0) } if(!.is.na.Psi(param1, interpolfct, shnam)){ - IC0 <- .getPsi(param1, interpolfct, model, type(risk), withMakeIC) + IC0 <- .getPsi(param1, interpolfct, model, type(risk), withMakeIC = withMakeIC) IC0 at modifyIC <- .modifyIC return(IC0) } @@ -63,7 +64,6 @@ mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias() mc$neighbor <- ContNeighborhood(radius=0.5) - gridn <- gsub("\\.","",type(risk)) nam <- paste(".",gsub("[F,f]amily","",gsub(" ","",name(model))),sep="") @@ -80,40 +80,27 @@ if(length(nsng)){ if(gridn %in% nsng){ interpolfct <- famg[[gridn]][[.versionSuff("fun")]] - if(withMakeIC){ - .modifyIC0 <- function(L2Fam, IC){ + .modifyIC0 <- function(L2Fam, IC, withMakeIC = FALSE){ para <- param(L2Fam) if(!.is.na.Psi(para, interpolfct, shnam)) - return(.getPsi.wL(para, interpolfct, L2Fam, type(risk), withMakeIC)) + return(.getPsi.wL(para, interpolfct, L2Fam, type(risk), + withMakeIC = withMakeIC)) else{ IC0 <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2)) - IC0 <- makeIC(IC0, L2Fam) + if(withMakeIC) IC0 <- makeIC(IC0, L2Fam) return(IC0) } - } - }else{ - .modifyIC0 <- function(L2Fam, IC){ - para <- param(L2Fam) - if(!.is.na.Psi(para, interpolfct, shnam)) - return(.getPsi.wL(para, interpolfct, L2Fam, type(risk), withMakeIC)) - else{ - IC0 <- do.call(getStartIC, as.list(mc[-1]), - envir=parent.frame(2)) - return(IC0) - } - } } - if(withMakeIC) attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE - .modifyIC <- function(L2Fam,IC){ - psi.0 <- .modifyIC0(L2Fam,IC) + .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE){ + psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC = withMakeIC) psi.0 at modifyIC <- .modifyIC return(psi.0) } - if(withMakeIC) attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE if(!.is.na.Psi(param1, interpolfct, shnam)){ - IC0 <- .getPsi.wL(param1, interpolfct, model, type(risk), withMakeIC) + IC0 <- .getPsi.wL(param1, interpolfct, model, type(risk), + withMakeIC = withMakeIC) IC0 at modifyIC <- .modifyIC return(IC0) } Modified: branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R 2018-08-06 18:39:39 UTC (rev 1107) +++ branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R 2018-08-06 20:51:33 UTC (rev 1108) @@ -3,18 +3,16 @@ param1 <- param(model) xi <- main(param1) - .modifyIC0 <- function(L2Fam, IC, withMakeIC){ + .modifyIC0 <- function(L2Fam, IC, withMakeIC = FALSE){ xi0 <- main(param(L2Fam)) - return(.getPsi.P(xi0, L2Fam, type(risk), withMakeIC)) + return(.getPsi.P(xi0, L2Fam, type(risk), withMakeIC = withMakeIC)) } - attr(.modifyIC0,"hasMakeICin.modifyIC") <- TRUE - .modifyIC <- function(L2Fam,IC, withMakeIC){ - psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC) - psi.0 at modifyIC <- .modifyIC0 + .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE){ + psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC = withMakeIC) + psi.0 at modifyIC <- .modifyIC return(psi.0) } - attr(.modifyIC,"hasMakeICin.modifyIC") <- TRUE - IC0 <- .getPsi.P(xi, model, type(risk), withMakeIC) + IC0 <- .getPsi.P(xi, model, type(risk), withMakeIC = withMakeIC) IC0 at modifyIC <- .modifyIC return(IC0) }) Modified: branches/robast-1.2/pkg/RobExtremes/R/gevgpddiag.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/gevgpddiag.R 2018-08-06 18:39:39 UTC (rev 1107) +++ branches/robast-1.2/pkg/RobExtremes/R/gevgpddiag.R 2018-08-06 20:51:33 UTC (rev 1108) @@ -74,7 +74,7 @@ es.call <- z at estimate.call nm.call <- names(es.call) if("pIC" %in% names(getSlots(class(z)))){ - PFam0 <- eval(z at pIC@CallL2Fam) + PFam0 <- eval(pIC(z)@CallL2Fam) }else{ PFam <- NULL if("ParamFamily" %in% nm.call) From noreply at r-forge.r-project.org Wed Aug 8 01:53:41 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 8 Aug 2018 01:53:41 +0200 (CEST) Subject: [Robast-commits] r1109 - in branches/robast-1.2/pkg/RandVar: . R inst Message-ID: <20180807235341.B8F8C18A79C@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-08 01:53:41 +0200 (Wed, 08 Aug 2018) New Revision: 1109 Modified: branches/robast-1.2/pkg/RandVar/DESCRIPTION branches/robast-1.2/pkg/RandVar/R/EuclRandVariable.R branches/robast-1.2/pkg/RandVar/inst/NEWS Log: [RandVar] branch 1.2 + for consistency to the univariate methods, the liesInSupport() method for DiscreteMVDistribution is called with an extra argument checkFin, which is not yet used. + require more recent distr/distrEx versions Modified: branches/robast-1.2/pkg/RandVar/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RandVar/DESCRIPTION 2018-08-06 20:51:33 UTC (rev 1108) +++ branches/robast-1.2/pkg/RandVar/DESCRIPTION 2018-08-07 23:53:41 UTC (rev 1109) @@ -3,7 +3,7 @@ Date: 2018-08-03 Title: Implementation of Random Variables Description: Implements random variables by means of S4 classes and methods. -Depends: R (>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5) +Depends: R (>= 2.14.0), methods, distr(>= 2.8.0), distrEx(>= 2.8.0) Imports: startupmsg Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", role=c("aut", Modified: branches/robast-1.2/pkg/RandVar/R/EuclRandVariable.R =================================================================== --- branches/robast-1.2/pkg/RandVar/R/EuclRandVariable.R 2018-08-06 20:51:33 UTC (rev 1108) +++ branches/robast-1.2/pkg/RandVar/R/EuclRandVariable.R 2018-08-07 23:53:41 UTC (rev 1109) @@ -197,7 +197,7 @@ nrvalues <- length(RandVar) res <- matrix(NA, nrow = nrvalues, ncol = RandVar at Range@dimension) - if(liesInSupport(distr, x)) + if(liesInSupport(distr, x, checkFin = TRUE)) for(i in 1:nrvalues) res[i,] <- RandVar at Map[[i]](x) return(res) @@ -219,7 +219,7 @@ for(i in 1:nrvalues){ fun <- RandVar at Map[[i]] for(j in 1:nrow(x)) - if(!liesInSupport(distr, x[j,])) + if(!liesInSupport(distr, x[j,], checkFin = TRUE)) next else res[i,j,] <- fun(x[j,]) @@ -282,7 +282,7 @@ d <- RandVar at Dim res <- array(NA, c(d[1], d[2], RandVar at Range@dimension)) - if(liesInSupport(distr, x)){ + if(liesInSupport(distr, x, checkFin = TRUE)){ for(i in 1:d[1]) for(j in 1:d[2]) res[i,j,] <- RandVar at Map[[(i-1)*d[2] + j]](x) @@ -308,7 +308,7 @@ for(j in 1:d[2]){ fun <- RandVar at Map[[(i-1)*d[2] + j]] for(k in 1:nrow(x)) - if(!liesInSupport(distr, x[k,])) + if(!liesInSupport(distr, x[k,], checkFin = TRUE)) next else res[i,j,k,] <- fun(x[k,]) Modified: branches/robast-1.2/pkg/RandVar/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RandVar/inst/NEWS 2018-08-06 20:51:33 UTC (rev 1108) +++ branches/robast-1.2/pkg/RandVar/inst/NEWS 2018-08-07 23:53:41 UTC (rev 1109) @@ -8,6 +8,18 @@ information) ####################################### +version 1.2 +####################################### + +user-visible CHANGES: ++ require more recent distr/distrEx versions + +under the hood: ++ for consistency to the univariate methods, the liesInSupport() method for + DiscreteMVDistribution is called with an extra argument checkFin, + which is not yet used. + +####################################### version 1.1 ####################################### From noreply at r-forge.r-project.org Wed Aug 8 23:49:35 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 8 Aug 2018 23:49:35 +0200 (CEST) Subject: [Robast-commits] r1110 - in branches/robast-1.2/pkg/RobAStBase: . R inst man Message-ID: <20180808214935.D56D91803BD@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-08 23:49:35 +0200 (Wed, 08 Aug 2018) New Revision: 1110 Added: branches/robast-1.2/pkg/RobAStBase/R/combinedICs.R Modified: branches/robast-1.2/pkg/RobAStBase/DESCRIPTION branches/robast-1.2/pkg/RobAStBase/NAMESPACE branches/robast-1.2/pkg/RobAStBase/R/AllClass.R branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R branches/robast-1.2/pkg/RobAStBase/R/ContIC.R branches/robast-1.2/pkg/RobAStBase/R/HampIC.R branches/robast-1.2/pkg/RobAStBase/R/IC.R branches/robast-1.2/pkg/RobAStBase/R/TotalVarIC.R branches/robast-1.2/pkg/RobAStBase/R/ddPlot_utils.R branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS branches/robast-1.2/pkg/RobAStBase/man/ContIC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/ContIC.Rd branches/robast-1.2/pkg/RobAStBase/man/HampIC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/IC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC.Rd branches/robast-1.2/pkg/RobAStBase/man/outlyingPlotIC.Rd Log: [RobAStBase] branch 1.2: + force optimal ICs to respect the support of the model distribution + and a forgotten no longer used instance of oldmodif in kStepEstimator + updated required package versions in DESCRIPTION + force optimal ICs to respect the support of the model distribution + in kStepEstimator got back from RandVar-evaluation to IC - evaluation background: updates should be fast (I saw examples with 60s for 3step... with fast LMs...) -> to this end: [so far things only got worse....] (a) (for internal purposes) introduce new intermediate S4 class ".fastIC" (with non-exported generator .fastIC in file combinedICs.R) which is inbetween class IC and HampIC and has a new slot ".fastFct". ".fastFct" is an optional (= can be NULL) mere function in one argument which returns the vector-valued IC; this way coordinatewise repeated checking whether x is in support of distr (and evaluation of the weight) can be avoided (b) new slot ".fastFct" is filled automatically for our Hamepl-type ICs in generators ContIC and TotalVarIC by analogue generateIC.fast.fct to generateIC.fct in file generateICfct.R. (c) class .fastIC is intermediate as we need it, too, for non-Hampel type ICs as arise when either the covariance of our opt-rob IC is singular or one works with pICs and has to reconstruct full ICs by filling the parts in the orthogonal complement of Range IC; (d) to this last issue instead of adding two random variables, as was done beforehand in kStepEstimator, one uses the new helper function combineOrthPICs in file combinedICs.R which combines (without checking orthogonality) two pICs to one full IC by adding the curves (and the fast functions). (e) in kStepEstimator, we now use evalIC.v, a (sapply-)vectorized version of evalIC; this is an exported method and has a particular method for class ".fastIC" which uses slot ".fastFct" instead of the evaluation of the pIC through evalRandVar ... (f) generateIC.fct has also been revised: it avoids using random variable Y(x)/Yi(x) and instead computes them right away from Lambda; this also has as background that checkIC/makeIC should be enhanced; ultimately, this enhancement is passed to ROptEst -- idea is to reuse infrastructure from getInfStand getInfCent which automatically does symmetry checking ... Modified: branches/robast-1.2/pkg/RobAStBase/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobAStBase/DESCRIPTION 2018-08-07 23:53:41 UTC (rev 1109) +++ branches/robast-1.2/pkg/RobAStBase/DESCRIPTION 2018-08-08 21:49:35 UTC (rev 1110) @@ -3,7 +3,7 @@ Date: 2018-08-03 Title: Robust Asymptotic Statistics Description: Base S4-classes and functions for robust asymptotic statistics. -Depends: R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.8.0), distrMod(>= 2.8.0), +Depends: R(>= 2.14.0), methods, rrcov, distr(>= 2.8.0), distrEx(>= 2.8.0), distrMod(>= 2.8.0), RandVar(>= 1.1.0) Suggests: ROptEst(>= 1.1.0), RUnit(>= 0.4.26) Imports: startupmsg, graphics, grDevices, stats Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-07 23:53:41 UTC (rev 1109) +++ branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-08 21:49:35 UTC (rev 1110) @@ -20,7 +20,7 @@ "FixRobModel", "InfRobModel") exportClasses("InfluenceCurve", - "IC", "HampIC", + "IC", "HampIC", ".fastIC", "ContIC", "TotalVarIC") exportClasses("RobAStControl", "RobWeight", "BoundedWeight", @@ -44,7 +44,7 @@ "modifyIC", "generateIC", "checkIC", - "evalIC", + "evalIC", "evalIC.v", "clip", "clip<-", "cent", "cent<-", "stand", "stand<-", Modified: branches/robast-1.2/pkg/RobAStBase/R/AllClass.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/AllClass.R 2018-08-07 23:53:41 UTC (rev 1109) +++ branches/robast-1.2/pkg/RobAStBase/R/AllClass.R 2018-08-08 21:49:35 UTC (rev 1110) @@ -127,6 +127,11 @@ return(TRUE) }) + +## internal class +setClass(".fastIC", representation(.fastFct = "OptionalFunction"), + prototype(.fastFct = NULL), contains="IC") + ## HampIC -- common mother class to ContIC and TotalVarIC setClass("HampIC", representation(stand = "matrix", @@ -134,7 +139,7 @@ neighborRadius = "numeric", weight = "RobWeight", biastype = "BiasType", - normtype = "NormType"), + normtype = "NormType"), prototype(name = "IC of total-var or contamination type", Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x}), Domain = Reals())), @@ -148,7 +153,7 @@ neighborRadius = 0, biastype = symmetricBias(), NormType = NormType()), - contains = "IC", + contains = ".fastIC", validity = function(object){ if(any(object at neighborRadius < 0)) # radius vector?! stop("'neighborRadius' has to be in [0, Inf]") Modified: branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R 2018-08-07 23:53:41 UTC (rev 1109) +++ branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R 2018-08-08 21:49:35 UTC (rev 1110) @@ -43,6 +43,9 @@ if(!isGeneric("evalIC")){ setGeneric("evalIC", function(IC, x) standardGeneric("evalIC")) } +if(!isGeneric("evalIC.v")){ + setGeneric("evalIC.v", function(IC, x) standardGeneric("evalIC.v")) +} if(!isGeneric("makeIC")){ setGeneric("makeIC", function(IC, L2Fam, ...) standardGeneric("makeIC")) } Modified: branches/robast-1.2/pkg/RobAStBase/R/ContIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/ContIC.R 2018-08-07 23:53:41 UTC (rev 1109) +++ branches/robast-1.2/pkg/RobAStBase/R/ContIC.R 2018-08-08 21:49:35 UTC (rev 1110) @@ -5,7 +5,7 @@ Risks, Infos, clip = Inf, cent = 0, stand = as.matrix(1), lowerCase = NULL, neighborRadius = 0, w = new("HampelWeight"), normtype = NormType(), biastype = symmetricBias(), - modifyIC = NULL){ + modifyIC = NULL, .fastFct = NULL){ if(missing(name)) name <- "IC of contamination type" if(missing(Risks)) @@ -42,6 +42,7 @@ contIC at biastype <- biastype contIC at normtype <- normtype contIC at modifyIC <- modifyIC + contIC at .fastFct <- .fastFct return(contIC) # return(new("ContIC", name = name, Curve = Curve, Risks = Risks, Infos = Infos, @@ -66,6 +67,7 @@ name = "IC of contamination type", CallL2Fam = L2call, Curve = generateIC.fct(neighbor, L2Fam, res), + .fastFct = generateIC.fast.fct(neighbor, L2Fam, res), clip = b, cent = a, stand = A, @@ -170,3 +172,5 @@ addInfo(object) <- c("CallL2Fam<-", "The entries in 'Risks' and 'Infos' may be wrong") object }) + + Modified: branches/robast-1.2/pkg/RobAStBase/R/HampIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/HampIC.R 2018-08-07 23:53:41 UTC (rev 1109) +++ branches/robast-1.2/pkg/RobAStBase/R/HampIC.R 2018-08-08 21:49:35 UTC (rev 1110) @@ -18,3 +18,22 @@ object }) +## evaluate IC +setMethod("evalIC.v", signature(IC = ".fastIC", x = "numeric"), + function(IC, x){ + if(is.null(IC at .fastFct)){ + res <- setMethod("evalIC.v", signature(IC = "IC", x = "numeric"))(IC,x) + ## cast to matrix ICdim x nobs + }else{ + res <- IC at .fastFct(x) + } + }) +setMethod("evalIC.v", signature(IC = ".fastIC", x = "matrix"), + function(IC, x){ + if(is.null(IC at .fastFct)){ + res <- setMethod("evalIC.v", signature(IC = "IC", x = "matrix"))(IC,x) + ## cast to matrix ICdim x nobs + }else{ + res <- IC at .fastFct(x) + } + }) Modified: branches/robast-1.2/pkg/RobAStBase/R/IC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-07 23:53:41 UTC (rev 1109) +++ branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-08 21:49:35 UTC (rev 1110) @@ -85,6 +85,8 @@ return(prec) }) + + ## evaluate IC setMethod("evalIC", signature(IC = "IC", x = "numeric"), function(IC, x){ @@ -113,7 +115,12 @@ else return(evalRandVar(Curve, x)[,,1]) }) +## evaluate IC +setMethod("evalIC.v", signature(IC = "IC", x = "numeric"), + function(IC, x) sapply(x, function(x) evalIC(IC,x)) + ) + ## make some L2function a pIC at a model setMethod("makeIC", signature(IC = "IC", L2Fam = "missing"), function(IC){ @@ -122,8 +129,8 @@ }) ## make some L2function a pIC at a model -setMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"), - function(IC, L2Fam){ +setMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"), + function(IC, L2Fam){ dims <- length(L2Fam at param) if(dimension(IC at Curve) != dims) @@ -142,40 +149,27 @@ E10 <- E(L2Fam, IC1 %*% t(L2deriv)) E1 <- matrix(E10, dims, dims) - stand <- trafo %*% solve(E1) + stand <- trafo %*% solve(E1) Y <- as(stand %*% IC1, "EuclRandVariable") - #ICfct <- vector(mode = "list", length = dims) - #ICfct[[1]] <- function(x){Y(x)} - if(!is.function(IC at modifyIC)) IC at modifyIC <- function(L2Fam, IC, withMakeIC = FALSE) return(makeIC(IC,L2Fam)) -# modifyIC <- ..modifnew -# }else{ -# .modifyIC <- IC at modifyIC -# if(!is.null(attr(IC at modifyIC,"hasMakeICin.modifyIC"))){ -# modifyIC <- .modifyIC -# }else{ -# modifyIC <- function(L2Fam, IC){ IC. <- .modifyIC(L2Fam, IC) -# return(makeIC(IC., L2Fam)) } -# } -# } -# } -# attr(modifyIC,"hasMakeICin.modifyIC") <- TRUE CallL2Fam <- L2Fam at fam.call return(IC(name = name(IC), Curve = EuclRandVarList(Y), - Risks = list(), - Infos=matrix(c("IC<-", - "generated by affine linear trafo to enforce consistency"), - ncol=2, dimnames=list(character(0), c("method", "message"))), + Risks = list(), + Infos=matrix(c("IC<-", + "generated by affine linear trafo to enforce consistency"), + ncol=2, dimnames=list(character(0), c("method", "message"))), CallL2Fam = CallL2Fam, modifyIC = IC at modifyIC)) }) + + # alias to IC needed here: .IC <- IC Modified: branches/robast-1.2/pkg/RobAStBase/R/TotalVarIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/TotalVarIC.R 2018-08-07 23:53:41 UTC (rev 1109) +++ branches/robast-1.2/pkg/RobAStBase/R/TotalVarIC.R 2018-08-08 21:49:35 UTC (rev 1110) @@ -4,7 +4,7 @@ Risks, Infos, clipLo = -Inf, clipUp = Inf, stand = as.matrix(1), lowerCase = NULL, neighborRadius = 0, w = new("BdStWeight"), normtype = NormType(), biastype = symmetricBias(), - modifyIC = NULL){ + modifyIC = NULL, .fastFct = NULL){ if(missing(name)) name <- "IC of total variation type" @@ -37,6 +37,7 @@ IC1 at biastype <- biastype IC1 at normtype <- normtype IC1 at modifyIC <- modifyIC + IC1 at .fastFct <- .fastFct return(IC1) } @@ -65,6 +66,7 @@ name = "IC of total variation type", CallL2Fam = L2call, Curve = generateIC.fct(neighbor, L2Fam, res), + .fastFct = generateIC.fast.fct(neighbor, L2Fam, res), clipUp = clipUp, clipLo = clipLo, stand = A, Added: branches/robast-1.2/pkg/RobAStBase/R/combinedICs.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/combinedICs.R (rev 0) +++ branches/robast-1.2/pkg/RobAStBase/R/combinedICs.R 2018-08-08 21:49:35 UTC (rev 1110) @@ -0,0 +1,53 @@ +combineOrthPICs <- function(pIC1, pIC2, combinedName = "combined IC", dim){ + ## adds to complementary pICs to give one IC + ## the orthogonality is not checked here + + IC <- new(".fastIC") + IC at name <- combinedName + pICC1 <- as(diag(dim)%*%pIC1 at Curve,"EuclRandVariable") + pICC2 <- as(diag(dim)%*%pIC2 at Curve,"EuclRandVariable") + IC at Curve <- EuclRandVarList(pICC1+pICC2) + IC at Risks <- pIC1 at Risks + if(length(pIC2 at Risks)) addRisk(IC) <- pIC2 at Risks + IC at Infos <- pIC1 at Infos + if(nrow(pIC2 at Infos)) addInfo(IC) <- pIC2 at Infos + IC at CallL2Fam <- pIC1 at CallL2Fam + .modifyIC.0 <- function(L2Fam, IC, withMakeIC = FALSE){ + pic1 <- pic1 at modifyIC(L2Fam, pIC1, withMakeIC) + pic2 <- pic2 at modifyIC(L2Fam, pIC2, withMakeIC) + IC1 <- combineOrthPICs(pic1, pic2,combinedName) + return(IC1) + } + .modifyIC.1 <- function(L2Fam, IC, withMakeIC = FALSE){ + IC1 <- .modifyIC.0(L2Fam, IC, withMakeIC) + IC1 at modifyIC <- .modifyIC.1 + return(IC1) + } + + IC at modifyIC <- .modifyIC.1 + IC at .fastFct <- function(x){pIC1 at .fastFct(x)+pIC2 at .fastFct(x)} + return(IC) +} + + +.fastIC <- function(name ="", Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x}), + Domain = Reals())), Risks, Infos, CallL2Fam = call("L2ParamFamily"), + modifyIC = NULL, .fastFct = NULL){ +fastIC <- new(".fastIC") +if(missing(Infos)) Infos <- fastIC at Infos +if(missing(Risks)) Risks <- fastIC at Risks +IC.0 <- IC(name, Curve, Risks, Infos, CallL2Fam, modifyIC) +slotNms <- slotNames(class(IC.0)) +for(sN in slotNms) slot(fastIC, sN) <- slot(IC.0,sN) +if(is.null(.fastFct)||missing(.fastFct)){ + ICM <- IC.0 at Curve[[1]]@Map + .fastFct <- function(x){ + if(is.null(dim(x))) + sapply(x, function(u) sapply(ICM, function(s)s(u))) + else + apply(x, 1,function(u) sapply(ICM, function(s)s(u))) + } +} +fastIC at .fastFct <- .fastFct +return(fastIC) +} Modified: branches/robast-1.2/pkg/RobAStBase/R/ddPlot_utils.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/ddPlot_utils.R 2018-08-07 23:53:41 UTC (rev 1109) +++ branches/robast-1.2/pkg/RobAStBase/R/ddPlot_utils.R 2018-08-08 21:49:35 UTC (rev 1110) @@ -266,9 +266,15 @@ ndata.y0[!isna] <- jitter(ndata.y0[!isna], factor=jitter.pts[2]) pdots$col <- col + inax <- is.na(ndata.x) + inay <- is.na(ndata.y) + + nonina <- !inax&!inay + retV <- 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) + qtx = quantile(ndata.x[nonina]), + qty = quantile(ndata.y[nonina]), + cutoff.x.v = co.x, cutoff.y.v = co.y) if(doplot){ plotInfo<- list("plotArgs"=NULL) Modified: branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R 2018-08-07 23:53:41 UTC (rev 1109) +++ branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R 2018-08-08 21:49:35 UTC (rev 1110) @@ -5,53 +5,101 @@ A <- as.matrix(res$A) a <- if(is(neighbor,"TotalVarNeighborhood")) 0 else res$a b <- res$b - d <- res$d + d <- if(!is.null(res$d)) res$d else 0 w <- weight(res$w) nrvalues <- nrow(A) dim <- ncol(A) ICfct <- vector(mode = "list", length = nrvalues) - Y <- as(A %*% L2Fam at L2deriv - a, "EuclRandVariable") L <- as(diag(dim)%*%L2Fam at L2deriv, "EuclRandVariable") + distr <- distribution(L2Fam) L.fct <- function(x) evalRandVar(L,x) if(nrvalues == 1){ - if(!is.null(d)){ + if(!is.null(res$d)){ ICfct[[1]] <- function(x){} if(all(dim(trafo(L2Fam at param)) == c(1, 1))){ body(ICfct[[1]]) <- substitute( - { ind <- 1-.eq(Y(x)) - Y(x)*w(L(x)) + zi*(1-ind)*d*b }, - list(Y = Y at Map[[1]], L = L.fct, w = w, b = b, d = d, - zi = sign(trafo(L2Fam at param)), .eq = .eq)) + { indS <- liesInSupport(Di,x,checkFin=TRUE) + Lx <- L(x) + Yx <- A %*% Lx - a + ind <- 1-.eq(Yx) + (Yx*w(Lx) + zi*(1-ind)*d*b)*indS }, + list(L = L.fct, w = w, b = b, d = d, A = A, a = a, + zi = sign(trafo(L2Fam at param)), .eq = .eq, Di = distr)) }else{ body(ICfct[[1]]) <- substitute( - { ind <- 1-.eq(Y(x)) - ifelse(ind, Y(x)*w(L(x)), NA) }, - list(Y = Y at Map[[1]], L = L.fct, w = w, b = b, d = d, - .eq = .eq)) + { indS <- liesInSupport(Di,x,checkFin=TRUE) + Lx <- L(x) + Yx <- A %*% Lx - a + ind <- 1-.eq(Yx) + ifelse(ind, Yx*w(Lx), NA)*indS }, + list(L = L.fct, w = w, b = b, d = d, A = A, a = a, + .eq = .eq, Di = distr)) } }else{ ICfct[[1]] <- function(x){} - body(ICfct[[1]]) <- substitute({ Y(x)*w(L(x)) }, - list(Y = Y at Map[[1]], L = L.fct, w = w)) + body(ICfct[[1]]) <- substitute({ indS <- liesInSupport(Di,x,checkFin=TRUE) + Lx <- L(x) + Yx <- A %*% Lx - a + Yx*w(Lx)*indS }, + list(L = L.fct, A = A, a = a, w = w, Di = distr)) } }else{ - if(!is.null(d)) + if(!is.null(res$d)) for(i in 1:nrvalues){ ICfct[[i]] <- function(x){} - body(ICfct[[i]]) <- substitute({ind <- 1-.eq(Yi(x)) - ind*Yi(x)*w(L(x)) + (1-ind)*d + body(ICfct[[i]]) <- substitute({indS <- liesInSupport(Di,x,checkFin=TRUE) + Lx <- L(x) + Yix <- Ai %*% Lx - ai + ind <- 1-.eq(Yix) + (ind*Yix*w(Lx) + (1-ind)*di)*indS }, - list(Yi = Y at Map[[i]], L = L.fct, w = w, - b = b, d = d[i]))#, .eq = .eq)) + list(L = L.fct, Ai = A[i,,drop=FALSE], ai = a[i], w = w, + di = d[i], Di = distr))#, .eq = .eq)) } else for(i in 1:nrvalues){ ICfct[[i]] <- function(x){} - body(ICfct[[i]]) <- substitute({ Yi(x)*w(L(x)) }, - list(Yi = Y at Map[[i]], L = L.fct, w = w)) + body(ICfct[[i]]) <- substitute({indS <- liesInSupport(Di,x,checkFin=TRUE) + Lx <- L(x) + Yix <- Ai %*% Lx - ai + Yix*w(Lx)*indS }, + list(L = L.fct, Ai = A[i,,drop=FALSE], ai = a[i], w = w, Di = distr)) } } - return(EuclRandVarList(EuclRandVariable(Map = ICfct, Domain = Y at Domain, - Range = Y at Range))) + return(EuclRandVarList(EuclRandVariable(Map = ICfct, Domain = L at Domain, + Range = Reals()))) # EuclideanSpace(dimension = nrvalues)))) }) +## generate fast IC fct +## for internal use only! +generateIC.fast.fct <- function(neighbor, L2Fam, res){ + A <- as.matrix(res$A) + a <- if(is(neighbor,"TotalVarNeighborhood")) 0 else res$a + b <- res$b + d <- res$d + w <- weight(res$w) + nrvalues <- nrow(A) + dims <- ncol(A) + L <- as(diag(dims)%*%L2Fam at L2deriv, "EuclRandVariable") + distr <- distribution(L2Fam) + L.fct <- function(x) evalRandVar(L,x) + fastFct <- function(x){} + if(nrvalues==1L){ + d0 <- if(dims==1L) d else NA + }else{ + d0 <- if(!is.null(d)) d else 0 + } + zi0 <- if(nrvalues==1L && dims==1L) sign(trafo(L2Fam at param)) else 1 + b0 <- if(nrvalues==1L) b else 1 + body(fastFct) <- substitute({ indS <- liesInSupport(Di,x,checkFin=TRUE) + Lx <- L(x) + Yx <- A %*% Lx - a + ind <- 1-.eq(Yx) + ifelse(ind,Yx*w(Lx), zi*d*b)*indS + }, + list(L = L.fct, w = w, b = b0, + d = d0 , A = A, a = a, zi = zi0, + .eq = .eq, Di = distr)) + return(fastFct) + } + Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-07 23:53:41 UTC (rev 1109) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-08 21:49:35 UTC (rev 1110) @@ -41,7 +41,8 @@ es.call[[1]] <- as.name("kStepEstimator") ## get some dimensions - L2Fam <- eval(CallL2Fam(IC)) + CallL2Fam <- CallL2Fam(IC) + L2Fam <- eval(CallL2Fam) Param <- param(L2Fam) tf <- trafo(L2Fam,Param) @@ -53,6 +54,8 @@ p <- nrow(Dtau) k <- ncol(Dtau) + CallL2FamK <- CallL2Fam + if(p!=k) CallL2FamK$trafo <- diag(k) lmx <- length(main(L2Fam)) lnx <- length(nuisance(L2Fam)) @@ -80,9 +83,9 @@ ### transform if necessary x0 <- x - x0 <- if(is.numeric(x) && ! is.matrix(x)) { - x0 <- as.matrix(x) - } + #x0 <- if(is.numeric(x) && ! is.matrix(x)) { + # x0 <- as.matrix(x) + # } completecases <- complete.cases(x0) if(na.rm) x0 <- na.omit(x0) @@ -91,7 +94,7 @@ ### use dispatch here (dispatch only on start) #a.var <- if( is(start, "Estimate")) asvar(start) else NULL - IC.UpdateInKer.0 <- if(is(start,"ALEstimate")) start at pIC else NULL + IC.UpdateInKer.0 <- if(is(start,"ALEstimate")) pIC(start) else NULL force(startArgList) start.val <- kStepEstimator.start(start, x=x0, nrvalues = k, na.rm = na.rm, L2Fam = L2Fam, @@ -122,10 +125,11 @@ ICList <- if(withICList) vector("list", steps) else NULL cvar.fct <- function(L2, IC, dim, dimn =NULL){ + IC.C <- as(diag(dim)%*%IC at Curve, "EuclRandVariable") if(is.null(dimn)){ - return(matrix(E(L2, IC %*% t(IC)),dim,dim)) + return(matrix(E(L2, IC.C %*% t(IC.C)),dim,dim)) }else{ - return(matrix(E(L2, IC %*% t(IC)),dim,dim, dimnames = dimn)) + return(matrix(E(L2, IC.C %*% t(IC.C)),dim,dim, dimnames = dimn)) } } @@ -137,57 +141,58 @@ if(withPreModif){ main(Param)[] <- .deleteDim(u.theta[idx]) -# print(Param) if (lnx) nuisance(Param)[] <- .deleteDim(u.theta[nuis.idx]) -# print(Param) -# print(L2Fam) L2Fam <- modifyModel(L2Fam, Param, .withL2derivDistr = L2Fam at .withEvalL2derivDistr) -# print(L2Fam) IC <- modifyIC(IC)(L2Fam, IC, withMakeIC = FALSE) - if(steps==1L && withMakeIC){ - IC <- makeIC(IC, L2Fam) -# IC at modifyIC <- oldmodifIC - } - # print(IC) + CallL2Fam <- IC at CallL2Fam + if(steps==1L && withMakeIC) IC <- makeIC(IC, L2Fam) } - IC.c <- as(diag(p) %*% IC at Curve, "EuclRandVariable") + IC.c <- .fastIC(Curve=EuclRandVarList(as(diag(p) %*% IC at Curve, "EuclRandVariable")), CallL2Fam = CallL2Fam) -# print(theta) tf <- trafo(L2Fam, Param) Dtau <- tf$mat IC.tot.0 <- NULL -# print(Dtau) if(!.isUnitMatrix(Dtau)){ - # print("HU1!") Dminus <- solve(Dtau, generalized = TRUE) projker <- diag(k) - Dminus %*% Dtau - IC.tot1 <- Dminus %*% IC.c - IC.tot2 <- 0 * IC.tot1 + IC.tot1 <- .fastIC(Curve=EuclRandVarList(as(Dminus %*% IC.c at Curve, "EuclRandVariable")), CallL2Fam = CallL2FamK) + IC.tot2.isnull <- TRUE if(sum(diag(projker))>0.5 && ### is EM-D^-D != 0 (i.e. rk D1){ IC <- upd$IC L2Fam <- upd$L2Fam if((i==steps)&&withMakeIC) IC <- makeIC(IC,L2Fam) -# IC at modifyIC <- modif.old Param <- upd$Param tf <- trafo(L2Fam, Param) @@ -285,17 +274,11 @@ upd <- updateStep(u.theta,theta,IC, L2Fam, Param, withPreModif = withPre, withPostModif = (steps>i) | useLast, - with.u.var = (i==steps), oldmodifIC = modif.old) + with.u.var = (i==steps)) uksteps[,i] <- u.theta <- upd$u.theta -# print(str(upd$theta)) -# print(nrow(ksteps)) ksteps[,i] <- theta <- upd$theta if(withICList) - ICList[[i]] <- new("InfluenceCurve", - name = paste(gettext("(total) IC in step"),i), - Risks = list(), - Infos = matrix(c("",""),ncol=2), - Curve = EuclRandVarList(upd$IC.tot)) + ICList[[i]] <- upd$IC.tot if(withPICList) pICList[[i]] <- upd$IC.c u.var <- upd$u.var @@ -336,9 +319,6 @@ "computation of IC, asvar and asbias via useLast = FALSE")) } - ## if non-trivial trafo: info on how update was done -# print(IC at Risks$asCov) -# print(Risks(IC)$asCov) if(! .isUnitMatrix(trafo(L2Fam))) Infos <- rbind(Infos, c("kStepEstimator", @@ -347,7 +327,6 @@ "modification in ker(trafo)"))) ## some risks -# print(list(u.theta=u.theta,theta=theta,u.var=u.var,var=var0)) if(var.to.be.c){ if("asCov" %in% names(Risks(IC))) if(is.matrix(Risks(IC)$asCov) || length(Risks(IC)$asCov) == 1) @@ -391,9 +370,11 @@ dimnames(asVar) <- list(nms.theta.idx, nms.theta.idx) } + samplesize <- if(is.null(dim(x0))) length(x0) else nrow(x0) + estres <- new("kStepEstimate", estimate.call = es.call, name = paste(steps, "-step estimate", sep = ""), - estimate = theta, samplesize = nrow(x0), asvar = asVar, + estimate = theta, samplesize = samplesize, asvar = asVar, trafo = tf, fixed = fixed, nuis.idx = nuis.idx, untransformed.estimate = u.theta, completecases = completecases, untransformed.asvar = u.var, asbias = asBias, pIC = IC, Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-07 23:53:41 UTC (rev 1109) +++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-08 21:49:35 UTC (rev 1110) @@ -15,7 +15,11 @@ + slot function modifyIC of the different IC classes gains [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/robast -r 1110 From noreply at r-forge.r-project.org Fri Aug 10 01:43:02 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 01:43:02 +0200 (CEST) Subject: [Robast-commits] r1111 - in branches/robast-1.2/pkg/RobAStBase: . R inst inst/chkTimeCode man Message-ID: <20180809234302.F2936180083@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 01:43:02 +0200 (Fri, 10 Aug 2018) New Revision: 1111 Added: branches/robast-1.2/pkg/RobAStBase/inst/chkTimeCode/ branches/robast-1.2/pkg/RobAStBase/inst/chkTimeCode/TimingChecks.R Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE branches/robast-1.2/pkg/RobAStBase/R/AllClass.R branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R branches/robast-1.2/pkg/RobAStBase/R/AllShow.R branches/robast-1.2/pkg/RobAStBase/R/ContIC.R branches/robast-1.2/pkg/RobAStBase/R/HampIC.R branches/robast-1.2/pkg/RobAStBase/R/IC.R branches/robast-1.2/pkg/RobAStBase/R/TotalVarIC.R branches/robast-1.2/pkg/RobAStBase/R/bALEstimate.R branches/robast-1.2/pkg/RobAStBase/R/combinedICs.R branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R branches/robast-1.2/pkg/RobAStBase/R/getPIC.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd branches/robast-1.2/pkg/RobAStBase/man/ContIC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/ContIC.Rd branches/robast-1.2/pkg/RobAStBase/man/HampIC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/IC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC.Rd branches/robast-1.2/pkg/RobAStBase/man/internals.Rd Log: [RobAStBase] branch 1.1 we are finally there... I reverted most changes from yesterday and now we have decent timings again... The clue was that to force optimal ICs to respect the support of the model distribution, during evaluation of kStepEstimator it is prohibitive to put line liesInSupport in each of the coordinate functions as this blows up the integration time for covariances; instead, we use helper .fixInLiesInSupport in file generateICfct.R which after computation of variances inserts this in the Maps of the IC + for time checking use file TimingChecks.R (with the preparation that the lines commented out by ##-t-## in kStepEstimator.R have to be activated; this uses helper function .addTime to produce a matrix with detailed timing information which can be read out as argument ) -- it is in package system folder "chkTimeCode" (in inst/chkTimeCode in r-forge) BTW: by preallocating memory for the matrix with the timings we do not gain speed unfortunately, so commenting in and out seems to be the best option Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-09 23:43:02 UTC (rev 1111) @@ -20,12 +20,13 @@ "FixRobModel", "InfRobModel") exportClasses("InfluenceCurve", - "IC", "HampIC", ".fastIC", + "IC", "HampIC", "ContIC", "TotalVarIC") -exportClasses("RobAStControl", "RobWeight", "BoundedWeight", +exportClasses("RobAStControl", "RobWeight", "BoundedWeight", "BdStWeight", "HampelWeight") -exportClasses("ALEstimate", "MCALEstimate", "kStepEstimate", "MEstimate") +exportClasses("ALEstimate", "MCALEstimate", "kStepEstimate", "MEstimate", + "CvMMD.ALEstimate", "ML.ALEstimate" ) exportClasses("cutoff") exportClasses("interpolRisk", "OMSRRisk","MBRRisk","RMXRRisk") exportClasses("StartClass", "pICList", "OptionalpICList", "OptionalCall", @@ -44,7 +45,7 @@ "modifyIC", "generateIC", "checkIC", - "evalIC", "evalIC.v", + "evalIC", "clip", "clip<-", "cent", "cent<-", "stand", "stand<-", @@ -88,3 +89,4 @@ export(".rescalefct",".plotRescaledAxis",".makedotsP",".makedotsLowLevel",".SelectOrderData") export(".merge.lists") export("InfoPlot", "ComparePlot", "PlotIC") +export(".fixInLiesInSupport") \ No newline at end of file Modified: branches/robast-1.2/pkg/RobAStBase/R/AllClass.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/AllClass.R 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/R/AllClass.R 2018-08-09 23:43:02 UTC (rev 1111) @@ -105,6 +105,7 @@ stop("'Infos' must have two columns") else TRUE }) +## comment 20180809: reverted changes in rev 1110 ## partial incluence curve setClass("IC", representation(CallL2Fam = "call", modifyIC = "OptionalFunction"), @@ -127,11 +128,6 @@ return(TRUE) }) - -## internal class -setClass(".fastIC", representation(.fastFct = "OptionalFunction"), - prototype(.fastFct = NULL), contains="IC") - ## HampIC -- common mother class to ContIC and TotalVarIC setClass("HampIC", representation(stand = "matrix", @@ -139,7 +135,7 @@ neighborRadius = "numeric", weight = "RobWeight", biastype = "BiasType", - normtype = "NormType"), + normtype = "NormType"), prototype(name = "IC of total-var or contamination type", Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x}), Domain = Reals())), @@ -153,7 +149,7 @@ neighborRadius = 0, biastype = symmetricBias(), NormType = NormType()), - contains = ".fastIC", + contains = "IC", validity = function(object){ if(any(object at neighborRadius < 0)) # radius vector?! stop("'neighborRadius' has to be in [0, Inf]") @@ -265,6 +261,8 @@ pIC = NULL), contains = c("ALEstimate","MCEstimate") ) +setClass("CvMMD.ALEstimate",contains = c("MCALEstimate","CvMMDEstimate")) +setClass("ML.ALEstimate",contains = c("MCALEstimate","MLEstimate")) setClass("kStepEstimate", representation(steps = "integer", Modified: branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R 2018-08-09 23:43:02 UTC (rev 1111) @@ -43,12 +43,10 @@ if(!isGeneric("evalIC")){ setGeneric("evalIC", function(IC, x) standardGeneric("evalIC")) } -if(!isGeneric("evalIC.v")){ - setGeneric("evalIC.v", function(IC, x) standardGeneric("evalIC.v")) -} if(!isGeneric("makeIC")){ setGeneric("makeIC", function(IC, L2Fam, ...) standardGeneric("makeIC")) } +## comment 20180809: reverted changes in rev 1110 if(!isGeneric("clip")){ setGeneric("clip", function(x1, ...) standardGeneric("clip")) } Modified: branches/robast-1.2/pkg/RobAStBase/R/AllShow.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/AllShow.R 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/R/AllShow.R 2018-08-09 23:43:02 UTC (rev 1111) @@ -105,6 +105,20 @@ show(pIC(object)) } }) +setMethod("show", "MCALEstimate", + function(object){ + digits <- getOption("digits") + getMethod("show","MCEstimate")(object) + if(getdistrModOption("show.details") != "minimal"){ + cat("asymptotic bias:\n") + print(asbias(object), quote = FALSE) + } + if(getdistrModOption("show.details") == "maximal" && !is.null(pIC(object))){ + cat("(partial) influence curve:\n") + show(pIC(object)) + } + }) + setMethod("show", "kStepEstimate", function(object){ digits <- getOption("digits") Modified: branches/robast-1.2/pkg/RobAStBase/R/ContIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/ContIC.R 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/R/ContIC.R 2018-08-09 23:43:02 UTC (rev 1111) @@ -5,7 +5,7 @@ Risks, Infos, clip = Inf, cent = 0, stand = as.matrix(1), lowerCase = NULL, neighborRadius = 0, w = new("HampelWeight"), normtype = NormType(), biastype = symmetricBias(), - modifyIC = NULL, .fastFct = NULL){ + modifyIC = NULL){ if(missing(name)) name <- "IC of contamination type" if(missing(Risks)) @@ -42,7 +42,6 @@ contIC at biastype <- biastype contIC at normtype <- normtype contIC at modifyIC <- modifyIC - contIC at .fastFct <- .fastFct return(contIC) # return(new("ContIC", name = name, Curve = Curve, Risks = Risks, Infos = Infos, @@ -67,7 +66,6 @@ name = "IC of contamination type", CallL2Fam = L2call, Curve = generateIC.fct(neighbor, L2Fam, res), - .fastFct = generateIC.fast.fct(neighbor, L2Fam, res), clip = b, cent = a, stand = A, @@ -172,5 +170,4 @@ addInfo(object) <- c("CallL2Fam<-", "The entries in 'Risks' and 'Infos' may be wrong") object }) - - +## comment 20180809: reverted changes in rev 1110 \ No newline at end of file Modified: branches/robast-1.2/pkg/RobAStBase/R/HampIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/HampIC.R 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/R/HampIC.R 2018-08-09 23:43:02 UTC (rev 1111) @@ -18,22 +18,4 @@ object }) -## evaluate IC -setMethod("evalIC.v", signature(IC = ".fastIC", x = "numeric"), - function(IC, x){ - if(is.null(IC at .fastFct)){ - res <- setMethod("evalIC.v", signature(IC = "IC", x = "numeric"))(IC,x) - ## cast to matrix ICdim x nobs - }else{ - res <- IC at .fastFct(x) - } - }) -setMethod("evalIC.v", signature(IC = ".fastIC", x = "matrix"), - function(IC, x){ - if(is.null(IC at .fastFct)){ - res <- setMethod("evalIC.v", signature(IC = "IC", x = "matrix"))(IC,x) - ## cast to matrix ICdim x nobs - }else{ - res <- IC at .fastFct(x) - } - }) +## comment 20180809: reverted changes in rev 1110 \ No newline at end of file Modified: branches/robast-1.2/pkg/RobAStBase/R/IC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-09 23:43:02 UTC (rev 1111) @@ -85,8 +85,6 @@ return(prec) }) - - ## evaluate IC setMethod("evalIC", signature(IC = "IC", x = "numeric"), function(IC, x){ @@ -115,12 +113,7 @@ else return(evalRandVar(Curve, x)[,,1]) }) -## evaluate IC -setMethod("evalIC.v", signature(IC = "IC", x = "numeric"), - function(IC, x) sapply(x, function(x) evalIC(IC,x)) - ) - ## make some L2function a pIC at a model setMethod("makeIC", signature(IC = "IC", L2Fam = "missing"), function(IC){ @@ -129,8 +122,8 @@ }) ## make some L2function a pIC at a model -setMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"), - function(IC, L2Fam){ +setMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"), + function(IC, L2Fam){ dims <- length(L2Fam at param) if(dimension(IC at Curve) != dims) @@ -149,27 +142,40 @@ E10 <- E(L2Fam, IC1 %*% t(L2deriv)) E1 <- matrix(E10, dims, dims) - stand <- trafo %*% solve(E1) + stand <- trafo %*% solve(E1) Y <- as(stand %*% IC1, "EuclRandVariable") + #ICfct <- vector(mode = "list", length = dims) + #ICfct[[1]] <- function(x){Y(x)} + if(!is.function(IC at modifyIC)) IC at modifyIC <- function(L2Fam, IC, withMakeIC = FALSE) return(makeIC(IC,L2Fam)) +# modifyIC <- ..modifnew +# }else{ +# .modifyIC <- IC at modifyIC +# if(!is.null(attr(IC at modifyIC,"hasMakeICin.modifyIC"))){ +# modifyIC <- .modifyIC +# }else{ +# modifyIC <- function(L2Fam, IC){ IC. <- .modifyIC(L2Fam, IC) +# return(makeIC(IC., L2Fam)) } +# } +# } +# } +# attr(modifyIC,"hasMakeICin.modifyIC") <- TRUE CallL2Fam <- L2Fam at fam.call return(IC(name = name(IC), Curve = EuclRandVarList(Y), - Risks = list(), - Infos=matrix(c("IC<-", - "generated by affine linear trafo to enforce consistency"), - ncol=2, dimnames=list(character(0), c("method", "message"))), + Risks = list(), + Infos=matrix(c("IC<-", + "generated by affine linear trafo to enforce consistency"), + ncol=2, dimnames=list(character(0), c("method", "message"))), CallL2Fam = CallL2Fam, modifyIC = IC at modifyIC)) }) - - # alias to IC needed here: .IC <- IC @@ -214,3 +220,4 @@ if(forceIC) IC.0 <- makeIC(IC.0, L2Fam) return(IC.0) }) +## comment 20180809: reverted changes in rev 1110 \ No newline at end of file Modified: branches/robast-1.2/pkg/RobAStBase/R/TotalVarIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/TotalVarIC.R 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/R/TotalVarIC.R 2018-08-09 23:43:02 UTC (rev 1111) @@ -4,7 +4,7 @@ Risks, Infos, clipLo = -Inf, clipUp = Inf, stand = as.matrix(1), lowerCase = NULL, neighborRadius = 0, w = new("BdStWeight"), normtype = NormType(), biastype = symmetricBias(), - modifyIC = NULL, .fastFct = NULL){ + modifyIC = NULL){ if(missing(name)) name <- "IC of total variation type" @@ -37,7 +37,6 @@ IC1 at biastype <- biastype IC1 at normtype <- normtype IC1 at modifyIC <- modifyIC - IC1 at .fastFct <- .fastFct return(IC1) } @@ -66,7 +65,6 @@ name = "IC of total variation type", CallL2Fam = L2call, Curve = generateIC.fct(neighbor, L2Fam, res), - .fastFct = generateIC.fast.fct(neighbor, L2Fam, res), clipUp = clipUp, clipLo = clipLo, stand = A, @@ -172,3 +170,4 @@ addInfo(object) <- c("CallL2Fam<-", "The entries in 'Risks' and 'Infos' may be wrong") object }) +## comment 20180809: reverted changes in rev 1110 \ No newline at end of file Modified: branches/robast-1.2/pkg/RobAStBase/R/bALEstimate.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/bALEstimate.R 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/R/bALEstimate.R 2018-08-09 23:43:02 UTC (rev 1111) @@ -5,20 +5,22 @@ setMethod("pIC", "ALEstimate", function(object){ pIC0 <- .getPIC(object) - eval.parent(substitute(object at pIC <- pIC0)) + if(is(pIC0,"IC")) eval.parent(substitute(object at pIC <- pIC0)) return(pIC0) }) setMethod("pIC", "MCEstimate", function(object){ if("pIC" %in% slotNames(class(object))){ pIC0 <- .getPIC(object) - eval.parent(substitute(object at pIC <- pIC0)) + if(is(pIC0,"IC")) eval.parent(substitute(object at pIC <- pIC0)) return(pIC0) }else{ return(getPIC(object)) }}) setMethod("pIC", "MCALEstimate", getMethod("pIC", "ALEstimate")) +setMethod("pIC", "ML.ALEstimate", getMethod("pIC", "ALEstimate")) +setMethod("pIC", "CvMMD.ALEstimate", getMethod("pIC", "ALEstimate")) setMethod("asbias", "ALEstimate", function(object) object at asbias) setMethod("steps", "kStepEstimate", function(object) object at steps) Modified: branches/robast-1.2/pkg/RobAStBase/R/combinedICs.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/combinedICs.R 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/R/combinedICs.R 2018-08-09 23:43:02 UTC (rev 1111) @@ -1,3 +1,9 @@ +################################################################################ +if(FALSE){ +################################################################################ +## 20180809: reverted changes from rev 1110 +################################################################################ + combineOrthPICs <- function(pIC1, pIC2, combinedName = "combined IC", dim){ ## adds to complementary pICs to give one IC ## the orthogonality is not checked here @@ -51,3 +57,7 @@ fastIC at .fastFct <- .fastFct return(fastIC) } +################################################################################ +## end if(FALSE) +################################################################################ +} \ No newline at end of file Modified: branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R 2018-08-09 23:43:02 UTC (rev 1111) @@ -8,70 +8,68 @@ d <- if(!is.null(res$d)) res$d else 0 w <- weight(res$w) nrvalues <- nrow(A) - dim <- ncol(A) + dims <- ncol(A) ICfct <- vector(mode = "list", length = nrvalues) - L <- as(diag(dim)%*%L2Fam at L2deriv, "EuclRandVariable") + L <- as(diag(dims)%*%L2Fam at L2deriv, "EuclRandVariable") distr <- distribution(L2Fam) + L.fct <- function(x) evalRandVar(L,x) if(nrvalues == 1){ if(!is.null(res$d)){ ICfct[[1]] <- function(x){} - if(all(dim(trafo(L2Fam at param)) == c(1, 1))){ + if(dims==1L){ body(ICfct[[1]]) <- substitute( - { indS <- liesInSupport(Di,x,checkFin=TRUE) - Lx <- L(x) + { Lx <- L(x) Yx <- A %*% Lx - a ind <- 1-.eq(Yx) - (Yx*w(Lx) + zi*(1-ind)*d*b)*indS }, + (Yx*w(Lx) + zi*(1-ind)*d*b) }, list(L = L.fct, w = w, b = b, d = d, A = A, a = a, - zi = sign(trafo(L2Fam at param)), .eq = .eq, Di = distr)) + zi = sign(trafo(L2Fam at param)), .eq = .eq)) }else{ body(ICfct[[1]]) <- substitute( - { indS <- liesInSupport(Di,x,checkFin=TRUE) - Lx <- L(x) + { Lx <- L(x) Yx <- A %*% Lx - a ind <- 1-.eq(Yx) - ifelse(ind, Yx*w(Lx), NA)*indS }, + ifelse(ind, Yx*w(Lx), NA) }, list(L = L.fct, w = w, b = b, d = d, A = A, a = a, - .eq = .eq, Di = distr)) + .eq = .eq)) } }else{ ICfct[[1]] <- function(x){} - body(ICfct[[1]]) <- substitute({ indS <- liesInSupport(Di,x,checkFin=TRUE) - Lx <- L(x) + body(ICfct[[1]]) <- substitute({ Lx <- L(x) Yx <- A %*% Lx - a - Yx*w(Lx)*indS }, - list(L = L.fct, A = A, a = a, w = w, Di = distr)) + Yx*w(Lx) }, + list(L = L.fct, A = A, a = a, w = w)) } }else{ if(!is.null(res$d)) for(i in 1:nrvalues){ ICfct[[i]] <- function(x){} - body(ICfct[[i]]) <- substitute({indS <- liesInSupport(Di,x,checkFin=TRUE) - Lx <- L(x) + body(ICfct[[i]]) <- substitute({Lx <- L(x) Yix <- Ai %*% Lx - ai ind <- 1-.eq(Yix) - (ind*Yix*w(Lx) + (1-ind)*di)*indS + (ind*Yix*w(Lx) + (1-ind)*di) }, list(L = L.fct, Ai = A[i,,drop=FALSE], ai = a[i], w = w, - di = d[i], Di = distr))#, .eq = .eq)) + di = d[i]))#, .eq = .eq)) } else for(i in 1:nrvalues){ ICfct[[i]] <- function(x){} - body(ICfct[[i]]) <- substitute({indS <- liesInSupport(Di,x,checkFin=TRUE) - Lx <- L(x) + body(ICfct[[i]]) <- substitute({Lx <- L(x) Yix <- Ai %*% Lx - ai - Yix*w(Lx)*indS }, - list(L = L.fct, Ai = A[i,,drop=FALSE], ai = a[i], w = w, Di = distr)) + Yix*w(Lx) }, + list(L = L.fct, Ai = A[i,,drop=FALSE], ai = a[i], w = w)) } } return(EuclRandVarList(EuclRandVariable(Map = ICfct, Domain = L at Domain, Range = Reals()))) # EuclideanSpace(dimension = nrvalues)))) }) +## comment 20180809: reverted changes in rev 1110 as to generate.fast.fc: ## generate fast IC fct ## for internal use only! +if(FALSE){ generateIC.fast.fct <- function(neighbor, L2Fam, res){ A <- as.matrix(res$A) a <- if(is(neighbor,"TotalVarNeighborhood")) 0 else res$a @@ -102,4 +100,13 @@ .eq = .eq, Di = distr)) return(fastFct) } +} +.fixInLiesInSupport<- function(IC, distr){ + MapL <- IC at Curve[[1]]@Map + for(i in 1:length(MapL)) + body(IC at Curve[[1]]@Map[[i]]) <- substitute({ + liesInSupport(distr,x,checkFin=TRUE)*fct(x) + }, list(fct = MapL[[i]], distr=distr)) + return(IC) +} Modified: branches/robast-1.2/pkg/RobAStBase/R/getPIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getPIC.R 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/R/getPIC.R 2018-08-09 23:43:02 UTC (rev 1111) @@ -5,13 +5,21 @@ setMethod(".checkEstClassForParamFamily", signature=signature(PFam="ANY",estimator="MCEstimate"), - function(PFam, estimator){ + function(PFam, estimator) .extendbyPIC(PFam, estimator, "MCALEstimate")) +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="ANY",estimator="MLEstimate"), + function(PFam, estimator) .extendbyPIC(PFam, estimator, "ML.ALEstimate")) +setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="ANY",estimator="CvMMDEstimate"), + function(PFam, estimator) .extendbyPIC(PFam, estimator, "CvMMD.ALEstimate")) + +.extendbyPIC <- function(PFam, estimator, toClass){ fromSlotNames <- slotNames(class(estimator)) - to <- new("MCALEstimate") + to <- new(toClass) for(item in fromSlotNames) slot(to, item) <- slot(estimator,item) to at pIC <- substitute(getPIC(estimator0), list(estimator0=estimator)) to - } ) + } .getPIC <- function(object){ if(is.null(object at pIC)) return(NULL) Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-08 21:49:35 UTC (rev 1110) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-09 23:43:02 UTC (rev 1111) @@ -24,6 +24,18 @@ setMethod("neighborRadius","ANY",function(object)NA) +.addTime <- function(timold,timnew,namenew){ + nameold <- rownames(timold) + tim <- rbind(timold,timnew) + rownames(tim) <- c(nameold,namenew) + return(tim) +} + +.ensureDim2 <- function(x){ + d <- dim(x) + if(length(d)==3L && d[3]==1L) dim(x) <- d[1:2] + x } + ### no dispatch on top layer -> keep product structure of dependence kStepEstimator <- function(x, IC, start = NULL, steps = 1L, useLast = getRobAStBaseOption("kStepUseLast"), @@ -41,8 +53,12 @@ es.call[[1]] <- as.name("kStepEstimator") ## get some dimensions - CallL2Fam <- CallL2Fam(IC) - L2Fam <- eval(CallL2Fam) +##-t-## syt <- system.time({ + L2Fam <- eval(CallL2Fam(IC)) +##-t-## }) +##-t-## sytm <- matrix(syt,nrow=1) +##-t-## rownames(sytm) <- "eval(CallL2Fam(IC))" +##-t-## colnames(sytm) <- names(syt) Param <- param(L2Fam) tf <- trafo(L2Fam,Param) @@ -54,8 +70,6 @@ p <- nrow(Dtau) k <- ncol(Dtau) - CallL2FamK <- CallL2Fam - if(p!=k) CallL2FamK$trafo <- diag(k) lmx <- length(main(L2Fam)) lnx <- length(nuisance(L2Fam)) @@ -83,9 +97,9 @@ ### transform if necessary x0 <- x - #x0 <- if(is.numeric(x) && ! is.matrix(x)) { - # x0 <- as.matrix(x) - # } + x0 <- if(is.numeric(x) && ! is.matrix(x)) { + x0 <- as.matrix(x) + } completecases <- complete.cases(x0) if(na.rm) x0 <- na.omit(x0) @@ -94,11 +108,20 @@ ### use dispatch here (dispatch only on start) #a.var <- if( is(start, "Estimate")) asvar(start) else NULL +##-t-## syt <- system.time({ IC.UpdateInKer.0 <- if(is(start,"ALEstimate")) pIC(start) else NULL +##-t-## }) +##-t-## sytm <- .addTime(sytm,syt,"pIC(start)") + ## pIC(start) instead of start at pIC to potentially eval a call + force(startArgList) + +##-t-## syt <- system.time({ start.val <- kStepEstimator.start(start, x=x0, nrvalues = k, na.rm = na.rm, L2Fam = L2Fam, startList = startArgList) +##-t-## }) +##-t-## sytm <- .addTime(sytm,syt,"kStepEstimator.start") ### use Logtransform here in scale models sclname <- "" @@ -106,6 +129,7 @@ logtrf <- is(L2Fam, "L2ScaleUnion") & withLogScale & sclname %in% names(start.val) ### a starting value in k-space +# print(start.val) u.theta <- start.val theta <- if(is(start.val,"Estimate")) estimate(start.val) else trafoF(u.theta[idx])$fval @@ -125,40 +149,65 @@ ICList <- if(withICList) vector("list", steps) else NULL cvar.fct <- function(L2, IC, dim, dimn =NULL){ - IC.C <- as(diag(dim)%*%IC at Curve, "EuclRandVariable") if(is.null(dimn)){ - return(matrix(E(L2, IC.C %*% t(IC.C)),dim,dim)) + return(matrix(E(L2, IC %*% t(IC)),dim,dim)) }else{ - return(matrix(E(L2, IC.C %*% t(IC.C)),dim,dim, dimnames = dimn)) + return(matrix(E(L2, IC %*% t(IC)),dim,dim, dimnames = dimn)) } } +##-t-## updStp <- 0 ### update - function updateStep <- function(u.theta, theta, IC, L2Fam, Param, withPreModif = FALSE, - withPostModif = TRUE, with.u.var = FALSE + withPostModif = TRUE, with.u.var = FALSE, + withEvalAsVar.0 = FALSE ){ +##-t-## updStp <<- updStp + 1 if(withPreModif){ main(Param)[] <- .deleteDim(u.theta[idx]) +# print(Param) if (lnx) nuisance(Param)[] <- .deleteDim(u.theta[nuis.idx]) +# print(Param) +# print(L2Fam) +##-t-## syt <- system.time({ L2Fam <- modifyModel(L2Fam, Param, .withL2derivDistr = L2Fam at .withEvalL2derivDistr) +##-t-## }) +##-t-## sytm <<- .addTime(sytm,syt,paste("modifyModel-PreModif-",updStp)) +# print(L2Fam) +##-t-## syt <- system.time({ IC <- modifyIC(IC)(L2Fam, IC, withMakeIC = FALSE) - CallL2Fam <- IC at CallL2Fam - if(steps==1L && withMakeIC) IC <- makeIC(IC, L2Fam) +##-t-## }) +##-t-## sytm <<- .addTime(sytm,syt,paste("modifyIC-PreModif-",updStp)) + if(steps==1L && withMakeIC){ +##-t-## syt <- system.time({ + IC <- makeIC(IC, L2Fam) +##-t-## }) +##-t-## sytm <<- .addTime(sytm,syt,paste("modifyIC-makeIC-",updStp)) +# IC at modifyIC <- oldmodifIC + } + # print(IC) } - IC.c <- .fastIC(Curve=EuclRandVarList(as(diag(p) %*% IC at Curve, "EuclRandVariable")), CallL2Fam = CallL2Fam) +##-t-## syt <- system.time({ + IC.c <- as(diag(p) %*% IC at Curve, "EuclRandVariable") +##-t-## }) +##-t-## sytm <<- .addTime(sytm,syt,paste("IC.c <- as(diag(p) %*%-",updStp)) +# print(theta) tf <- trafo(L2Fam, Param) Dtau <- tf$mat IC.tot.0 <- NULL +# print(Dtau) if(!.isUnitMatrix(Dtau)){ + # print("HU1!") Dminus <- solve(Dtau, generalized = TRUE) projker <- diag(k) - Dminus %*% Dtau - IC.tot1 <- .fastIC(Curve=EuclRandVarList(as(Dminus %*% IC.c at Curve, "EuclRandVariable")), CallL2Fam = CallL2FamK) + IC.tot1 <- Dminus %*% IC.c +# IC.tot2 <- 0 * IC.tot1 IC.tot2.isnull <- TRUE if(sum(diag(projker))>0.5 && ### is EM-D^-D != 0 (i.e. rk D Author: ruckdeschel Date: 2018-08-10 01:46:38 +0200 (Fri, 10 Aug 2018) New Revision: 1112 Modified: branches/robast-1.2/pkg/ROptEst/R/roptest.new.R branches/robast-1.2/pkg/ROptEst/inst/NEWS Log: [ROptEst] branch 1.2: inserted code for time checking (which is inactive usually; only if in kStepEstimator.R in RobAStBase, the respective ##-t-## lines are de-commented the timings are visible as attribute "kStepTimings" in the result of roptest ...) Modified: branches/robast-1.2/pkg/ROptEst/R/roptest.new.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-09 23:43:02 UTC (rev 1111) +++ branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-09 23:46:38 UTC (rev 1112) @@ -137,10 +137,12 @@ retV at robestCall <- quote(retV at estimate.call) retV at estimate.call <- mc tim <- attr(retV,"timings") + timK <- attr(retV,"kStepTimings") retV <- as(as(retV,"kStepEstimate"), "ORobEstimate") retV <- .checkEstClassForParamFamily(L2Fam,retV) attr(retV,"timings") <- tim + attr(retV,"kStepTimings") <- timK retV at roptestCall <- mc return(retV) } @@ -361,8 +363,9 @@ withEvalAsVar = withEvalAsVarkStep, withMakeIC = withMakeICkStep) }) + sy.OnlykStep <- attr(res,"timings") if (withTimings) print(sy.kStep) - + if (withTimings && !is.null(sy.OnlykStep)) print(sy.OnlykStep) if(!debug){ if(mwt) es.call$withTimings <- withTimings res at estimate.call <- es.call @@ -393,5 +396,6 @@ res at completecases <- completecases res at start <- initial.est attr(res, "timings") <- sy + attr(res, "kStepTimings") <- sy.OnlykStep return(res) } Modified: branches/robast-1.2/pkg/ROptEst/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-09 23:43:02 UTC (rev 1111) +++ branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-09 23:46:38 UTC (rev 1112) @@ -26,6 +26,9 @@ + some buglets in getStartIC + some tedious debugging in getStartIClcsc.R + clarified if clauses in roptest.new (and removed .with.checkEstClassForParamFamily from dots to be sure) ++ inserted code for time checking (which is inactive usually; only if in kStepEstimator.R in + RobAStBase, the respective ##-t-## lines are de-commented the timings are visible as + attribute "kStepTimings" in the result of roptest ...) ####################################### version 1.1 From noreply at r-forge.r-project.org Fri Aug 10 01:48:37 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 01:48:37 +0200 (CEST) Subject: [Robast-commits] r1113 - in branches/robast-1.2/pkg/RobExtremes: . R Message-ID: <20180809234837.20390189BCD@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 01:48:36 +0200 (Fri, 10 Aug 2018) New Revision: 1113 Modified: branches/robast-1.2/pkg/RobExtremes/DESCRIPTION branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R Log: [RobExtremes] in getStartIC.R we remove some interpolation grid parts from the function's environment which is no longer used in DESCRIPTION we require ROptEst 1.2.0 now Modified: branches/robast-1.2/pkg/RobExtremes/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobExtremes/DESCRIPTION 2018-08-09 23:46:38 UTC (rev 1112) +++ branches/robast-1.2/pkg/RobExtremes/DESCRIPTION 2018-08-09 23:48:36 UTC (rev 1113) @@ -5,8 +5,9 @@ Description: Optimally robust estimation for extreme value distributions using S4 classes and methods (based on packages 'distr', 'distrEx', 'distrMod', 'RobAStBase', and 'ROptEst'). -Depends: R(>= 2.14.0), methods, distrMod(>= 2.8.0), ROptEst(>= 1.1.0), robustbase, evd +Depends: R(>= 2.14.0), methods, distrMod(>= 2.8.0), ROptEst(>= 1.2.0), robustbase, evd Suggests: RUnit(>= 0.4.26), ismev(>= 1.39) +Enhances: fitdistrplus(>= 1.0-9) Imports: RobAStRDA, distr, distrEx(>= 2.8.0), RandVar, RobAStBase(>= 1.2.0), startupmsg, actuar Authors at R: c(person("Nataliya", "Horbenko", role=c("aut","cph")), person("Bernhard", "Spangl", role="ctb", comment="contributed smoothed grid values of the Lagrange multipliers"), Modified: branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R 2018-08-09 23:46:38 UTC (rev 1112) +++ branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R 2018-08-09 23:48:36 UTC (rev 1113) @@ -26,6 +26,7 @@ if(length(nsng)){ if(gridn %in% nsng){ interpolfct <- famg[[gridn]][[.versionSuff("fun")]] + rm(famg, nsgn, gridn) .modifyIC0 <- function(L2Fam, IC, withMakeIC = FALSE){ para <- param(L2Fam) if(!.is.na.Psi(para, interpolfct, shnam)) @@ -49,8 +50,10 @@ IC0 at modifyIC <- .modifyIC return(IC0) } + rm(mc) } } + rm(famg, nsgn,gridn) IC <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2)) if(withMakeIC) IC <- makeIC(IC,model) return(IC) From noreply at r-forge.r-project.org Fri Aug 10 01:51:28 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 01:51:28 +0200 (CEST) Subject: [Robast-commits] r1114 - branches/robast-1.2/pkg/RobLox/R Message-ID: <20180809235128.20E11189BCD@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 01:51:27 +0200 (Fri, 10 Aug 2018) New Revision: 1114 Modified: branches/robast-1.2/pkg/RobLox/R/rlOptIC.R branches/robast-1.2/pkg/RobLox/R/rlsOptIC_AL.R branches/robast-1.2/pkg/RobLox/R/roblox.R branches/robast-1.2/pkg/RobLox/R/rsOptIC.R Log: [RobLox] branch 2.8: + the modifyIC functions gain argument withMakeIC to be consistent with the signature in RobAStBase (the arg is ignored in the RobLox Code) + The warnings as to moved ICs have been condensed Modified: branches/robast-1.2/pkg/RobLox/R/rlOptIC.R =================================================================== --- branches/robast-1.2/pkg/RobLox/R/rlOptIC.R 2018-08-09 23:48:36 UTC (rev 1113) +++ branches/robast-1.2/pkg/RobLox/R/rlOptIC.R 2018-08-09 23:51:27 UTC (rev 1114) @@ -18,7 +18,7 @@ biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC){ + modIC <- function(L2Fam, IC, withMakeIC){ if(is(L2Fam, "L2LocationFamily") && is(distribution(L2Fam), "Norm")){ CallL2Fam(IC) <- L2Fam at fam.call return(IC) Modified: branches/robast-1.2/pkg/RobLox/R/rlsOptIC_AL.R =================================================================== --- branches/robast-1.2/pkg/RobLox/R/rlsOptIC_AL.R 2018-08-09 23:48:36 UTC (rev 1113) +++ branches/robast-1.2/pkg/RobLox/R/rlsOptIC_AL.R 2018-08-09 23:51:27 UTC (rev 1114) @@ -157,7 +157,7 @@ biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC){ + modIC <- function(L2Fam, IC, withMakeIC){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2LocationScaleFamily") && is(distribution(L2Fam), "Norm")){ sdneu <- main(L2Fam)[2] @@ -185,8 +185,10 @@ modifyIC = modifyIC(IC)) IC <- generateIC(neighbor = ContNeighborhood(radius = r), L2Fam = L2Fam, res = res) - addInfo(IC) <- c("modifyIC", "The IC has been modified") - addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong") + if(!any(grepl("Some entries in 'Infos' may be wrong", Infos(IC)[,2]))){ + addInfo(IC) <- c("modifyIC", "The IC has been modified") + addInfo(IC) <- c("modifyIC", "Some entries in 'Infos' may be wrong") + } return(IC) }else{ makeIC(IC, L2Fam) Modified: branches/robast-1.2/pkg/RobLox/R/roblox.R =================================================================== --- branches/robast-1.2/pkg/RobLox/R/roblox.R 2018-08-09 23:48:36 UTC (rev 1113) +++ branches/robast-1.2/pkg/RobLox/R/roblox.R 2018-08-09 23:51:27 UTC (rev 1114) @@ -362,7 +362,7 @@ biastype = symmetricBias(), normW = NormType()) mse <- robEst$A1 + robEst$A2 - modIC <- function(L2Fam, IC){ + modIC <- function(L2Fam, IC, withMakeIC){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2LocationScaleFamily") && is(distribution(L2Fam), "Norm")){ sdneu <- main(L2Fam)[2] @@ -391,8 +391,10 @@ modifyIC = modifyIC(IC)) IC <- generateIC(neighbor = ContNeighborhood(radius = r), L2Fam = L2Fam, res = res) - addInfo(IC) <- c("modifyIC", "The IC has been modified") - addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong") + if(!any(grepl("Some entries in 'Infos' may be wrong", Infos(IC)[,2]))){ + addInfo(IC) <- c("modifyIC", "The IC has been modified") + addInfo(IC) <- c("modifyIC", "Some entries in 'Infos' may be wrong") + } return(IC) }else{ makeIC(L2Fam, IC) @@ -489,7 +491,7 @@ biastype = symmetricBias(), normW = NormType()) mse <- robEst$A1 + robEst$A2 - modIC <- function(L2Fam, IC){ + modIC <- function(L2Fam, IC, withMakeIC){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2LocationScaleFamily") && is(distribution(L2Fam), "Norm")){ sdneu <- main(L2Fam)[2] @@ -518,8 +520,10 @@ modifyIC = modifyIC(IC)) IC <- generateIC(neighbor = ContNeighborhood(radius = r), L2Fam = L2Fam, res = res) - addInfo(IC) <- c("modifyIC", "The IC has been modified") - addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong") + if(!any(grepl("Some entries in 'Infos' may be wrong", Infos(IC)[,2]))){ + addInfo(IC) <- c("modifyIC", "The IC has been modified") + addInfo(IC) <- c("modifyIC", "Some entries in 'Infos' may be wrong") + } return(IC) }else{ makeIC(L2Fam, IC) @@ -597,7 +601,7 @@ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = r), biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC){ + modIC <- function(L2Fam, IC, withMakeIC){ if(is(L2Fam, "L2LocationFamily") && is(distribution(L2Fam), "Norm")){ CallL2New <- call("NormLocationFamily", mean = main(L2Fam)) @@ -686,7 +690,7 @@ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = r), biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC){ + modIC <- function(L2Fam, IC, withMakeIC){ if(is(L2Fam, "L2LocationFamily") && is(distribution(L2Fam), "Norm")){ CallL2New <- call("NormLocationFamily", mean = main(L2Fam)) @@ -773,7 +777,7 @@ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = r), biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC){ + modIC <- function(L2Fam, IC, withMakeIC){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), "Norm")){ sdneu <- main(L2Fam) @@ -795,8 +799,10 @@ modifyIC = modifyIC(IC)) IC <- generateIC(neighbor = ContNeighborhood(radius = r), L2Fam = L2Fam, res = res) - addInfo(IC) <- c("modifyIC", "The IC has been modified") - addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong") + if(!any(grepl("Some entries in 'Infos' may be wrong", Infos(IC)[,2]))){ + addInfo(IC) <- c("modifyIC", "The IC has been modified") + addInfo(IC) <- c("modifyIC", "Some entries in 'Infos' may be wrong") + } return(IC) }else{ makeIC(L2Fam, IC) @@ -884,7 +890,7 @@ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = r), biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC){ + modIC <- function(L2Fam, IC, withMakeIC){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), "Norm")){ sdneu <- main(L2Fam) @@ -906,8 +912,10 @@ modifyIC = modifyIC(IC)) IC <- generateIC(neighbor = ContNeighborhood(radius = r), L2Fam = L2Fam, res = res) - addInfo(IC) <- c("modifyIC", "The IC has been modified") - addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong") + if(!any(grepl("Some entries in 'Infos' may be wrong", Infos(IC)[,2]))){ + addInfo(IC) <- c("modifyIC", "The IC has been modified") + addInfo(IC) <- c("modifyIC", "Some entries in 'Infos' may be wrong") + } return(IC) }else{ makeIC(L2Fam, IC) Modified: branches/robast-1.2/pkg/RobLox/R/rsOptIC.R =================================================================== --- branches/robast-1.2/pkg/RobLox/R/rsOptIC.R 2018-08-09 23:48:36 UTC (rev 1113) +++ branches/robast-1.2/pkg/RobLox/R/rsOptIC.R 2018-08-09 23:51:27 UTC (rev 1114) @@ -70,7 +70,7 @@ biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC){ + modIC <- function(L2Fam, IC, withMakeIC){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), "Norm")){ sdneu <- main(L2Fam) @@ -91,8 +91,10 @@ modifyIC = modifyIC(IC)) IC <- generateIC(neighbor = ContNeighborhood(radius = neighborRadius(IC)), L2Fam = L2Fam, res = res) - addInfo(IC) <- c("modifyIC", "The IC has been modified") - addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong") + if(!any(grepl("Some entries in 'Infos' may be wrong", Infos(IC)[,2]))){ + addInfo(IC) <- c("modifyIC", "The IC has been modified") + addInfo(IC) <- c("modifyIC", "Some entries in 'Infos' may be wrong") + } return(IC) }else{ makeIC(IC, L2Fam) From noreply at r-forge.r-project.org Fri Aug 10 01:53:28 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 01:53:28 +0200 (CEST) Subject: [Robast-commits] r1115 - branches/robast-1.2/pkg/RobRex/R Message-ID: <20180809235328.E0C6E189BCD@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 01:53:28 +0200 (Fri, 10 Aug 2018) New Revision: 1115 Modified: branches/robast-1.2/pkg/RobRex/R/rgsOptIC_ALc.R Log: [RobRex] branch 1.2: the calls to liesInSupport gain argument "checkFin" for consistency with the method in distr/distrEx (it is not used in RobRex, though). Modified: branches/robast-1.2/pkg/RobRex/R/rgsOptIC_ALc.R =================================================================== --- branches/robast-1.2/pkg/RobRex/R/rgsOptIC_ALc.R 2018-08-09 23:51:27 UTC (rev 1114) +++ branches/robast-1.2/pkg/RobRex/R/rgsOptIC_ALc.R 2018-08-09 23:53:28 UTC (rev 1115) @@ -209,14 +209,14 @@ body(fct1) <- substitute({ numeric(k) }, list(k = k)) if(is(K, "DiscreteMVDistribution")){ fct2 <- function(x){ - if(liesInSupport(K, x[1:k])){ + if(liesInSupport(K, x[1:k], checkFin = TRUE)){ ind <- colSums(apply(supp, 1, "==", x[1:k])) == k return(a.sc[ind]) }else{ return(NA) } } - body(fct2) <- substitute({ if(liesInSupport(K, x[1:k])){ + body(fct2) <- substitute({ if(liesInSupport(K, x[1:k], checkFin = TRUE)){ ind <- colSums(apply(supp, 1, "==", x[1:k])) == k return(a.sc[ind]) }else{ @@ -225,7 +225,7 @@ } if(is(K, "DiscreteDistribution")){ fct2 <- function(x){ - if(liesInSupport(K, x[1])){ + if(liesInSupport(K, x[1], checkFin = TRUE)){ ind <- (round(x[1], 8) == round(supp, 8)) return(a.sc[ind]) }else{ From noreply at r-forge.r-project.org Fri Aug 10 01:54:33 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 01:54:33 +0200 (CEST) Subject: [Robast-commits] r1116 - in branches/robast-1.2/pkg: . 20080808RobAStBaseDeadEnd Message-ID: <20180809235434.06C93189BCD@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 01:54:33 +0200 (Fri, 10 Aug 2018) New Revision: 1116 Added: branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/ branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllClass.R branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllGeneric.R branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/ContIC.R branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/HampIC.R branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/IC.R branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/TotalVarIC.R branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/combinedICs.R branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/ddPlot_utils.R branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/generateICfct.R branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/kStepEstimator.R Log: Added: branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllClass.R =================================================================== --- branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllClass.R (rev 0) +++ branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllClass.R 2018-08-09 23:54:33 UTC (rev 1116) @@ -0,0 +1,343 @@ +.onLoad <- function(lib, pkg){ +# require("methods", character = TRUE, quietly = TRUE) +# require("distr", character = TRUE, quietly = TRUE) +# require("distrEx", character = TRUE, quietly = TRUE) +# require("distrMod", character = TRUE, quietly = TRUE) +# require("RandVar", character = TRUE, quietly = TRUE) +} + +.onAttach <- function(library, pkg){ + unlockBinding(".RobAStBaseOptions", asNamespace("RobAStBase")) + msga <- gettext( + "Some functions from pkg's 'stats' and 'graphics' are intentionally masked ---see RobAStBaseMASK().\n" + ) + msgb <- gettext( + "Note that global options are controlled by RobAStBaseoptions() ---c.f. ?\"RobAStBaseoptions\"." + ) + buildStartupMessage(pkg = "RobAStBase", msga, msgb, + library = library, packageHelp = TRUE + # , MANUAL="http://www.uni-bayreuth.de/departments/math/org/mathe7/DISTR/distr.pdf" + # , VIGNETTE = gettext("Package \"distrDoc\" provides a vignette to this package as well as to several related packages; try vignette(\"distr\").") + ) + invisible() +} + +RobAStBaseMASK <- function(library = NULL) +{ + infoShow(pkg = "RobAStBase", filename = "MASKING", library = library) +} + +## neighborhood +setClass("Neighborhood", + representation(type = "character", + radius = "numeric"), + contains = "VIRTUAL") +## unconditional (errors-in-variables) neighborhood +setClass("UncondNeighborhood", contains = c("Neighborhood", "VIRTUAL")) +## unconditional convex contamination neighborhood +setClass("ContNeighborhood", contains = "UncondNeighborhood", + prototype = prototype(type = "(uncond.) convex contamination neighborhood", + radius = 0)) +## unconditional total variation neighborhood +setClass("TotalVarNeighborhood", contains = "UncondNeighborhood", + prototype = prototype(type = "(uncond.) total variation neighborhood", + radius = 0)) +## robust model +setClass("RobModel", + representation(center = "ProbFamily", + neighbor = "Neighborhood"), + contains = "VIRTUAL") +## robust model with fixed (unconditional) neighborhood +setClass("FixRobModel", + prototype = prototype(center = new("ParamFamily"), + neighbor = new("ContNeighborhood")), + contains = "RobModel", + validity = function(object){ + if(!is(object at neighbor, "UncondNeighborhood")) + stop("'neighbor' is no unconditional neighborhood") + if(any(object at neighbor@radius < 0 || object at neighbor@radius > 1)) + stop("neighborhood radius has to be in [0, 1]") + else return(TRUE) + }) +## robust model with infinitesimal (unconditional) neighborhood +setClass("InfRobModel", + prototype = prototype(center = new("L2ParamFamily"), + neighbor = new("ContNeighborhood")), + contains = "RobModel", + validity = function(object){ + if(!is(object at neighbor, "UncondNeighborhood")) + stop("'neighbor' is no unconditional neighborhood") + if(any(object at neighbor@radius < 0)) + stop("'radius' has to be in [0, Inf]") + else return(TRUE) + }) +## Weights +setClass("RobAStControl", representation(name ="character"), + contains = "VIRTUAL") + +setClass("RobWeight", representation(name = "character", weight = "function"), + prototype(name = "some weight", weight = function(x) 1)) +setClass("BoundedWeight", representation(clip = "numeric"), + prototype(clip = 1), contains = "RobWeight") +setClass("BdStWeight", representation(stand = "matrix"), + prototype(stand = matrix(1)), contains = "BoundedWeight") +setClass("HampelWeight", representation(cent = "numeric"), + prototype(cent = 0), contains = "BdStWeight") + + + + +## Influence curve/function with domain: EuclideanSpace +setClass("InfluenceCurve", + representation(name = "character", + Curve = "EuclRandVarList", + Risks = "list", + Infos = "matrix"), + validity = function(object){ + if(!is(Domain(object at Curve[[1]]), "EuclideanSpace")) + stop("The domain of 'Curve' has to be a Euclidean space") + if(!is.character(object at Infos)) + stop("'Infos' contains no matrix of characters") + for(char in names(object at Risks)) + if(!extends(char, "RiskType")) + stop(paste(char, "is no valid 'RiskType'")) + if(ncol(object at Infos)!=2) + stop("'Infos' must have two columns") + else TRUE + }) +## partial incluence curve +setClass("IC", representation(CallL2Fam = "call", + modifyIC = "OptionalFunction"), + prototype(name = "square integrable (partial) influence curve", + Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x}), + Domain = Reals())), + Risks = list(), + Infos = matrix(c(character(0),character(0)), ncol=2, + dimnames=list(character(0), c("method", "message"))), + CallL2Fam = call("L2ParamFamily"), + modifyIC = NULL), + contains = "InfluenceCurve", + validity = function(object){ + L2Fam <- eval(object at CallL2Fam) + trafo <- trafo(L2Fam at param) + if(nrow(trafo) != dimension(object at Curve)) + stop("wrong dimension of 'Curve'") + if(dimension(Domain(L2Fam at L2deriv[[1]])) != dimension(Domain(object at Curve[[1]]))) + stop("dimension of 'Domain' of 'L2deriv' != dimension of 'Domain' of 'Curve'") + + return(TRUE) + }) + +## internal class +setClass(".fastIC", representation(.fastFct = "OptionalFunction"), + prototype(.fastFct = NULL), contains="IC") + +## HampIC -- common mother class to ContIC and TotalVarIC +setClass("HampIC", + representation(stand = "matrix", + lowerCase = "OptionalNumeric", + neighborRadius = "numeric", + weight = "RobWeight", + biastype = "BiasType", + normtype = "NormType"), + prototype(name = "IC of total-var or contamination type", + Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x}), + Domain = Reals())), + Risks = list(), weight = new("RobWeight"), + Infos = matrix(c(character(0),character(0)), ncol=2, + dimnames=list(character(0), c("method", "message"))), + CallL2Fam = call("L2ParamFamily"), + modifyIC = NULL, + stand = as.matrix(1), + lowerCase = NULL, + neighborRadius = 0, + biastype = symmetricBias(), + NormType = NormType()), + contains = ".fastIC", + validity = function(object){ + if(any(object at neighborRadius < 0)) # radius vector?! + stop("'neighborRadius' has to be in [0, Inf]") + if(!is.null(object at lowerCase)) + if(length(object at lowerCase) != nrow(object at stand)) + stop("length of 'lowerCase' != nrow of standardizing matrix") + L2Fam <- eval(object at CallL2Fam) + if(!identical(dim(trafo(L2Fam at param)), dim(object at stand))) + stop(paste("dimension of 'trafo' of 'param' != dimension of 'stand'")) + return(TRUE) + }) +## (partial) influence curve of contamination type +setClass("ContIC", + representation(clip = "numeric", + cent = "numeric"), + prototype(name = "IC of contamination type", + Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x}), + Domain = Reals())), + Risks = list(), + Infos = matrix(c(character(0),character(0)), ncol=2, + dimnames=list(character(0), c("method", "message"))), + CallL2Fam = call("L2ParamFamily"), + modifyIC = NULL, + clip = Inf, cent = 0, stand = as.matrix(1), + lowerCase = NULL, + neighborRadius = 0, weight = new("HampelWeight"), + biastype = symmetricBias(), NormType = NormType()), + contains = "HampIC", + validity = function(object){ + if(length(object at cent) != nrow(object at stand)) + stop("length of centering constant != nrow of standardizing matrix") + if((length(object at clip) != 1) && (length(object at clip) != length(object at Curve))) + stop("length of clipping bound != 1 and != length of 'Curve'") + if(!is(weight,"HampelWeight")) + stop("Weight has to be of class 'HampelWeight'") + return(TRUE) + }) +## (partial) influence curve of total variation type +setClass("TotalVarIC", + representation(clipLo = "numeric", + clipUp = "numeric"), + prototype(name = "IC of total variation type", + Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x}), + Domain = Reals())), + Risks = list(), + Infos = matrix(c(character(0),character(0)), ncol=2, + dimnames=list(character(0), c("method", "message"))), + CallL2Fam = call("L2ParamFamily"), + modifyIC = NULL, + clipLo = -Inf, clipUp = Inf, stand = as.matrix(1), + lowerCase = NULL, + neighborRadius = 0, weight = new("BdStWeight"), + biastype = symmetricBias(), NormType = NormType()), + contains = "HampIC", + validity = function(object){ + if((length(object at clipLo) != 1) && (length(object at clipLo) != length(object at Curve))) + stop("length of lower clipping bound != 1 and != length of 'Curve'") + if((length(object at clipLo) != 1) && (length(object at clipLo) != length(object at Curve))) + stop("length of upper clipping bound != 1 and != length of 'Curve'") + if(!is(weight,"BdStWeight")) + stop("Weight has to be of class 'BdStWeight'") + return(TRUE) + }) + +## ALEstimate +setClassUnion("OptionalCall", c("call","NULL")) +setClassUnion("OptionalInfluenceCurve", c("InfluenceCurve", "NULL")) +setClassUnion("OptionalInfluenceCurveOrCall", c("InfluenceCurve", "NULL", "call")) +setClassUnion("StartClass", c("numeric", "matrix", "function", "Estimate")) +setClass("pICList", + prototype = prototype(list()), + contains = "list", + validity = function(object){ + nrvalues <- length(object) + if(nrvalues){ + for(i in 1:nrvalues) + if(!is(object[[i]], "OptionalInfluenceCurve")) + stop("element ", i, " is no 'OptionalInfluenceCurve'") + } + return(TRUE) + }) +setClassUnion("OptionalpICList", c("pICList", "NULL")) +setClass("ALEstimate", + representation(pIC = "OptionalInfluenceCurveOrCall", #"OptionalInfluenceCurve", + asbias = "OptionalNumeric"), + prototype(name = "Asymptotically linear estimate", + estimate = numeric(0), + samplesize = numeric(0), + estimate.call = call("{}"), + asvar = NULL, + asbias = NULL, + pIC = NULL, + nuis.idx = NULL, + trafo = list(fct = function(x){ + list(fval = x, mat = matrix(1))}, + mat = matrix(1)), ### necessary for comparison with unit matrix + Infos = matrix(c(character(0),character(0)), ncol=2, + dimnames=list(character(0), c("method", "message"))), + completecases = logical(0), + untransformed.estimate = NULL, + untransformed.asvar = NULL), + contains = "Estimate") + +setClass("MCALEstimate", + representation(pIC = "OptionalInfluenceCurveOrCall", + asbias = "OptionalNumeric"), + prototype(name = "Minimum criterion estimate (which is asy. linear)", + asbias = NULL, + pIC = NULL), + contains = c("ALEstimate","MCEstimate") +) + +setClass("kStepEstimate", + representation(steps = "integer", + pICList = "OptionalpICList", + ICList = "OptionalpICList", + start = "StartClass", + startval = "matrix", + ustartval = "matrix", + ksteps = "OptionalMatrix", + uksteps = "OptionalMatrix", + robestCall = "OptionalCall"), + prototype(name = "Asymptotically linear estimate", + estimate = numeric(0), + samplesize = numeric(0), + completecases = logical(0), + estimate.call = call("{}"), + steps = integer(0), + asvar = NULL, + asbias = NULL, + pIC = NULL, + pICList = NULL, + ICList = NULL, + ksteps = NULL, + uksteps = NULL, + start = matrix(0), + startval = matrix(0), + ustartval = matrix(0), + nuis.idx = NULL, + trafo = list(fct = function(x){ + list(fval = x, mat = matrix(1))}, + mat = matrix(1)), ### necessary for comparison with unit matrix + Infos = matrix(c(character(0),character(0)), ncol=2, + dimnames=list(character(0), c("method", "message"))), + untransformed.estimate = NULL, + untransformed.asvar = NULL, + robestCall = NULL), + contains = "ALEstimate") +setClass("MEstimate", + representation(Mroot = "numeric"), + prototype(name = "Asymptotically linear estimate", + estimate = numeric(0), + samplesize = numeric(0), + completecases = logical(0), + estimate.call = call("{}"), + Mroot = numeric(0), + asvar = NULL, + asbias = NULL, + pIC = NULL, + nuis.idx = NULL, + trafo = list(fct = function(x){ + list(fval = x, mat = matrix(1))}, + mat = matrix(1)), ### necessary for comparison with unit matrix + Infos = matrix(c(character(0),character(0)), ncol=2, + dimnames=list(character(0), c("method", "message"))), + untransformed.estimate = NULL, + untransformed.asvar = NULL), + contains = "ALEstimate") +################################################# +## "cutoff" class +################################################# +setClass("cutoff", representation = representation(name = "character", + fct = "function", + cutoff.quantile = "numeric"), + 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)) Added: branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllGeneric.R =================================================================== --- branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllGeneric.R (rev 0) +++ branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllGeneric.R 2018-08-09 23:54:33 UTC (rev 1116) @@ -0,0 +1,255 @@ +if(!isGeneric("radius")){ + setGeneric("radius", function(object) standardGeneric("radius")) +} +if(!isGeneric("radius<-")){ + setGeneric("radius<-", function(object,value) standardGeneric("radius<-")) +} +if(!isGeneric("center")){ + setGeneric("center", function(object) standardGeneric("center")) +} +if(!isGeneric("center<-")){ + setGeneric("center<-", function(object, value) standardGeneric("center<-")) +} +if(!isGeneric("neighbor")){ + setGeneric("neighbor", function(object) standardGeneric("neighbor")) +} +if(!isGeneric("neighbor<-")){ + setGeneric("neighbor<-", function(object, value) standardGeneric("neighbor<-")) +} +if(!isGeneric("Curve")){ + setGeneric("Curve", function(object) standardGeneric("Curve")) +} +if(!isGeneric("Risks")){ + setGeneric("Risks", function(object) standardGeneric("Risks")) +} +if(!isGeneric("Risks<-")){ + setGeneric("Risks<-", function(object, value) standardGeneric("Risks<-")) +} +if(!isGeneric("addRisk<-")){ + setGeneric("addRisk<-", function(object, value) standardGeneric("addRisk<-")) +} +if(!isGeneric("CallL2Fam")){ + setGeneric("CallL2Fam", function(object) standardGeneric("CallL2Fam")) +} +if(!isGeneric("CallL2Fam<-")){ + setGeneric("CallL2Fam<-", function(object, value) standardGeneric("CallL2Fam<-")) +} +if(!isGeneric("generateIC")){ + setGeneric("generateIC", function(neighbor, L2Fam, ...) standardGeneric("generateIC")) +} +if(!isGeneric("checkIC")){ + setGeneric("checkIC", function(IC, L2Fam, ...) standardGeneric("checkIC")) +} +if(!isGeneric("evalIC")){ + setGeneric("evalIC", function(IC, x) standardGeneric("evalIC")) +} +if(!isGeneric("evalIC.v")){ + setGeneric("evalIC.v", function(IC, x) standardGeneric("evalIC.v")) +} +if(!isGeneric("makeIC")){ + setGeneric("makeIC", function(IC, L2Fam, ...) standardGeneric("makeIC")) +} +if(!isGeneric("clip")){ + setGeneric("clip", function(x1, ...) standardGeneric("clip")) +} +if(!isGeneric("clip<-")){ + setGeneric("clip<-", function(object, value) standardGeneric("clip<-")) +} +if(!isGeneric("cent")){ + setGeneric("cent", function(object) standardGeneric("cent")) +} +if(!isGeneric("cent<-")){ + setGeneric("cent<-", function(object, value) standardGeneric("cent<-")) +} +if(!isGeneric("stand")){ + setGeneric("stand", function(object) standardGeneric("stand")) +} +if(!isGeneric("stand<-")){ + setGeneric("stand<-", function(object, value) standardGeneric("stand<-")) +} +if(!isGeneric("lowerCase")){ + setGeneric("lowerCase", function(object) standardGeneric("lowerCase")) +} +if(!isGeneric("lowerCase<-")){ + setGeneric("lowerCase<-", function(object, value) standardGeneric("lowerCase<-")) +} +if(!isGeneric("neighborRadius")){ + setGeneric("neighborRadius", function(object) standardGeneric("neighborRadius")) +} +if(!isGeneric("neighborRadius<-")){ + setGeneric("neighborRadius<-", function(object, value) standardGeneric("neighborRadius<-")) +} +if(!isGeneric("clipLo")){ + setGeneric("clipLo", function(object) standardGeneric("clipLo")) +} +if(!isGeneric("clipLo<-")){ + setGeneric("clipLo<-", function(object, value) standardGeneric("clipLo<-")) +} +if(!isGeneric("clipUp")){ + setGeneric("clipUp", function(object) standardGeneric("clipUp")) +} +if(!isGeneric("clipUp<-")){ + setGeneric("clipUp<-", function(object, value) standardGeneric("clipUp<-")) +} +#if(!isGeneric("oneStepEstimator")){ +# setGeneric("oneStepEstimator", +# function(x, IC, start, ...) standardGeneric("oneStepEstimator")) +#} +#if(!isGeneric("kStepEstimator")){ +# setGeneric("kStepEstimator", +# function(x, IC, start, ...) standardGeneric("kStepEstimator")) +#} +if(!isGeneric("locMEstimator")){ + setGeneric("locMEstimator", function(x, IC, ...) standardGeneric("locMEstimator")) +} +if(!isGeneric("infoPlot")){ + setGeneric("infoPlot", function(object,...) standardGeneric("infoPlot")) +} +if(!isGeneric("optIC")){ + setGeneric("optIC", function(model, risk, ...) standardGeneric("optIC")) +} + + +if(!isGeneric("weight")){ + setGeneric("weight", + function(object, ...) standardGeneric("weight")) +} +if(!isGeneric("weight<-")){ + setGeneric("weight<-", + function(object, value) standardGeneric("weight<-")) +} +if(!isGeneric("clip<-")){ + setGeneric("clip<-", + function(object, value, ...) standardGeneric("clip<-")) +} +if(!isGeneric("stand")){ + setGeneric("stand", + function(object, ...) standardGeneric("stand")) +} +if(!isGeneric("stand<-")){ + setGeneric("stand<-", + function(object, value, ...) standardGeneric("stand<-")) +} +if(!isGeneric("cent")){ + setGeneric("cent", + function(object, ...) standardGeneric("cent")) +} +if(!isGeneric("cent<-")){ + setGeneric("cent<-", + function(object, value, ...) standardGeneric("cent<-")) +} + +if(!isGeneric("getweight")){ + setGeneric("getweight", + function(Weight, neighbor, biastype, ...) standardGeneric("getweight")) +} + +if(!isGeneric("minbiasweight")){ + setGeneric("minbiasweight", + function(Weight, neighbor, biastype, ...) standardGeneric("minbiasweight")) +} +if(!isGeneric("generateIC.fct")){ + setGeneric("generateIC.fct", function(neighbor, L2Fam, ...) standardGeneric("generateIC.fct")) +} +if(!isGeneric("getRiskIC")){ + setGeneric("getRiskIC", + function(IC, risk, neighbor, L2Fam, ...) standardGeneric("getRiskIC")) +} +if(!isGeneric("getBiasIC")){ + setGeneric("getBiasIC", + function(IC, neighbor, ...) standardGeneric("getBiasIC")) +} +if(!isGeneric(".evalBiasIC")){ + setGeneric(".evalBiasIC", + function(IC, neighbor, biastype, ...) standardGeneric(".evalBiasIC")) +} +if(!isGeneric("comparePlot")){ + setGeneric("comparePlot", function(obj1,obj2,...) standardGeneric("comparePlot")) +} +if(!isGeneric("pIC")){ + setGeneric("pIC", function(object) standardGeneric("pIC")) +} +if(!isGeneric("asbias")){ + setGeneric("asbias", function(object) standardGeneric("asbias")) +} +if(!isGeneric("steps")){ + setGeneric("steps", function(object) standardGeneric("steps")) +} +if(!isGeneric("ksteps")){ + setGeneric("ksteps", function(object,...) standardGeneric("ksteps")) +} +if(!isGeneric("uksteps")){ + setGeneric("uksteps", function(object,...) standardGeneric("uksteps")) +} +if(!isGeneric("start")){ + setGeneric("start", function(x, ...) standardGeneric("start")) +} +if(!isGeneric("startval")){ + setGeneric("startval", function(object) standardGeneric("startval")) +} +if(!isGeneric("ustartval")){ + setGeneric("ustartval", function(object) standardGeneric("ustartval")) +} +if(!isGeneric("ICList")){ + setGeneric("ICList", function(object) standardGeneric("ICList")) +} +if(!isGeneric("pICList")){ + setGeneric("pICList", function(object) standardGeneric("pICList")) +} +if(!isGeneric("robestCall")){ + setGeneric("robestCall", function(object) standardGeneric("robestCall")) +} +if(!isGeneric("Mroot")){ + setGeneric("Mroot", function(object) standardGeneric("Mroot")) +} +if(!isGeneric("modifyIC")){ + setGeneric("modifyIC", function(object) standardGeneric("modifyIC")) +} +if(!isGeneric("cutoff.quantile")){ + setGeneric("cutoff.quantile", function(object) standardGeneric("cutoff.quantile")) +} +if(!isGeneric("cutoff.quantile<-")){ + setGeneric("cutoff.quantile<-", function(object,value) + standardGeneric("cutoff.quantile<-")) +} +if(!isGeneric("ddPlot")){ + setGeneric("ddPlot", function(data, dist.x, dist.y, cutoff.x, cutoff.y,...) + standardGeneric("ddPlot")) +} +if(!isGeneric("kStepEstimator.start")){ + 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")) +} +if(!isGeneric("getFiRisk")){ + setGeneric("getFiRisk", + function(risk, Distr, neighbor, ...) standardGeneric("getFiRisk")) +} +if(!isGeneric("getPIC")){ + setGeneric("getPIC", function(estimator) standardGeneric("getPIC")) +} Added: branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/ContIC.R =================================================================== --- branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/ContIC.R (rev 0) +++ branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/ContIC.R 2018-08-09 23:54:33 UTC (rev 1116) @@ -0,0 +1,176 @@ +## Generating function +ContIC <- function(name, CallL2Fam = call("L2ParamFamily"), + Curve = EuclRandVarList(RealRandVariable(Map = c(function(x){x}), + Domain = Reals())), + Risks, Infos, clip = Inf, cent = 0, stand = as.matrix(1), + lowerCase = NULL, neighborRadius = 0, w = new("HampelWeight"), + normtype = NormType(), biastype = symmetricBias(), + modifyIC = NULL, .fastFct = NULL){ + if(missing(name)) + name <- "IC of contamination type" + if(missing(Risks)) + Risks <- list() + if(missing(Infos)) + Infos <- matrix(c(character(0),character(0)), ncol=2, + dimnames=list(character(0), c("method", "message"))) + + if(any(neighborRadius < 0)) # radius vector?! + stop("'neighborRadius' has to be in [0, Inf]") + if(length(cent) != nrow(stand)) + stop("length of centering constant != nrow of standardizing matrix") + if((length(clip) != 1) && (length(clip) != length(Curve))) + stop("length of clipping bound != 1 and != length of 'Curve'") + if(!is.null(lowerCase)) + if(length(lowerCase) != nrow(stand)) + stop("length of 'lowerCase' != nrow of standardizing matrix") + L2Fam <- eval(CallL2Fam) + if(!identical(dim(trafo(L2Fam at param)), dim(stand))) + stop(paste("dimension of 'trafo' of 'param' != dimension of 'stand'")) + + contIC <- new("ContIC") + contIC at name <- name + contIC at Curve <- Curve + contIC at Risks <- Risks + contIC at Infos <- Infos + contIC at CallL2Fam <- CallL2Fam + contIC at clip <- clip + contIC at cent <- cent + contIC at stand <- stand + contIC at lowerCase <- lowerCase + contIC at neighborRadius <- neighborRadius + contIC at weight <- w + contIC at biastype <- biastype + contIC at normtype <- normtype + contIC at modifyIC <- modifyIC + contIC at .fastFct <- .fastFct + + return(contIC) +# return(new("ContIC", name = name, Curve = Curve, Risks = Risks, Infos = Infos, +# CallL2Fam = CallL2Fam, clip = clip, cent = cent, stand = stand, +# lowerCase = lowerCase, neighborRadius = neighborRadius)) +} + + +setMethod("generateIC", signature(neighbor = "ContNeighborhood", + L2Fam = "L2ParamFamily"), + function(neighbor, L2Fam, res){ + A <- res$A + a <- res$a + b <- res$b + d <- res$d + normtype <- res$normtype + biastype <- res$biastype + w <- res$w + L2call <- L2Fam at fam.call + L2call$trafo <- trafo(L2Fam) + return(ContIC( + name = "IC of contamination type", + CallL2Fam = L2call, + Curve = generateIC.fct(neighbor, L2Fam, res), + .fastFct = generateIC.fast.fct(neighbor, L2Fam, res), + clip = b, + cent = a, + stand = A, + lowerCase = d, + w = w, + neighborRadius = neighbor at radius, + modifyIC = res$modifyIC, + normtype = normtype, + biastype = biastype, + Risks = res$risk, + Infos = matrix(res$info, ncol = 2, + dimnames = list(character(0), c("method", "message"))))) + }) + +## Access methods +setMethod("clip", "ContIC", function(x1) x1 at clip) +setMethod("cent", "ContIC", function(object) object at cent) +setMethod("neighbor", "ContIC", function(object) ContNeighborhood(radius = object at neighborRadius) ) + +## replace methods +setReplaceMethod("clip", "ContIC", + function(object, value){ + stopifnot(is.numeric(value)) + L2Fam <- eval(object at CallL2Fam) + w <- object at weight + clip(w) <- value + weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = object at neighborRadius), + biastype = object at biastype, + normW = object at normtype) + res <- list(A = object at stand, a = object at cent, b = value, d = object at lowerCase, + risk = object at Risks, info = object at Infos, w = w, + normtype = object at normtype, biastype = object at biastype, + modifyIC = object at modifyIC) + object <- generateIC(neighbor = ContNeighborhood(radius = object at neighborRadius), + L2Fam = L2Fam, res = res) + addInfo(object) <- c("clip<-", "The clipping bound has been changed") + addInfo(object) <- c("clip<-", "The entries in 'Risks' and 'Infos' may be wrong") + object + }) +setReplaceMethod("cent", "ContIC", + function(object, value){ + stopifnot(is.numeric(value)) + L2Fam <- eval(object at CallL2Fam) + w <- object at weight + cent(w) <- as.vector(solve(object at stand) %*% value) + weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = object at neighborRadius), + biastype = object at biastype, + normW = object at normtype) + res <- list(A = object at stand, a = value, b = object at clip, d = object at lowerCase, + risk = object at Risks, info = object at Infos, w = w, + normtype = object at normtype, biastype = object at biastype, + modifyIC = object at modifyIC) + object <- generateIC(neighbor = ContNeighborhood(radius = object at neighborRadius), + L2Fam = L2Fam, res = res) + addInfo(object) <- c("cent<-", "The centering constant has been changed") + addInfo(object) <- c("cent<-", "The entries in 'Risks' and 'Infos' may be wrong") + object + }) +setReplaceMethod("stand", "ContIC", + function(object, value){ + stopifnot(is.matrix(value)) + L2Fam <- eval(object at CallL2Fam) + w <- object at weight + stand(w) <- value + weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = object at neighborRadius), [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/robast -r 1116 From noreply at r-forge.r-project.org Fri Aug 10 01:56:27 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 01:56:27 +0200 (CEST) Subject: [Robast-commits] r1117 - branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd Message-ID: <20180809235627.677E8189BCD@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 01:56:27 +0200 (Fri, 10 Aug 2018) New Revision: 1117 Added: branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/Readme.txt Log: explanation for code in folder 20180808RobAStBaseDeadEnd Added: branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/Readme.txt =================================================================== --- branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/Readme.txt (rev 0) +++ branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/Readme.txt 2018-08-09 23:56:27 UTC (rev 1117) @@ -0,0 +1,2 @@ +This is code from revision 1010 which was reverted / because (for the moment) +it seems a dead end... / but who knows... \ No newline at end of file From noreply at r-forge.r-project.org Fri Aug 10 01:58:02 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 01:58:02 +0200 (CEST) Subject: [Robast-commits] r1118 - branches/robast-1.2/pkg Message-ID: <20180809235802.AD6EF189BCD@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 01:58:02 +0200 (Fri, 10 Aug 2018) New Revision: 1118 Added: branches/robast-1.2/pkg/20180808RobAStBaseDeadEnd/ Removed: branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/ Log: renamed folder 20080808... to 20180808 ... From noreply at r-forge.r-project.org Fri Aug 10 19:48:28 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 19:48:28 +0200 (CEST) Subject: [Robast-commits] r1119 - branches/robast-1.2/pkg/20180808RobAStBaseDeadEnd Message-ID: <20180810174828.2A0E718A7F8@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 19:48:27 +0200 (Fri, 10 Aug 2018) New Revision: 1119 Added: branches/robast-1.2/pkg/20180808RobAStBaseDeadEnd/SkippedNewsEntries.txt Log: Skipped News Entries Added: branches/robast-1.2/pkg/20180808RobAStBaseDeadEnd/SkippedNewsEntries.txt =================================================================== --- branches/robast-1.2/pkg/20180808RobAStBaseDeadEnd/SkippedNewsEntries.txt (rev 0) +++ branches/robast-1.2/pkg/20180808RobAStBaseDeadEnd/SkippedNewsEntries.txt 2018-08-10 17:48:27 UTC (rev 1119) @@ -0,0 +1,42 @@ ++ in kStepEstimator got back from RandVar-evaluation to IC - evaluation + background: updates should be fast (I saw examples with 60s for 3step... + with fast LMs...) -> to this end: + (a) (for internal purposes) introduce new intermediate S4 class ".fastIC" + (with non-exported generator .fastIC in file combinedICs.R) which is + inbetween class IC and HampIC and has a new slot ".fastFct". + ".fastFct" is an optional (= can be NULL) mere function in one argument + which returns the vector-valued IC; this way coordinatewise repeated + checking whether x is in support of distr (and evaluation of the weight) + can be avoided + (b) new slot ".fastFct" is filled automatically for our Hamepl-type + ICs in generators ContIC and TotalVarIC by analogue generateIC.fast.fct + to generateIC.fct in file generateICfct.R. + (c) class .fastIC is intermediate as we need it, too, for non-Hampel type ICs + as arise when either the covariance of our opt-rob IC is singular or + one works with pICs and has to reconstruct full ICs by filling the parts + in the orthogonal complement of Range IC; + (d) to this last issue instead of adding two random variables, as was done + beforehand in kStepEstimator, one uses the new helper function combineOrthPICs + in file combinedICs.R which combines (without checking orthogonality) two + pICs to one full IC by adding the curves (and the fast functions). + (e) in kStepEstimator, we now use evalIC.v, a (sapply-)vectorized version + of evalIC; this is an exported method and has a particular method for + class ".fastIC" which uses slot ".fastFct" instead of the evaluation + of the pIC through evalRandVar ... + (f) generateIC.fct has also been revised: it avoids using random variable + Y(x)/Yi(x) and instead computes them right away from Lambda; + this also has as background that checkIC/makeIC should be enhanced; + ultimately, this enhancement is passed to ROptEst -- idea is to + reuse infrastructure from getInfStand getInfCent which automatically + does symmetry checking ... +TBD: documentation for + generateIC.fast.fct + evalIC.v + combineOrthPICs + .fastIC generator + .fastIC class + + fu <- function(x){x=4; return(x)} + li <- list(a=3) + b <- fu(li$x) + b; li \ No newline at end of file From noreply at r-forge.r-project.org Sat Aug 11 00:49:40 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 00:49:40 +0200 (CEST) Subject: [Robast-commits] r1120 - in branches/robast-1.2/pkg/RobAStBase: R inst man Message-ID: <20180810224940.B1801187A53@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 00:49:40 +0200 (Sat, 11 Aug 2018) New Revision: 1120 Removed: branches/robast-1.2/pkg/RobAStBase/R/combinedICs.R Modified: branches/robast-1.2/pkg/RobAStBase/R/getPIC.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd Log: [RobAstBase] branch 1.2: only MLEs and CvMMDEs (of class MCEstimate) are automatically cast to ALEstimate / surrogate classes ML.ALEstimate / CvMMD.ALEstimate i.e., the ".checkEstClassForParamFamily" for MCEstimate is removed / set to trivial identity Deleted: branches/robast-1.2/pkg/RobAStBase/R/combinedICs.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/combinedICs.R 2018-08-10 17:48:27 UTC (rev 1119) +++ branches/robast-1.2/pkg/RobAStBase/R/combinedICs.R 2018-08-10 22:49:40 UTC (rev 1120) @@ -1,63 +0,0 @@ -################################################################################ -if(FALSE){ -################################################################################ -## 20180809: reverted changes from rev 1110 -################################################################################ - -combineOrthPICs <- function(pIC1, pIC2, combinedName = "combined IC", dim){ - ## adds to complementary pICs to give one IC - ## the orthogonality is not checked here - - IC <- new(".fastIC") - IC at name <- combinedName - pICC1 <- as(diag(dim)%*%pIC1 at Curve,"EuclRandVariable") - pICC2 <- as(diag(dim)%*%pIC2 at Curve,"EuclRandVariable") - IC at Curve <- EuclRandVarList(pICC1+pICC2) - IC at Risks <- pIC1 at Risks - if(length(pIC2 at Risks)) addRisk(IC) <- pIC2 at Risks - IC at Infos <- pIC1 at Infos - if(nrow(pIC2 at Infos)) addInfo(IC) <- pIC2 at Infos - IC at CallL2Fam <- pIC1 at CallL2Fam - .modifyIC.0 <- function(L2Fam, IC, withMakeIC = FALSE){ - pic1 <- pic1 at modifyIC(L2Fam, pIC1, withMakeIC) - pic2 <- pic2 at modifyIC(L2Fam, pIC2, withMakeIC) - IC1 <- combineOrthPICs(pic1, pic2,combinedName) - return(IC1) - } - .modifyIC.1 <- function(L2Fam, IC, withMakeIC = FALSE){ - IC1 <- .modifyIC.0(L2Fam, IC, withMakeIC) - IC1 at modifyIC <- .modifyIC.1 - return(IC1) - } - - IC at modifyIC <- .modifyIC.1 - IC at .fastFct <- function(x){pIC1 at .fastFct(x)+pIC2 at .fastFct(x)} - return(IC) -} - - -.fastIC <- function(name ="", Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x}), - Domain = Reals())), Risks, Infos, CallL2Fam = call("L2ParamFamily"), - modifyIC = NULL, .fastFct = NULL){ -fastIC <- new(".fastIC") -if(missing(Infos)) Infos <- fastIC at Infos -if(missing(Risks)) Risks <- fastIC at Risks -IC.0 <- IC(name, Curve, Risks, Infos, CallL2Fam, modifyIC) -slotNms <- slotNames(class(IC.0)) -for(sN in slotNms) slot(fastIC, sN) <- slot(IC.0,sN) -if(is.null(.fastFct)||missing(.fastFct)){ - ICM <- IC.0 at Curve[[1]]@Map - .fastFct <- function(x){ - if(is.null(dim(x))) - sapply(x, function(u) sapply(ICM, function(s)s(u))) - else - apply(x, 1,function(u) sapply(ICM, function(s)s(u))) - } -} -fastIC at .fastFct <- .fastFct -return(fastIC) -} -################################################################################ -## end if(FALSE) -################################################################################ -} \ No newline at end of file Modified: branches/robast-1.2/pkg/RobAStBase/R/getPIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getPIC.R 2018-08-10 17:48:27 UTC (rev 1119) +++ branches/robast-1.2/pkg/RobAStBase/R/getPIC.R 2018-08-10 22:49:40 UTC (rev 1120) @@ -3,10 +3,10 @@ function(PFam, estimator)estimator) +#setMethod(".checkEstClassForParamFamily", +# signature=signature(PFam="ANY",estimator="MCEstimate"), +# function(PFam, estimator) .extendbyPIC(PFam, estimator, "MCALEstimate")) setMethod(".checkEstClassForParamFamily", - signature=signature(PFam="ANY",estimator="MCEstimate"), - function(PFam, estimator) .extendbyPIC(PFam, estimator, "MCALEstimate")) -setMethod(".checkEstClassForParamFamily", signature=signature(PFam="ANY",estimator="MLEstimate"), function(PFam, estimator) .extendbyPIC(PFam, estimator, "ML.ALEstimate")) setMethod(".checkEstClassForParamFamily", Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-10 17:48:27 UTC (rev 1119) +++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-10 22:49:40 UTC (rev 1120) @@ -50,6 +50,10 @@ * "( mu = model distr. )" => this uses .CvMMDCovariance with no argument mu * "( mu = )" => this uses .CvMMDCovariance with argument mu to get the pIC ++ only MLEs and CvMMDEs (of class MCEstimate) are automatically cast to ALEstimate + / surrogate classes ML.ALEstimate / CvMMD.ALEstimate + i.e., the ".checkEstClassForParamFamily" for MCEstimate is removed + / set to trivial identity + force optimal ICs to respect the support of the model distribution careful testing gave: during evaluation of kStepEstimator it is prohibitive to put line liesInSupport in each of the coordinate functions Modified: branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd 2018-08-10 17:48:27 UTC (rev 1119) +++ branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd 2018-08-10 22:49:40 UTC (rev 1120) @@ -18,7 +18,8 @@ \alias{confint,ALEstimate,symmetricBias-method} \alias{confint,ALEstimate,onesidedBias-method} \alias{confint,ALEstimate,asymmetricBias-method} -\alias{.checkEstClassForParamFamily,ANY,MCEstimate-method} +\alias{.checkEstClassForParamFamily,ANY,MLEstimate-method} +\alias{.checkEstClassForParamFamily,ANY,CvMMDEstimate-method} \alias{getPIC} \alias{getPIC,ANY-method} \alias{getPIC,MLEstimate-method} From noreply at r-forge.r-project.org Sat Aug 11 15:54:52 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 15:54:52 +0200 (CEST) Subject: [Robast-commits] r1121 - in branches/robast-1.2/pkg/RobAStBase: R inst man Message-ID: <20180811135452.6A4A918A816@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 15:54:52 +0200 (Sat, 11 Aug 2018) New Revision: 1121 Modified: branches/robast-1.2/pkg/RobAStBase/R/ContIC.R branches/robast-1.2/pkg/RobAStBase/R/IC.R branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R branches/robast-1.2/pkg/RobAStBase/R/infoPlot.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R branches/robast-1.2/pkg/RobAStBase/R/optIC.R branches/robast-1.2/pkg/RobAStBase/R/outlyingPlot.R branches/robast-1.2/pkg/RobAStBase/R/qqplot.R branches/robast-1.2/pkg/RobAStBase/R/returnlevelplot.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd Log: [RobAStBase] branch 1.2: + now specified that we want to use distr::solve + now generateIC.fct produces vectorized functions (can now use useApply=FALSE in E()) Modified: branches/robast-1.2/pkg/RobAStBase/R/ContIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/ContIC.R 2018-08-10 22:49:40 UTC (rev 1120) +++ branches/robast-1.2/pkg/RobAStBase/R/ContIC.R 2018-08-11 13:54:52 UTC (rev 1121) @@ -110,7 +110,7 @@ stopifnot(is.numeric(value)) L2Fam <- eval(object at CallL2Fam) w <- object at weight - cent(w) <- as.vector(solve(object at stand) %*% value) + cent(w) <- as.vector(distr::solve(object at stand) %*% value) weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = object at neighborRadius), biastype = object at biastype, normW = object at normtype) Modified: branches/robast-1.2/pkg/RobAStBase/R/IC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-10 22:49:40 UTC (rev 1120) +++ branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-11 13:54:52 UTC (rev 1121) @@ -142,7 +142,7 @@ E10 <- E(L2Fam, IC1 %*% t(L2deriv)) E1 <- matrix(E10, dims, dims) - stand <- trafo %*% solve(E1) + stand <- trafo %*% distr::solve(E1) Y <- as(stand %*% IC1, "EuclRandVariable") #ICfct <- vector(mode = "list", length = dims) #ICfct[[1]] <- function(x){Y(x)} Modified: branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R 2018-08-10 22:49:40 UTC (rev 1120) +++ branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R 2018-08-11 13:54:52 UTC (rev 1121) @@ -13,7 +13,7 @@ L <- as(diag(dims)%*%L2Fam at L2deriv, "EuclRandVariable") distr <- distribution(L2Fam) - L.fct <- function(x) evalRandVar(L,x) + L.fct <- function(x) evalRandVar(L,as.matrix(x))[,,1] if(nrvalues == 1){ if(!is.null(res$d)){ ICfct[[1]] <- function(x){} @@ -80,7 +80,7 @@ dims <- ncol(A) L <- as(diag(dims)%*%L2Fam at L2deriv, "EuclRandVariable") distr <- distribution(L2Fam) - L.fct <- function(x) evalRandVar(L,x) + L.fct <- function(x) evalRandVar(L,as.matrix(x))[,,1] fastFct <- function(x){} if(nrvalues==1L){ d0 <- if(dims==1L) d else NA Modified: branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-10 22:49:40 UTC (rev 1120) +++ branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-11 13:54:52 UTC (rev 1121) @@ -1,6 +1,6 @@ getBoundedIC <- function(L2Fam, D=trafo(L2Fam at param)){ FI <- FisherInfo(L2Fam) - bm <- sum(diag(solve(FI))) + bm <- sum(diag(distr::solve(FI))) w <- new("BoundedWeight", clip = bm, weight = function(x){ norm0 <- EuclideanNorm(as.matrix(x)) ind2 <- (norm0 < bm/2) @@ -30,6 +30,6 @@ L2w0 <- L2w - cent E1 <- matrix(E(D1, L2w0 %*% t(L2deriv-cent)), dims, dims) - stand <- as.matrix(D %*% solve(E1, generalized = TRUE)) + stand <- as.matrix(D %*% distr::solve(E1, generalized = TRUE)) return(as(stand %*% L2w0, "EuclRandVariable")) } Modified: branches/robast-1.2/pkg/RobAStBase/R/infoPlot.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/infoPlot.R 2018-08-10 22:49:40 UTC (rev 1120) +++ branches/robast-1.2/pkg/RobAStBase/R/infoPlot.R 2018-08-11 13:54:52 UTC (rev 1121) @@ -207,7 +207,7 @@ QFc <- diag(dimsA) if(is(object,"ContIC") & dimsA>1 ) {if (is(normtype(object),"QFNorm")) QFc <- QuadForm(normtype(object)) - QFc0 <- solve( trafo %*% solve(L2Fam at FisherInfo) %*% t(trafo )) + QFc0 <- distr::solve( trafo %*% distr::solve(L2Fam at FisherInfo) %*% t(trafo )) if (is(normtype(object),"SelfNorm")|is(normtype(object),"InfoNorm")) QFc <- QFc0 } @@ -223,7 +223,7 @@ QFc.5 <- sqrt(PosSemDefSymmMatrix(QFc)) - classIC <- as(trafo %*% solve(L2Fam at FisherInfo) %*% L2Fam at L2deriv, "EuclRandVariable") + classIC <- as(trafo %*% distr::solve(L2Fam at FisherInfo) %*% L2Fam at L2deriv, "EuclRandVariable") absInfoClass.f <- t(classIC) %*% QFc %*% classIC # absInfoClass <- absInfoEval(x.vec, absInfoClass.f) Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-10 22:49:40 UTC (rev 1120) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-11 13:54:52 UTC (rev 1121) @@ -203,7 +203,7 @@ # print(Dtau) if(!.isUnitMatrix(Dtau)){ # print("HU1!") - Dminus <- solve(Dtau, generalized = TRUE) + Dminus <- distr::solve(Dtau, generalized = TRUE) projker <- diag(k) - Dminus %*% Dtau IC.tot1 <- Dminus %*% IC.c Modified: branches/robast-1.2/pkg/RobAStBase/R/optIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/optIC.R 2018-08-10 22:49:40 UTC (rev 1120) +++ branches/robast-1.2/pkg/RobAStBase/R/optIC.R 2018-08-11 13:54:52 UTC (rev 1121) @@ -3,7 +3,7 @@ ############################################################################### setMethod("optIC", signature(model = "L2ParamFamily", risk = "asCov"), function(model, risk, withMakeIC = FALSE){ - Curve <- as((trafo(model at param) %*% solve(model at FisherInfo)) %*% model at L2deriv, "EuclRandVariable") + Curve <- as((trafo(model at param) %*% distr::solve(model at FisherInfo)) %*% model at L2deriv, "EuclRandVariable") asCov <- trafo(model at param) %*% solve(model at FisherInfo) %*% t(trafo(model at param)) modifyIC <- function(L2Fam, IC, withMakeIC=FALSE){ optIC(L2Fam, asCov()) } Modified: branches/robast-1.2/pkg/RobAStBase/R/outlyingPlot.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/outlyingPlot.R 2018-08-10 22:49:40 UTC (rev 1120) +++ branches/robast-1.2/pkg/RobAStBase/R/outlyingPlot.R 2018-08-11 13:54:52 UTC (rev 1121) @@ -111,7 +111,7 @@ devIC <- data.frame(t(evIC[1:dimevIC,,drop=FALSE])) CMcd <- PosSemDefSymmMatrix(rrcov::getCov(rrcov::CovMcd(devIC,alpha=0.5))) asVar <- CMcd -# asVar <- solve(CMcd) +# asVar <- distr::solve(CMcd) # cat("\n", sep="", gettext("Robust asVar"), ":\n") # print(asVar) } @@ -129,8 +129,8 @@ } } -# asVar <- PosSemDefSymmMatrix(solve(asVar)) - mc$dist.x <- QFNorm(name = gettext("Mahalonobis-Norm"), QuadForm = PosSemDefSymmMatrix(solve(asVar))) +# asVar <- PosSemDefSymmMatrix(distr::solve(asVar)) + mc$dist.x <- QFNorm(name = gettext("Mahalonobis-Norm"), QuadForm = PosSemDefSymmMatrix(distr::solve(asVar))) } if(missing(dist.y)){ @@ -161,7 +161,7 @@ } mc$dist.y <- QFNorm(name = gettext("Mahalonobis-Norm"), - QuadForm = PosSemDefSymmMatrix(solve(asVar))) + QuadForm = PosSemDefSymmMatrix(distr::solve(asVar))) } Modified: branches/robast-1.2/pkg/RobAStBase/R/qqplot.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/qqplot.R 2018-08-10 22:49:40 UTC (rev 1120) +++ branches/robast-1.2/pkg/RobAStBase/R/qqplot.R 2018-08-11 13:54:52 UTC (rev 1121) @@ -113,7 +113,7 @@ FI <- PosSemDefSymmMatrix(FisherInfo(y at center)) L2D <- as(diag(nrow(FI)) %*% L2deriv(y at center), "EuclRandVariable") L2Dx <- evalRandVar(L2D,matrix(x))[,,1] - scx <- solve(sqrt(FI),L2Dx) + scx <- distr::solve(sqrt(FI),L2Dx) xD <- fct(distance)(scx) cex.pts <- if(is.null(mcl[["cex.pts"]])){ if(is.null(mcl[["cex"]])){ Modified: branches/robast-1.2/pkg/RobAStBase/R/returnlevelplot.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/returnlevelplot.R 2018-08-10 22:49:40 UTC (rev 1120) +++ branches/robast-1.2/pkg/RobAStBase/R/returnlevelplot.R 2018-08-11 13:54:52 UTC (rev 1121) @@ -99,7 +99,7 @@ FI <- PosSemDefSymmMatrix(FisherInfo(y at center)) L2D <- as(diag(nrow(FI)) %*% L2deriv(y at center), "EuclRandVariable") L2Dx <- evalRandVar(L2D,matrix(x))[,,1] - scx <- solve(sqrt(FI),L2Dx) + scx <- distr::solve(sqrt(FI),L2Dx) xD <- fct(distance)(scx) cex.pts <- if(is.null(mcl[["cex.pts"]])){ if(is.null(mcl[["cex"]])){ Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-10 22:49:40 UTC (rev 1120) +++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-11 13:54:52 UTC (rev 1121) @@ -65,6 +65,8 @@ this uses helper function .addTime to produce a matrix with detailed timing information which can be read out as argument ) -- it is in package system folder "chkTimeCode" (in inst/chkTimeCode in r-forge) ++ now specified that we want to use distr::solve ++ now generateIC.fct produces vectorized functions (can now use useApply=FALSE in E()) ####################################### version 1.1 Modified: branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd 2018-08-10 22:49:40 UTC (rev 1120) +++ branches/robast-1.2/pkg/RobAStBase/man/ALEstimate-class.Rd 2018-08-11 13:54:52 UTC (rev 1121) @@ -10,6 +10,8 @@ \alias{pIC,MLEstimate-method} \alias{pIC,CvMMDEstimate-method} \alias{pIC,MCALEstimate-method} +\alias{pIC,ML.ALEstimate-method} +\alias{pIC,CvMMD.ALEstimate-method} \alias{asbias} \alias{asbias,ALEstimate-method} \alias{show,ALEstimate-method} From noreply at r-forge.r-project.org Sat Aug 11 16:34:07 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 16:34:07 +0200 (CEST) Subject: [Robast-commits] r1122 - in branches/robast-1.2/pkg/ROptEst: R inst Message-ID: <20180811143407.1C448187FB6@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 16:34:06 +0200 (Sat, 11 Aug 2018) New Revision: 1122 Modified: branches/robast-1.2/pkg/ROptEst/R/LowerCaseMultivariate.R branches/robast-1.2/pkg/ROptEst/R/getComp.R branches/robast-1.2/pkg/ROptEst/R/getInfLM.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asBias.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asCov.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asGRisk.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asHampel.R branches/robast-1.2/pkg/ROptEst/R/getInfStand.R branches/robast-1.2/pkg/ROptEst/R/getInfV.R branches/robast-1.2/pkg/ROptEst/R/getMaxIneff.R branches/robast-1.2/pkg/ROptEst/R/getRadius.R branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R branches/robast-1.2/pkg/ROptEst/R/leastFavorableRadius.R branches/robast-1.2/pkg/ROptEst/R/optRisk.R branches/robast-1.2/pkg/ROptEst/R/radiusMinimaxIC.R branches/robast-1.2/pkg/ROptEst/R/roptest.new.R branches/robast-1.2/pkg/ROptEst/R/updateNorm.R branches/robast-1.2/pkg/ROptEst/inst/NEWS Log: [ROptEst] branch 1.2 + now specified that we want to use distr::solve + internal function .getComp, determining by symmetry slots which entries in LMs a and A have to be computed, now fills the lower triangle of A with FALSE (was not used so far, but can be used in a faster computation method for checkIC makeIC to determine whether it is cleverer to integrate in k or in p space) + begun with speedup code for checkIC makeIC Modified: branches/robast-1.2/pkg/ROptEst/R/LowerCaseMultivariate.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/LowerCaseMultivariate.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/LowerCaseMultivariate.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -9,7 +9,7 @@ w <- new("HampelWeight") if(is.null(z.start)) z.start <- numeric(ncol(trafo)) - if(is.null(A.start)) A.start <- trafo%*%solve(as.matrix(Finfo)) + if(is.null(A.start)) A.start <- trafo%*%distr::solve(as.matrix(Finfo)) if(is.null(A.comp)) A.comp <- matrix(TRUE, nrow = nrow(trafo), ncol = ncol(trafo)) if(is.null(z.comp)) @@ -109,7 +109,7 @@ w <- new("BdStWeight") k <- ncol(trafo) - if(is.null(A.start)) A.start <- trafo%*%solve(Finfo) + if(is.null(A.start)) A.start <- trafo%*%distr::solve(Finfo) pos.fct <- function(x, L2, stand){ X <- evalRandVar(L2, as.matrix(x))[,,1] Modified: branches/robast-1.2/pkg/ROptEst/R/getComp.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getComp.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/getComp.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -18,7 +18,7 @@ A.comp[i,j] <- FALSE } } - A.comp[col(A.comp) < row(A.comp)] <- A.comp[col(A.comp) > row(A.comp)] + A.comp[col(A.comp) < row(A.comp)] <- FALSE return(list(A.comp = A.comp, z.comp = z.comp)) } Modified: branches/robast-1.2/pkg/ROptEst/R/getInfLM.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfLM.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/getInfLM.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -47,7 +47,7 @@ # print(c("z"=z)) if(is(neighbor,"TotalVarNeighborhood")){ a <- z - z <- as.numeric(solve(A,a)) + z <- as.numeric(distr::solve(A,a)) zc <- numeric(ncol(trafo)) }else if(is(neighbor,"ContNeighborhood")) { zc <- z @@ -159,7 +159,7 @@ # print(list(A0vecA,A0,a0)) - z0 <- as.numeric(solve(A0,a0)) + z0 <- as.numeric(distr::solve(A0,a0)) std0 <- stdC w0 <- w1 risk0 <- risk1 Modified: branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -132,9 +132,9 @@ stop("Not yet implemented") ## non-standard norms - FI1 <- trafo%*%solve(Finfo) + FI1 <- trafo%*%distr::solve(Finfo) FI0 <- FI1%*%t(trafo) - FI <- solve(FI0) + FI <- distr::solve(FI0) if(is(normtype,"InfoNorm") || is(normtype,"SelfNorm") ){ QuadForm(normtype) <- PosSemDefSymmMatrix(FI) normtype(risk) <- normtype Modified: branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asBias.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asBias.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asBias.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -82,7 +82,7 @@ } # } - FI <- solve(trafo%*%solve(Finfo)%*%t(trafo)) + FI <- distr::solve(trafo%*%distr::solve(Finfo)%*%t(trafo)) if(is(normtype,"QFNorm")) {QuadForm(normtype) <- PosSemDefSymmMatrix(FI); normtype(risk) <- normtype} Modified: branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asCov.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asCov.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asCov.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -10,7 +10,7 @@ verbose <- getRobAStBaseOption("all.verbose") info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) b <- abs(as.vector(A))*max(abs(q.l(L2deriv)(1)),abs(q.l(L2deriv)(0))) @@ -43,7 +43,7 @@ verbose <- getRobAStBaseOption("all.verbose") info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) b <- abs(as.vector(A))*(q.l(L2deriv)(1)-q.l(L2deriv)(0)) a <- -abs(as.vector(A))*q.l(L2deriv)(0) asCov <- A %*% t(trafo) @@ -80,7 +80,7 @@ if(! Cont && p>1) stop("Not yet implemented") info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) IC <- A %*% L2deriv if(is(Distr, "UnivariateDistribution")){ lower <- ifelse(is.finite(q.l(Distr)(0)), q.l(Distr)(1e-8), q.l(Distr)(0)) Modified: branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asGRisk.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asGRisk.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asGRisk.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -21,7 +21,7 @@ k <- ncol(trafo) ## non-standard norms - FI <- solve(trafo%*%matrix(1/Finfo,1,1)%*%t(trafo)) + FI <- distr::solve(trafo%*%matrix(1/Finfo,1,1)%*%t(trafo)) if(is(normtype,"InfoNorm") || is(normtype,"SelfNorm") ){ QuadForm(normtype) <- PosSemDefSymmMatrix(FI) normtype(risk) <- normtype @@ -221,7 +221,7 @@ stop("Not yet implemented") ## non-standard norms - FI <- solve(trafo%*%solve(Finfo)%*%t(trafo)) + FI <- distr::solve(trafo%*%distr::solve(Finfo)%*%t(trafo)) if(is(normtype,"InfoNorm") || is(normtype,"SelfNorm") ){ QuadForm(normtype) <- PosSemDefSymmMatrix(FI) normtype(risk) <- normtype @@ -232,7 +232,7 @@ ## starting values if(is.null(z.start)) z.start <- numeric(k) - if(is.null(A.start)) A.start <- trafo %*% solve(Finfo) + if(is.null(A.start)) A.start <- trafo %*% distr::solve(Finfo) a.start <- as.numeric(A.start %*% z.start) ## sort out upper solution if radius = 0 @@ -288,7 +288,7 @@ verbose = verbose) lower <- lowBerg$b} #if(is.null(upper)) - upper <- 5*max(solve(Finfo)) + upper <- 5*max(distr::solve(Finfo)) OptIterCall <- numeric(1) Cov <- 0 @@ -510,7 +510,7 @@ b <- res$b res <- c(res, list(biastype = biastype, normtype = normtype)) if(!is(risk, "asMSE")){ - FI <- trafo%*%solve(Finfo)%*%t(trafo) + FI <- trafo%*%distr::solve(Finfo)%*%t(trafo) FI <- sum(diag(QuadForm %*% FI)) Risk <- getAsRisk(risk = risk, L2deriv = L2deriv, neighbor = neighbor, biastype = biastype, normtype = normtype, @@ -549,7 +549,7 @@ verbose = verbose) normtype(risk) <- res$normtype if(!is(risk, "asMSE")){ - FI <- trafo%*%solve(Finfo)%*%t(trafo) + FI <- trafo%*%distr::solve(Finfo)%*%t(trafo) FI <- sum(diag(QuadForm %*% FI)) Risk <- getAsRisk(risk = risk, L2deriv = L2deriv, neighbor = neighbor, biastype = biastype(risk), normtype = normtype(risk), @@ -665,14 +665,14 @@ # if( is(neighbor,"TotalVarNeighborhood") && p>1) # stop("Not yet implemented") # -# FI <- solve(trafo%*%solve(Finfo)%*%t(trafo)) +# FI <- distr::solve(trafo%*%distr::solve(Finfo)%*%t(trafo)) # if(is(normtype,"InfoNorm") || is(normtype,"SelfNorm") ) # {QuadForm(normtype) <- PosSemDefSymmMatrix(FI); # normtype(risk) <- normtype} # QF <- if(is(normtype,"QFNorm")) QuadForm(normtype) else diag(nrow(trafo)) # # if(is.null(z.start)) z.start <- numeric(ncol(trafo)) -# if(is.null(A.start)) A.start <- trafo %*% solve(Finfo) +# if(is.null(A.start)) A.start <- trafo %*% distr::solve(Finfo) # # radius <- neighbor at radius # if(identical(all.equal(radius, 0), TRUE)){ @@ -791,7 +791,7 @@ # # if(is(neighbor,"TotalVarNeighborhood")){ # a <- z -# z <- solve(A,a) +# z <- distr::solve(A,a) # zc <- numeric(ncol(trafo)) # }else if(is(neighbor,"ContNeighborhood")) { # zc <- z Modified: branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asHampel.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asHampel.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asHampel.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -170,7 +170,7 @@ stop("Not yet implemented") ## non-standard norms - FI <- solve(trafo%*%solve(Finfo)%*%t(trafo)) + FI <- distr::solve(trafo%*%distr::solve(Finfo)%*%t(trafo)) if(is(normtype,"InfoNorm") || is(normtype,"SelfNorm") ){ QuadForm(normtype) <- PosSemDefSymmMatrix(FI) normtype(risk) <- normtype @@ -180,7 +180,7 @@ ## starting values if(is.null(z.start)) z.start <- numeric(k) - if(is.null(A.start)) A.start <- trafo%*%solve(Finfo) + if(is.null(A.start)) A.start <- trafo%*%distr::solve(Finfo) a.start <- as.numeric(A.start %*% z.start) ## initialize @@ -334,7 +334,7 @@ tol, QuadForm, verbose, nrvalpts, warn){ if(missing(warn)|| is.null(warn)) warn <- FALSE - ClassIC <- trafo %*% solve(Finfo) %*% L2deriv + ClassIC <- trafo %*% distr::solve(Finfo) %*% L2deriv lower.x <- getLow(Distr) upper.x <- getUp(Distr) @@ -405,7 +405,7 @@ # if(! is(neighbor,"ContNeighborhood") && p>1) # stop("Not yet implemented") # -# FI <- solve(trafo%*%solve(Finfo)%*%t(trafo)) +# FI <- distr::solve(trafo%*%distr::solve(Finfo)%*%t(trafo)) # if(is(normtype,"InfoNorm") || is(normtype,"SelfNorm") ) # {QuadForm(normtype) <- PosSemDefSymmMatrix(FI); normtype(risk) <- normtype} # @@ -416,7 +416,7 @@ # b <- risk at bound # # if(checkBounds){ -# ClassIC <- trafo %*% solve(Finfo) %*% L2deriv +# ClassIC <- trafo %*% distr::solve(Finfo) %*% L2deriv # lower.x <- getLow(Distr) # upper.x <- getUp(Distr) # x <- seq(from = lower.x, to = upper.x, length = 5000) @@ -502,7 +502,7 @@ # # if(is(neighbor,"TotalVarNeighborhood")){ # a <- z -# z <- solve(A,a) +# z <- distr::solve(A,a) # zc <- numeric(ncol(trafo)) # }else if(is(neighbor,"ContNeighborhood")) { # zc <- z Modified: branches/robast-1.2/pkg/ROptEst/R/getInfStand.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfStand.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/getInfStand.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -42,7 +42,7 @@ erg[col(erg) < row(erg)] <- erg[col(erg) > row(erg)] - return(trafo %*% solve(erg)) + return(trafo %*% distr::solve(erg)) }) ############################################################################### ## standardizing constant for one-sided bias Modified: branches/robast-1.2/pkg/ROptEst/R/getInfV.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfV.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/getInfV.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -36,12 +36,12 @@ (weight(w)(evalRandVar(L2deriv, as.matrix(x)) [,,1]))^2 } - .solve <- function(A0, b0) solve(A0,b0) - if(is.matrix(stand)){ - if(nrow(stand)!=ncol(stand)) - .solve <- function(A0,b0) MASS::ginv(A0)%*%b0 - } - cent0 <- .solve(stand, cent) +# .solve <- function(A0, b0) distr::solve(A0,b0) +# if(is.matrix(stand)){ +# if(nrow(stand)!=ncol(stand)) +# .solve <- function(A0,b0) MASS::ginv(A0)%*%b0 +# } + cent0 <- distr::solve(stand, cent, generalized = TRUE) integrandV <- function(x, L2.i, L2.j, i, j){ Modified: branches/robast-1.2/pkg/ROptEst/R/getMaxIneff.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getMaxIneff.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/getMaxIneff.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -21,7 +21,7 @@ Finfo <- L2Fam at FisherInfo L2derivDim <- numberOfMaps(L2Fam at L2deriv) - FI0 <- trafo%*%solve(Finfo)%*%t(trafo) + FI0 <- trafo%*%distr::solve(Finfo)%*%t(trafo) std <- if(is(normtype,"QFNorm")) QuadForm(normtype) else diag(nrow(trafo)) s0 <- sum(diag(std%*%FI0)) Modified: branches/robast-1.2/pkg/ROptEst/R/getRadius.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getRadius.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/getRadius.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -23,7 +23,7 @@ }else{ L2deriv <- diag(dimension(L2Fam at L2deriv)) %*% L2Fam at L2deriv } - z <- solve(stand(IC),cent(IC)) + z <- distr::solve(stand(IC),cent(IC)) r <- getInfRad(clip = clip(IC), L2deriv = L2deriv, risk = risk, neighbor = neighbor, biastype = biastype(risk), Distr = L2Fam at distribution, stand = stand(IC), Modified: branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -101,7 +101,7 @@ LM0$Aw <- LM0$A <- (Aa+Ai+t(Ai)+t(Aa))/4 ai <- Ai %*% zi LM0$a <- (ai+aa)/2 - LM0$aw <- solve(LM0$A, LM0$a) + LM0$aw <- distr::solve(LM0$A, LM0$a) } .xiMkLM <- function(LMset,xi){ Modified: branches/robast-1.2/pkg/ROptEst/R/leastFavorableRadius.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/leastFavorableRadius.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/leastFavorableRadius.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -20,8 +20,8 @@ normtype <- normtype(risk) trafo <- trafo(L2Fam at param) - FI0 <- trafo%*%solve(L2Fam at FisherInfo)%*%t(trafo) - FI <- solve(FI0) + FI0 <- trafo%*%distr::solve(L2Fam at FisherInfo)%*%t(trafo) + FI <- distr::solve(FI0) if(is(normtype,"InfoNorm") || is(normtype,"SelfNorm") ) {QuadForm(normtype) <- PosSemDefSymmMatrix(FI); normtype(risk) <- normtype} Modified: branches/robast-1.2/pkg/ROptEst/R/optRisk.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/optRisk.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/optRisk.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -3,7 +3,7 @@ ############################################################################### setMethod("optRisk", signature(model = "L2ParamFamily", risk = "asCov"), function(model, risk){ - return(list(asCov = solve(model at FisherInfo))) + return(list(asCov = distr::solve(model at FisherInfo))) }) ############################################################################### Modified: branches/robast-1.2/pkg/ROptEst/R/radiusMinimaxIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/radiusMinimaxIC.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/radiusMinimaxIC.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -123,10 +123,10 @@ Finfo <- L2Fam at FisherInfo p <- nrow(trafo) - FI0 <- trafo%*%solve(Finfo)%*%t(trafo) + FI0 <- trafo%*%distr::solve(Finfo)%*%t(trafo) if(is(normtype,"InfoNorm") || is(normtype,"SelfNorm") ) - {QuadForm(normtype) <- PosSemDefSymmMatrix(solve(FI0)); + {QuadForm(normtype) <- PosSemDefSymmMatrix(distr::solve(FI0)); normtype(risk) <- normtype} std <- if(is(normtype,"QFNorm")) QuadForm(normtype) else diag(p) loRisk <- sum(diag(std%*%FI0)) Modified: branches/robast-1.2/pkg/ROptEst/R/roptest.new.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -318,7 +318,7 @@ es.list0$fsCor <- eval(es.list0$fsCor) es.list0$OptOrIter <- eval(es.list0$OptOrIter) - if(debug) {cat("\n\n\n::::\n\n") + if(debug) {cat("\n\n\n:::: args for getStartIC\n\n") argList <- c(list(model=L2Fam,risk=risk,neighbor=neighbor, withEvalAsVar = withEvalAsVarSIC, withMakeIC = withMakeICSIC, modifyICwarn = modifyICwarnSIC), es.list0) @@ -337,7 +337,7 @@ if(debug){ - ICstart <- "BUL" + ICstart <- "ICstart-result-debug" argList <- list(x, IC = ICstart, start = initial.est, steps = steps, useLast = kStepCtrl$useLast, withUpdateInKer = kStepCtrl$withUpdateInKer, Modified: branches/robast-1.2/pkg/ROptEst/R/updateNorm.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/updateNorm.R 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/R/updateNorm.R 2018-08-11 14:34:06 UTC (rev 1122) @@ -6,7 +6,7 @@ {Cv <- getInfV(L2deriv = L2, neighbor = neighbor, biastype = biastype, Distr = Distr, V.comp = V.comp, cent = cent, stand = stand, w = w) - QuadForm(normtype) <- PosSemDefSymmMatrix(solve(Cv)) + QuadForm(normtype) <- PosSemDefSymmMatrix(distr::solve(Cv)) normtype}) Modified: branches/robast-1.2/pkg/ROptEst/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-11 13:54:52 UTC (rev 1121) +++ branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-11 14:34:06 UTC (rev 1122) @@ -29,6 +29,11 @@ + inserted code for time checking (which is inactive usually; only if in kStepEstimator.R in RobAStBase, the respective ##-t-## lines are de-commented the timings are visible as attribute "kStepTimings" in the result of roptest ...) ++ now specified that we want to use distr::solve ++ internal function .getComp, determining by symmetry slots which entries in LMs a and A + have to be computed, now fills the lower triangle of A with FALSE (was not used so far, + but can be used in a faster computation method for checkIC makeIC to determine whether + it is cleverer to integrate in k or in p space) ####################################### version 1.1 From noreply at r-forge.r-project.org Sat Aug 11 16:45:33 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 16:45:33 +0200 (CEST) Subject: [Robast-commits] r1123 - branches/robast-1.2/pkg/RobAStBase/R Message-ID: <20180811144533.AF402187A74@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 16:45:33 +0200 (Sat, 11 Aug 2018) New Revision: 1123 Modified: branches/robast-1.2/pkg/RobAStBase/R/optIC.R Log: [RobAStBase] branch 2.8: overlooked one instance of solve without distr::solve Modified: branches/robast-1.2/pkg/RobAStBase/R/optIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/optIC.R 2018-08-11 14:34:06 UTC (rev 1122) +++ branches/robast-1.2/pkg/RobAStBase/R/optIC.R 2018-08-11 14:45:33 UTC (rev 1123) @@ -4,7 +4,7 @@ setMethod("optIC", signature(model = "L2ParamFamily", risk = "asCov"), function(model, risk, withMakeIC = FALSE){ Curve <- as((trafo(model at param) %*% distr::solve(model at FisherInfo)) %*% model at L2deriv, "EuclRandVariable") - asCov <- trafo(model at param) %*% solve(model at FisherInfo) %*% t(trafo(model at param)) + asCov <- trafo(model at param) %*% distr::solve(model at FisherInfo) %*% t(trafo(model at param)) modifyIC <- function(L2Fam, IC, withMakeIC=FALSE){ optIC(L2Fam, asCov()) } L2call <- model at fam.call From noreply at r-forge.r-project.org Sat Aug 11 16:46:52 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 16:46:52 +0200 (CEST) Subject: [Robast-commits] r1124 - branches/robast-1.2/pkg/ROptEstOld/R Message-ID: <20180811144652.A9C53187A74@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 16:46:52 +0200 (Sat, 11 Aug 2018) New Revision: 1124 Modified: branches/robast-1.2/pkg/ROptEstOld/R/getInfRobIC_asCov.R branches/robast-1.2/pkg/ROptEstOld/R/getInfRobIC_asHampel.R branches/robast-1.2/pkg/ROptEstOld/R/getInfStand.R branches/robast-1.2/pkg/ROptEstOld/R/infoPlot.R branches/robast-1.2/pkg/ROptEstOld/R/leastFavorableRadius.R branches/robast-1.2/pkg/ROptEstOld/R/optIC.R branches/robast-1.2/pkg/ROptEstOld/R/optRisk.R branches/robast-1.2/pkg/ROptEstOld/R/radiusMinimaxIC.R Log: [ROptEstOld] branch 1.2 + now specified that we want to use distr::solve Modified: branches/robast-1.2/pkg/ROptEstOld/R/getInfRobIC_asCov.R =================================================================== --- branches/robast-1.2/pkg/ROptEstOld/R/getInfRobIC_asCov.R 2018-08-11 14:45:33 UTC (rev 1123) +++ branches/robast-1.2/pkg/ROptEstOld/R/getInfRobIC_asCov.R 2018-08-11 14:46:52 UTC (rev 1124) @@ -6,7 +6,7 @@ neighbor = "ContNeighborhood"), function(L2deriv, risk, neighbor, Finfo, trafo){ info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) b <- abs(as.vector(A))*max(abs(q.l(L2deriv)(1)),abs(q.l(L2deriv)(0))) Risk <- list(asCov = A %*% t(trafo), asBias = b) @@ -17,7 +17,7 @@ neighbor = "TotalVarNeighborhood"), function(L2deriv, risk, neighbor, Finfo, trafo){ info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) b <- abs(as.vector(A))*(q.l(L2deriv)(1)-q.l(L2deriv)(0)) Risk <- list(asCov = A %*% t(trafo), asBias = b) @@ -28,7 +28,7 @@ neighbor = "ContNeighborhood"), function(L2deriv, risk, neighbor, Distr, Finfo, trafo){ info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) IC <- A %*% L2deriv if(is(Distr, "UnivariateDistribution")){ lower <- ifelse(is.finite(q.l(Distr)(0)), q.l(Distr)(1e-8), q.l(Distr)(0)) Modified: branches/robast-1.2/pkg/ROptEstOld/R/getInfRobIC_asHampel.R =================================================================== --- branches/robast-1.2/pkg/ROptEstOld/R/getInfRobIC_asHampel.R 2018-08-11 14:45:33 UTC (rev 1123) +++ branches/robast-1.2/pkg/ROptEstOld/R/getInfRobIC_asHampel.R 2018-08-11 14:46:52 UTC (rev 1124) @@ -69,7 +69,7 @@ if(is.null(z.start)) z.start <- numeric(ncol(trafo)) if(is.null(A.start)) A.start <- trafo - ClassIC <- trafo %*% solve(Finfo) %*% L2deriv + ClassIC <- trafo %*% distr::solve(Finfo) %*% L2deriv lower <- q.l(Distr)(getdistrOption("TruncQuantile")) upper <- q.l(Distr)(1-getdistrOption("TruncQuantile")) x <- seq(from = lower, to = upper, by = 0.01) Modified: branches/robast-1.2/pkg/ROptEstOld/R/getInfStand.R =================================================================== --- branches/robast-1.2/pkg/ROptEstOld/R/getInfStand.R 2018-08-11 14:45:33 UTC (rev 1123) +++ branches/robast-1.2/pkg/ROptEstOld/R/getInfStand.R 2018-08-11 14:46:52 UTC (rev 1124) @@ -46,5 +46,5 @@ erg[col(erg) < row(erg)] <- erg[col(erg) > row(erg)] - return(trafo %*% solve(erg)) + return(trafo %*% distr::solve(erg)) }) Modified: branches/robast-1.2/pkg/ROptEstOld/R/infoPlot.R =================================================================== --- branches/robast-1.2/pkg/ROptEstOld/R/infoPlot.R 2018-08-11 14:45:33 UTC (rev 1123) +++ branches/robast-1.2/pkg/ROptEstOld/R/infoPlot.R 2018-08-11 14:46:52 UTC (rev 1124) @@ -22,7 +22,7 @@ trafo <- L2Fam at param@trafo dims <- nrow(trafo) - classIC <- as(trafo %*% solve(L2Fam at FisherInfo) %*% L2Fam at L2deriv, "EuclRandVariable") + classIC <- as(trafo %*% distr::solve(L2Fam at FisherInfo) %*% L2Fam at L2deriv, "EuclRandVariable") absInfoClass <- classIC %*% classIC absInfoClass <- sapply(x.vec, absInfoClass at Map[[1]]) IC1 <- as(diag(dims) %*% object at Curve, "EuclRandVariable") Modified: branches/robast-1.2/pkg/ROptEstOld/R/leastFavorableRadius.R =================================================================== --- branches/robast-1.2/pkg/ROptEstOld/R/leastFavorableRadius.R 2018-08-11 14:45:33 UTC (rev 1123) +++ branches/robast-1.2/pkg/ROptEstOld/R/leastFavorableRadius.R 2018-08-11 14:46:52 UTC (rev 1124) @@ -109,7 +109,7 @@ trafo <- L2Fam at param@trafo if(identical(all.equal(loRad, 0), TRUE)){ loRad <- 0 - loRisk <- sum(diag(solve(L2Fam at FisherInfo))) + loRisk <- sum(diag(distr::solve(L2Fam at FisherInfo))) }else{ neighbor at radius <- loRad resLo <- getInfRobIC(L2deriv = L2deriv, neighbor = neighbor, risk = risk, Modified: branches/robast-1.2/pkg/ROptEstOld/R/optIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEstOld/R/optIC.R 2018-08-11 14:45:33 UTC (rev 1123) +++ branches/robast-1.2/pkg/ROptEstOld/R/optIC.R 2018-08-11 14:46:52 UTC (rev 1124) @@ -3,8 +3,8 @@ ############################################################################### setMethod("optIC", signature(model = "L2ParamFamily", risk = "asCov"), function(model, risk){ - Curve <- as((model at param@trafo %*% solve(model at FisherInfo)) %*% model at L2deriv, "EuclRandVariable") - asCov <- model at param@trafo %*% solve(model at FisherInfo) %*% t(model at param@trafo) + Curve <- as((model at param@trafo %*% distr::solve(model at FisherInfo)) %*% model at L2deriv, "EuclRandVariable") + asCov <- model at param@trafo %*% distr::solve(model at FisherInfo) %*% t(model at param@trafo) return(IC( name = paste("Classical optimal influence curve for", model at name), Modified: branches/robast-1.2/pkg/ROptEstOld/R/optRisk.R =================================================================== --- branches/robast-1.2/pkg/ROptEstOld/R/optRisk.R 2018-08-11 14:45:33 UTC (rev 1123) +++ branches/robast-1.2/pkg/ROptEstOld/R/optRisk.R 2018-08-11 14:46:52 UTC (rev 1124) @@ -3,7 +3,7 @@ ############################################################################### setMethod("optRisk", signature(model = "L2ParamFamily", risk = "asCov"), function(model, risk){ - return(list(asCov = solve(model at FisherInfo))) + return(list(asCov = distr::solve(model at FisherInfo))) }) ############################################################################### Modified: branches/robast-1.2/pkg/ROptEstOld/R/radiusMinimaxIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEstOld/R/radiusMinimaxIC.R 2018-08-11 14:45:33 UTC (rev 1123) +++ branches/robast-1.2/pkg/ROptEstOld/R/radiusMinimaxIC.R 2018-08-11 14:46:52 UTC (rev 1124) @@ -105,7 +105,7 @@ if(identical(all.equal(loRad, 0), TRUE)){ loRad <- 0 - loRisk <- sum(diag(solve(L2Fam at FisherInfo))) + loRisk <- sum(diag(distr::solve(L2Fam at FisherInfo))) }else{ neighbor at radius <- loRad resLo <- getInfRobIC(L2deriv = L2deriv, neighbor = neighbor, risk = risk, From noreply at r-forge.r-project.org Sat Aug 11 16:53:01 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 16:53:01 +0200 (CEST) Subject: [Robast-commits] r1125 - in branches/robast-1.2/pkg: ROptEstOld/inst ROptRegTS/R ROptRegTS/inst Message-ID: <20180811145301.E3DC1189EAE@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 16:53:01 +0200 (Sat, 11 Aug 2018) New Revision: 1125 Modified: branches/robast-1.2/pkg/ROptEstOld/inst/NEWS branches/robast-1.2/pkg/ROptRegTS/R/Av2CondContIC.R branches/robast-1.2/pkg/ROptRegTS/R/getAsRiskRegTS.R branches/robast-1.2/pkg/ROptRegTS/R/getIneffDiff.R branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asBias.R branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asCov.R branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asGRisk_c2.R branches/robast-1.2/pkg/ROptRegTS/R/getInfStandRegTS.R branches/robast-1.2/pkg/ROptRegTS/R/leastFavorableRadius.R branches/robast-1.2/pkg/ROptRegTS/R/optIC.R branches/robast-1.2/pkg/ROptRegTS/R/radiusMinimaxIC.R branches/robast-1.2/pkg/ROptRegTS/inst/NEWS Log: [ROptRegTS] branch 1.2 + now specified that we want to use distr::solve (and updated NEWS in ROptEstOld) Modified: branches/robast-1.2/pkg/ROptEstOld/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/ROptEstOld/inst/NEWS 2018-08-11 14:46:52 UTC (rev 1124) +++ branches/robast-1.2/pkg/ROptEstOld/inst/NEWS 2018-08-11 14:53:01 UTC (rev 1125) @@ -8,6 +8,13 @@ information) ####################################### +version 1.2 +####################################### + +under the hood ++ now specified that we want to use distr::solve + +####################################### version 1.1 ####################################### Modified: branches/robast-1.2/pkg/ROptRegTS/R/Av2CondContIC.R =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/R/Av2CondContIC.R 2018-08-11 14:46:52 UTC (rev 1124) +++ branches/robast-1.2/pkg/ROptRegTS/R/Av2CondContIC.R 2018-08-11 14:53:01 UTC (rev 1125) @@ -29,7 +29,7 @@ ICfct <- vector(mode = "list", length = 1) L2 <- L2Fam at ErrorL2deriv[[1]] k <- dimension(img(L2Fam at RegDistr)) - K.inv <- solve(E(L2Fam at RegDistr, fun = function(x){ x %*% t(x) })) + K.inv <- distr::solve(E(L2Fam at RegDistr, fun = function(x){ x %*% t(x) })) trafo <- L2Fam at param@trafo if(!is.null(d)){ Modified: branches/robast-1.2/pkg/ROptRegTS/R/getAsRiskRegTS.R =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/R/getAsRiskRegTS.R 2018-08-11 14:46:52 UTC (rev 1124) +++ branches/robast-1.2/pkg/ROptRegTS/R/getAsRiskRegTS.R 2018-08-11 14:53:01 UTC (rev 1125) @@ -19,7 +19,7 @@ if(!is.finite(neighbor at radius)) return(list(asMSE = Inf)) else{ - K.inv <- solve(E(Regressor, fun = function(x){ x %*% t(x) })) + K.inv <- distr::solve(E(Regressor, fun = function(x){ x %*% t(x) })) return(list(asMSE = stand * sum(diag(t(trafo) %*% K.inv)))) } }) @@ -178,7 +178,7 @@ K <- E(Regressor, fun = function(x){ x %*% t(x) }) z <- q.l(ErrorL2deriv)(0.5) Eu <- E(ErrorL2deriv, function(x, z){abs(x - z)}, z = z) - b <- sqrt(sum(diag(trafo %*% solve(K) %*% t(trafo))))/Eu + b <- sqrt(sum(diag(trafo %*% distr::solve(K) %*% t(trafo))))/Eu return(list(asBias = b)) }) Modified: branches/robast-1.2/pkg/ROptRegTS/R/getIneffDiff.R =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/R/getIneffDiff.R 2018-08-11 14:46:52 UTC (rev 1124) +++ branches/robast-1.2/pkg/ROptRegTS/R/getIneffDiff.R 2018-08-11 14:53:01 UTC (rev 1125) @@ -90,7 +90,7 @@ trafo = L2Fam at param@trafo, upper = upper.b, maxiter = MaxIter, tol = eps, warn = warn) trafo <- L2Fam at param@trafo - K.inv <- solve(E(L2Fam at RegDistr, fun = function(x){ x %*% t(x) })) + K.inv <- distr::solve(E(L2Fam at RegDistr, fun = function(x){ x %*% t(x) })) ineffLo <- (res$A*sum(diag(t(trafo) %*% K.inv)) - res$b^2*(radius^2-loRad^2))/loRisk if(upRad == Inf) ineffUp <- res$b^2/upRisk Modified: branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asBias.R =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asBias.R 2018-08-11 14:46:52 UTC (rev 1124) +++ branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asBias.R 2018-08-11 14:53:01 UTC (rev 1125) @@ -114,7 +114,7 @@ K <- E(Regressor, fun = function(x){ x %*% t(x) }) z <- q.l(ErrorL2deriv)(0.5) Eu <- E(ErrorL2deriv, function(x, z){abs(x - z)}, z = z) - b <- sqrt(sum(diag(trafo %*% solve(K) %*% t(trafo))))/Eu + b <- sqrt(sum(diag(trafo %*% distr::solve(K) %*% t(trafo))))/Eu if(is(ErrorL2deriv, "AbscontDistribution")){ ws0 <- 0 Modified: branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asCov.R =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asCov.R 2018-08-11 14:46:52 UTC (rev 1124) +++ branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asCov.R 2018-08-11 14:53:01 UTC (rev 1125) @@ -8,7 +8,7 @@ function(ErrorL2deriv, Regressor, risk, neighbor, ErrorL2derivDistrSymm, RegSymm, Finfo, trafo){ info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) b <- max(abs(as.vector(A)))*max(q.l(ErrorL2deriv)(1),abs(q.l(ErrorL2deriv)(0))) if(is(Regressor, "UnivariateDistribution")) b <- b*max(abs(q.l(Regressor)(1)), abs(q.l(Regressor)(0))) @@ -24,7 +24,7 @@ function(ErrorL2deriv, Regressor, risk, neighbor, ErrorL2derivDistrSymm, RegSymm, Finfo, trafo){ info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) b <- abs(as.vector(A))*(q.l(ErrorL2deriv)(1) - q.l(ErrorL2deriv)(0)) b <- b*(abs(q.l(Regressor)(1)) + abs(q.l(Regressor)(0))) Risk <- list(asCov = A %*% t(trafo), asBias = b) @@ -38,7 +38,7 @@ function(ErrorL2deriv, Regressor, risk, neighbor, ErrorL2derivDistrSymm, RegSymm, Finfo, trafo){ info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) b <- max(abs(as.vector(A)))*max(q.l(ErrorL2deriv)(1),abs(q.l(ErrorL2deriv)(0))) if(is(Regressor, "UnivariateDistribution")) b <- b*max(abs(q.l(Regressor)(1)), abs(q.l(Regressor)(0))) @@ -57,7 +57,7 @@ function(ErrorL2deriv, Regressor, risk, neighbor, ErrorL2derivDistrSymm, RegSymm, Finfo, trafo){ info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) b <- abs(as.vector(A))*(q.l(ErrorL2deriv)(1) - q.l(ErrorL2deriv)(0)) if(is(Regressor, "UnivariateDistribution")) b <- b*(abs(q.l(Regressor)(1)) + abs(q.l(Regressor)(0))) @@ -80,7 +80,7 @@ function(ErrorL2deriv, Regressor, risk, neighbor, ErrorL2derivDistrSymm, RegSymm, Finfo, trafo){ info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) b <- max(abs(as.vector(A)))*max(q.l(ErrorL2deriv)(1),abs(q.l(ErrorL2deriv)(0))) if(is(Regressor, "UnivariateDistribution")) b <- b*max(abs(q.l(Regressor)(1)), abs(q.l(Regressor)(0))) @@ -100,7 +100,7 @@ function(ErrorL2deriv, Regressor, risk, neighbor, ErrorL2derivDistrSymm, RegSymm, Finfo, trafo){ info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) b <- max(abs(as.vector(A)))*max(q.l(ErrorL2deriv)(1),abs(q.l(ErrorL2deriv)(0))) if(is(Regressor, "UnivariateDistribution")) b <- b*max(abs(q.l(Regressor)(1)), abs(q.l(Regressor)(0))) @@ -115,7 +115,7 @@ function(ErrorL2deriv, Regressor, risk, neighbor, ErrorL2derivDistrSymm, RegSymm, Finfo, trafo){ info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) b <- max(abs(as.vector(A)))*abs(q.l(ErrorL2deriv)(1) - q.l(ErrorL2deriv)(0)) if(is(Regressor, "UnivariateDistribution")) b <- b*(q.l(Regressor)(1) - q.l(Regressor)(0)) @@ -132,7 +132,7 @@ neighbor = "ContNeighborhood"), function(ErrorL2deriv, Regressor, risk, neighbor, ErrorDistr, Finfo, trafo){ info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) if(is(ErrorDistr, "UnivariateDistribution")){ lower <- ifelse(is.finite(q.l(ErrorDistr)(0)), q.l(ErrorDistr)(1e-8), q.l(ErrorDistr)(0)) @@ -155,7 +155,7 @@ neighbor = "Av1CondContNeighborhood"), function(ErrorL2deriv, Regressor, risk, neighbor, ErrorDistr, Finfo, trafo){ info <- c("optimal IC in sense of Cramer-Rao bound") - A <- trafo %*% solve(Finfo) + A <- trafo %*% distr::solve(Finfo) if(is(ErrorDistr, "UnivariateDistribution")){ lower <- ifelse(is.finite(q.l(ErrorDistr)(0)), q.l(ErrorDistr)(1e-8), q.l(ErrorDistr)(0)) Modified: branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asGRisk_c2.R =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asGRisk_c2.R 2018-08-11 14:46:52 UTC (rev 1124) +++ branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asGRisk_c2.R 2018-08-11 14:53:01 UTC (rev 1125) @@ -72,7 +72,7 @@ A <- getInfStandRegTS(ErrorL2deriv = ErrorL2deriv, Regressor = Regressor, neighbor = neighbor, z.comp = z.comp, clip = c0, cent = z, stand = A, trafo = trafo) - b <- c0*A*sqrt(sum(diag(solve(E(Regressor, fun = function(x){ x %*% t(x) }))))) + b <- c0*A*sqrt(sum(diag(distr::solve(E(Regressor, fun = function(x){ x %*% t(x) }))))) info <- paste("optimally robust IC for", sQuote(class(risk)[1])) Risk <- getAsRiskRegTS(risk = risk, ErrorL2deriv = ErrorL2deriv, Modified: branches/robast-1.2/pkg/ROptRegTS/R/getInfStandRegTS.R =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/R/getInfStandRegTS.R 2018-08-11 14:46:52 UTC (rev 1124) +++ branches/robast-1.2/pkg/ROptRegTS/R/getInfStandRegTS.R 2018-08-11 14:53:01 UTC (rev 1125) @@ -92,7 +92,7 @@ res <- E(Regressor, Afct, clip = clip, stand = stand, D1 = ErrorL2deriv) } - return(trafo %*% solve(res)) + return(trafo %*% distr::solve(res)) }) setMethod("getInfStandRegTS", signature(ErrorL2deriv = "UnivariateDistribution", Regressor = "UnivariateDistribution", @@ -142,7 +142,7 @@ res <- E(Regressor, Afct, clip = clip, stand = stand, D1 = ErrorL2deriv) } - return(trafo %*% solve(res)) + return(trafo %*% distr::solve(res)) }) setMethod("getInfStandRegTS", signature(ErrorL2deriv = "UnivariateDistribution", Regressor = "Distribution", @@ -180,7 +180,7 @@ return((x %*% t(x))*(m2df(D1, cx) - m2df(D1, gx) + gx*m1df(D1, gx) - cx*m1df(D1, cx))) } - return(trafo %*% solve(E(Regressor, Afct, cent = cent, clip = clip, + return(trafo %*% distr::solve(E(Regressor, Afct, cent = cent, clip = clip, stand = stand, D1 = ErrorL2deriv))) }) setMethod("getInfStandRegTS", signature(ErrorL2deriv = "RealRandVariable", @@ -263,7 +263,7 @@ } res[col(res) < row(res)] <- res[col(res) > row(res)] - return(trafo %*% solve(res)) + return(trafo %*% distr::solve(res)) }) setMethod("getInfStandRegTS", signature(ErrorL2deriv = "RealRandVariable", Regressor = "Distribution", @@ -334,5 +334,5 @@ } res[col(res) < row(res)] <- res[col(res) > row(res)] - return(trafo %*% solve(res)) + return(trafo %*% distr::solve(res)) }) Modified: branches/robast-1.2/pkg/ROptRegTS/R/leastFavorableRadius.R =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/R/leastFavorableRadius.R 2018-08-11 14:46:52 UTC (rev 1124) +++ branches/robast-1.2/pkg/ROptRegTS/R/leastFavorableRadius.R 2018-08-11 14:53:01 UTC (rev 1125) @@ -122,7 +122,7 @@ trafo <- L2Fam at param@trafo if(identical(all.equal(loRad, 0), TRUE)){ loRad <- 0 - loRisk <- sum(diag(solve(L2Fam at FisherInfo))) + loRisk <- sum(diag(distr::solve(L2Fam at FisherInfo))) }else{ neighbor at radius <- loRad resLo <- getInfRobRegTypeIC(ErrorL2deriv = ErrorL2deriv, Modified: branches/robast-1.2/pkg/ROptRegTS/R/optIC.R =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/R/optIC.R 2018-08-11 14:46:52 UTC (rev 1124) +++ branches/robast-1.2/pkg/ROptRegTS/R/optIC.R 2018-08-11 14:53:01 UTC (rev 1125) @@ -3,7 +3,7 @@ ############################################################################### setMethod("optIC", signature(model = "L2RegTypeFamily", risk = "asCov"), function(model, risk){ - Curve <- as((model at param@trafo %*% solve(model at FisherInfo)) %*% model at L2deriv, "EuclRandVariable") + Curve <- as((model at param@trafo %*% distr::solve(model at FisherInfo)) %*% model at L2deriv, "EuclRandVariable") return(IC( name = paste("Classical optimal influence curve for", model at name), CallL2Fam = call("L2RegTypeFamily", @@ -24,7 +24,7 @@ ErrorL2derivDistrSymm = model at ErrorL2derivDistrSymm, FisherInfo = model at FisherInfo), Curve = EuclRandVarList(Curve), - Risks = list(asCov = model at param@trafo %*% solve(model at FisherInfo) %*% t(model at param@trafo)), + Risks = list(asCov = model at param@trafo %*% distr::solve(model at FisherInfo) %*% t(model at param@trafo)), Infos = matrix(c("optIC", "optimal IC in sense of Cramer-Rao bound"), ncol = 2, dimnames = list(character(0), c("method", "message"))))) }) Modified: branches/robast-1.2/pkg/ROptRegTS/R/radiusMinimaxIC.R =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/R/radiusMinimaxIC.R 2018-08-11 14:46:52 UTC (rev 1124) +++ branches/robast-1.2/pkg/ROptRegTS/R/radiusMinimaxIC.R 2018-08-11 14:53:01 UTC (rev 1125) @@ -26,7 +26,7 @@ if(identical(all.equal(loRad, 0), TRUE)){ loRad <- 0 - loRisk <- sum(diag(solve(L2Fam at FisherInfo))) + loRisk <- sum(diag(distr::solve(L2Fam at FisherInfo))) }else{ neighbor at radius <- loRad resLo <- getInfRobRegTypeIC(ErrorL2deriv = L2Fam at ErrorL2derivDistr[[1]], @@ -118,7 +118,7 @@ if(identical(all.equal(loRad, 0), TRUE)){ loRad <- 0 - loRisk <- sum(diag(solve(L2Fam at FisherInfo))) + loRisk <- sum(diag(distr::solve(L2Fam at FisherInfo))) }else{ neighbor at radius <- loRad resLo <- getInfRobRegTypeIC(ErrorL2deriv = ErrorL2deriv, Modified: branches/robast-1.2/pkg/ROptRegTS/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/ROptRegTS/inst/NEWS 2018-08-11 14:46:52 UTC (rev 1124) +++ branches/robast-1.2/pkg/ROptRegTS/inst/NEWS 2018-08-11 14:53:01 UTC (rev 1125) @@ -7,6 +7,13 @@ to ease updating "depends" information) ####################################### +version 1.2 +####################################### + +under the hood ++ now specified that we want to use distr::solve + +####################################### version 1.1 ####################################### From noreply at r-forge.r-project.org Sat Aug 11 16:56:46 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 16:56:46 +0200 (CEST) Subject: [Robast-commits] r1126 - in branches/robast-1.2/pkg/RobRex: R inst Message-ID: <20180811145646.6BBFF187FA2@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 16:56:46 +0200 (Sat, 11 Aug 2018) New Revision: 1126 Modified: branches/robast-1.2/pkg/RobRex/R/rgsOptIC_AL.R branches/robast-1.2/pkg/RobRex/R/rgsOptIC_ALc.R branches/robast-1.2/pkg/RobRex/R/rgsOptIC_ALs.R branches/robast-1.2/pkg/RobRex/R/rgsOptIC_M.R branches/robast-1.2/pkg/RobRex/R/rgsOptIC_MK.R branches/robast-1.2/pkg/RobRex/inst/NEWS Log: [RobRex] branch 1.2 + now specified that we want to use distr::solve Modified: branches/robast-1.2/pkg/RobRex/R/rgsOptIC_AL.R =================================================================== --- branches/robast-1.2/pkg/RobRex/R/rgsOptIC_AL.R 2018-08-11 14:53:01 UTC (rev 1125) +++ branches/robast-1.2/pkg/RobRex/R/rgsOptIC_AL.R 2018-08-11 14:56:46 UTC (rev 1126) @@ -92,7 +92,7 @@ .ALrgsGetAz <- function(K, b, A.rg, z.sc, A.sc){ A.rg1 <- E(K, .ALrgsGetArg, b = b, A.rg = A.rg, z.sc = z.sc, A.sc = A.sc) - A.rg <- solve(A.rg1) + A.rg <- distr::solve(A.rg1) A.sc1 <- E(K, .ALrgsGetAsc, b = b, A.rg = A.rg, z.sc = z.sc, A.sc = A.sc) @@ -139,7 +139,7 @@ A.sc <- A.sc.start; z.sc <- a.sc.start/A.sc + 1 if(missing(A.rg.start)) - A.rg <- solve(Reg2Mom) + A.rg <- distr::solve(Reg2Mom) else A.rg <- A.rg.start Modified: branches/robast-1.2/pkg/RobRex/R/rgsOptIC_ALc.R =================================================================== --- branches/robast-1.2/pkg/RobRex/R/rgsOptIC_ALc.R 2018-08-11 14:53:01 UTC (rev 1125) +++ branches/robast-1.2/pkg/RobRex/R/rgsOptIC_ALc.R 2018-08-11 14:56:46 UTC (rev 1126) @@ -88,7 +88,7 @@ for(i in 1:nrow(supp)){ summe <- summe + prob[i]*supp[i,]%*%t(supp[i,])*A.rg1[i] } - A.rg <- solve(summe) + A.rg <- distr::solve(summe) A.sc1 <- apply(z.sc.x, 1, .ALcrgsGetAsc, b = b, A.rg = A.rg, A.sc = A.sc) A.sc <- 1/sum(prob*A.sc1) @@ -141,7 +141,7 @@ else z.sc <- a.sc.start/A.sc + 1 if(missing(A.rg.start)) - A.rg <- solve(Reg2Mom) + A.rg <- distr::solve(Reg2Mom) else A.rg <- A.rg.start Modified: branches/robast-1.2/pkg/RobRex/R/rgsOptIC_ALs.R =================================================================== --- branches/robast-1.2/pkg/RobRex/R/rgsOptIC_ALs.R 2018-08-11 14:53:01 UTC (rev 1125) +++ branches/robast-1.2/pkg/RobRex/R/rgsOptIC_ALs.R 2018-08-11 14:56:46 UTC (rev 1126) @@ -76,7 +76,7 @@ .ALsrgsGetArg <- function(K, b.rg, A.rg){ A.rg1 <- E(K, .ALsrgsGetArg1, b.rg = b.rg, A.rg = A.rg) - return(solve(A.rg1)) + return(distr::solve(A.rg1)) } @@ -104,7 +104,7 @@ "is (numerically) not positive definite") if(missing(A.rg.start)) - A.rg <- solve(Reg2Mom) + A.rg <- distr::solve(Reg2Mom) else A.rg <- A.rg.start @@ -166,8 +166,8 @@ cat("MSE equation for eta.sc:\t", rvgl.sc, "\n") } - k <- dimension(img(K)) - vec.A <- as.vector(A.rg) + k <- dimension(img(K)) + vec.A <- as.vector(A.rg) w <- .ALsrgsGetwrg fct1 <- function(x){ A.rg <- matrix(vec.A, ncol = k) Modified: branches/robast-1.2/pkg/RobRex/R/rgsOptIC_M.R =================================================================== --- branches/robast-1.2/pkg/RobRex/R/rgsOptIC_M.R 2018-08-11 14:53:01 UTC (rev 1125) +++ branches/robast-1.2/pkg/RobRex/R/rgsOptIC_M.R 2018-08-11 14:56:46 UTC (rev 1126) @@ -243,10 +243,10 @@ k <- dimension(img(K)) Gk <- .duplicationMatrix(dimn = k) - Hk <- solve(t(Gk) %*% Gk)%*%t(Gk) + Hk <- distr::solve(t(Gk) %*% Gk)%*%t(Gk) h5 <- Hk %*% h5 %*% Gk - vech.B <- solve(h5) %*% vech.D + vech.B <- distr::solve(h5) %*% vech.D B <- matrix(0, nrow = k , ncol = k) B[row(B) >= col(B)] <- vech.B B[row(B) < col(B)] <- B[row(B) > col(B)] @@ -305,7 +305,7 @@ ############################################################################### .MrgsGetba1a3B <- function(r, K, A, gg, a1, a3, B, bUp, delta, itmax){ C1 <- E(K, .MrgsGetC1, A = A, gg = gg) - C2 <- solve(A) - gg^2*E(K, .MrgsGetC2, A = A, gg = gg) + C2 <- distr::solve(A) - gg^2*E(K, .MrgsGetC2, A = A, gg = gg) C3 <- 1 + 1/gg - gg^2*E(K, .MrgsGetC3, A = A, gg = gg) b <- try(uniroot(.MrgsGetr, lower = gg, upper = bUp, @@ -442,7 +442,7 @@ stop("Regressor is a.e. K concentrated on a conic") if(missing(A.start)) - A <- solve(Reg2Mom) + A <- distr::solve(Reg2Mom) else A <- A.start @@ -474,7 +474,7 @@ if(check){ C1 <- E(K, .MrgsGetC1, A = A, gg = gg) - C2 <- solve(A) - gg^2*E(K, .MrgsGetC2, A = A, gg = gg) + C2 <- distr::solve(A) - gg^2*E(K, .MrgsGetC2, A = A, gg = gg) C3 <- 1 + 1/gg - gg^2*E(K, .MrgsGetC3, A = A, gg = gg) kont1 <- try(E(K, .MrgsGetch1, A = A, gg = gg, b = b, a1 = a1, @@ -506,7 +506,7 @@ else cat("could not determine MSE equation:\n", rvgl ,"\n") } - + w <- .MrgsGetw fct1 <- function(x){ B.mat <- matrix(B, ncol = k) Modified: branches/robast-1.2/pkg/RobRex/R/rgsOptIC_MK.R =================================================================== --- branches/robast-1.2/pkg/RobRex/R/rgsOptIC_MK.R 2018-08-11 14:53:01 UTC (rev 1125) +++ branches/robast-1.2/pkg/RobRex/R/rgsOptIC_MK.R 2018-08-11 14:56:46 UTC (rev 1126) @@ -37,7 +37,7 @@ if(.rgsRegressorCheck(K)) stop("Regressor is a.e. K concentrated on a conic") - A <- solve(Reg2Mom) + A <- distr::solve(Reg2Mom) if(missing(B.start)) B.start <- A %*% A res <- optimize(.MKrgsGetmse, lower = ggLo, upper = ggUp, @@ -54,7 +54,7 @@ if(check){ C1 <- E(K, .MrgsGetC1, A = A, gg = gg) - C2 <- solve(A) - gg^2*E(K, .MrgsGetC2, A = A, gg = gg) + C2 <- distr::solve(A) - gg^2*E(K, .MrgsGetC2, A = A, gg = gg) C3 <- 1 + 1/gg - gg^2*E(K, .MrgsGetC3, A = A, gg = gg) kont1 <- try(E(K, .MrgsGetch1, A = A, gg = gg, b = b, a1 = a1, @@ -86,7 +86,7 @@ else cat("could not determine MSE equation:\n", rvgl ,"\n") } - + w <- .MrgsGetw fct1 <- function(x){ B.mat <- matrix(B, ncol = k) Modified: branches/robast-1.2/pkg/RobRex/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobRex/inst/NEWS 2018-08-11 14:53:01 UTC (rev 1125) +++ branches/robast-1.2/pkg/RobRex/inst/NEWS 2018-08-11 14:56:46 UTC (rev 1126) @@ -8,6 +8,13 @@ information) ####################################### +version 1.2 +####################################### + +under the hood ++ now specified that we want to use distr::solve + +####################################### version 1.1 ####################################### From noreply at r-forge.r-project.org Sat Aug 11 16:59:36 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 16:59:36 +0200 (CEST) Subject: [Robast-commits] r1127 - in branches/robast-1.2/pkg: RobLox/inst RobRex/inst Message-ID: <20180811145936.1BB05187FA2@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 16:59:35 +0200 (Sat, 11 Aug 2018) New Revision: 1127 Modified: branches/robast-1.2/pkg/RobLox/inst/NEWS branches/robast-1.2/pkg/RobRex/inst/NEWS Log: [RobLox,RobRex] branch 2.8 updated NEWS Modified: branches/robast-1.2/pkg/RobLox/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobLox/inst/NEWS 2018-08-11 14:56:46 UTC (rev 1126) +++ branches/robast-1.2/pkg/RobLox/inst/NEWS 2018-08-11 14:59:35 UTC (rev 1127) @@ -8,6 +8,15 @@ information) ####################################### +version 1.2 +####################################### + +under the hood ++ the modifyIC functions gain argument withMakeIC to be consistent with the signature in RobAStBase + (the arg is ignored in the RobLox Code) ++ The warnings as to moved ICs have been condensed + +####################################### version 1.1 ####################################### Modified: branches/robast-1.2/pkg/RobRex/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobRex/inst/NEWS 2018-08-11 14:56:46 UTC (rev 1126) +++ branches/robast-1.2/pkg/RobRex/inst/NEWS 2018-08-11 14:59:35 UTC (rev 1127) @@ -13,6 +13,8 @@ under the hood + now specified that we want to use distr::solve ++ the calls to liesInSupport gain argument "checkFin" for consistency with + the method in distr/distrEx (it is not used in RobRex, though). ####################################### version 1.1 From noreply at r-forge.r-project.org Sun Aug 12 02:07:24 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 02:07:24 +0200 (CEST) Subject: [Robast-commits] r1128 - in branches/robast-1.2/pkg/RobAStBase: . R inst man Message-ID: <20180812000724.E1874187BD2@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 02:07:24 +0200 (Sun, 12 Aug 2018) New Revision: 1128 Added: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE branches/robast-1.2/pkg/RobAStBase/R/IC.R branches/robast-1.2/pkg/RobAStBase/R/getBiasIC.R branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R branches/robast-1.2/pkg/RobAStBase/R/move2bckRefParam.R branches/robast-1.2/pkg/RobAStBase/R/oneStepEstimator.R branches/robast-1.2/pkg/RobAStBase/R/optIC.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS branches/robast-1.2/pkg/RobAStBase/man/ContIC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/ContIC.Rd branches/robast-1.2/pkg/RobAStBase/man/HampIC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/IC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/IC.Rd branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC-class.Rd branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC.Rd branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd branches/robast-1.2/pkg/RobAStBase/man/getBiasIC.Rd branches/robast-1.2/pkg/RobAStBase/man/getBoundedIC.Rd branches/robast-1.2/pkg/RobAStBase/man/getRiskIC.Rd branches/robast-1.2/pkg/RobAStBase/man/internals.Rd branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd branches/robast-1.2/pkg/RobAStBase/man/oneStepEstimator.Rd branches/robast-1.2/pkg/RobAStBase/man/optIC.Rd Log: [RobAStBase] branch 1.2 + particular checkIC methods are now documented in documentation object checkIC (and no longer with class IC); there argument out is documented + checkIC and makeIC now both use helper function .preparedirectCheckMakeIC which allows for extra arguments for E() and integrates coordinate wise with useApply = FALSE to gain speed (code has moved from file IC.R to file CheckMakeIC.R) + several methods (getRiskIC, getBiasIC, getBoundedIC, makeIC, checkIC, modifyIC) gain argument "..." to pass on arguments to E() + new internal constant ..IntegrateArgs which contains the names of all arguments used for integration, i.e., currently, c("lowerTruncQuantile", "upperTruncQuantile", "IQR.fac", "subdivisions", "rel.tol", "abs.tol", "stop.on.error", "order", "useApply") + getboundedIC now uses coordinate-wise integration with useApply = FALSE and only computing the upper half of E LL'w Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-11 14:59:35 UTC (rev 1127) +++ branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-12 00:07:24 UTC (rev 1128) @@ -89,4 +89,4 @@ export(".rescalefct",".plotRescaledAxis",".makedotsP",".makedotsLowLevel",".SelectOrderData") export(".merge.lists") export("InfoPlot", "ComparePlot", "PlotIC") -export(".fixInLiesInSupport") \ No newline at end of file +export(".fixInLiesInSupport", "..IntegrateArgs") \ No newline at end of file Added: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R (rev 0) +++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-12 00:07:24 UTC (rev 1128) @@ -0,0 +1,178 @@ +## new helper function for make and check IC to speed up things + +.preparedirectCheckMakeIC <- function(L2Fam, IC, ...){ + + dims <- length(L2Fam at param) + trafo <- trafo(L2Fam at param) + nrvalues <- nrow(trafo) + Distr <- L2Fam at distribution + + dots <- list(...) + dotsI <- list() + for(item in ..IntegrateArgs) dotsI[[item]] <- dots[[item]] + if(!is.null(dotsI$useApply)) dotsI$useApply <- FALSE + + + IC.v <- as(diag(nrvalues) %*% IC at Curve, "EuclRandVariable") + L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable") + + res <- numeric(nrvalues) + for(i in 1:nrvalues){ + Eargs <- c(list(object = Distr, fun = IC.v at Map[[i]]), dotsI) + res[i] <- do.call(E, Eargs) + } + + integrandA <- function(x, IC.i, L2.j){ + return(IC.i(x)*L2.j(x)) + } + + erg <- matrix(0, ncol = nrvalues, nrow = nrvalues) + + for(i in 1:nrvalues) + for(j in 1:nrvalues){ + Eargs <- c(list(object = Distr, fun = integrandA, + IC.i = IC.v at Map[[i]], L2.j = L2deriv at Map[[j]]), + dotsI) + erg[i, j] <- do.call(E, Eargs) + } + + return(list(E.IC=res,E.IC.L=erg)) +} + + + +## check centering and Fisher consistency +setMethod("checkIC", signature(IC = "IC", L2Fam = "missing"), + function(IC, out = TRUE, ...){ + L2Fam <- eval(IC at CallL2Fam) + getMethod("checkIC", signature(IC = "IC", L2Fam = "L2ParamFamily"))( + IC = IC, L2Fam = L2Fam, out = out, ...) + }) + +## check centering and Fisher consistency +setMethod("checkIC", signature(IC = "IC", L2Fam = "L2ParamFamily"), + function(IC, L2Fam, out = TRUE, ...){ + D1 <- L2Fam at distribution + if(dimension(Domain(IC at Curve[[1]])) != dimension(img(D1))) + stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") + + trafo <- trafo(L2Fam at param) + + res <- .preparedirectCheckMakeIC(L2Fam, IC, ...) + + cent <- res$E.IC + if(out) + cat("precision of centering:\t", cent, "\n") + + + consist <- res$E.IC.L - trafo + + if(out){ + cat("precision of Fisher consistency:\n") + print(consist) + cat("precision of Fisher consistency - relative error [%]:\n") + print(100*consist/trafo) + } + + prec <- max(abs(cent), abs(consist)) + names(prec) <- "maximum deviation" + + return(prec) + }) + + +## make some L2function a pIC at a model +setMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"), + function(IC, L2Fam, ...){ + + dims <- length(L2Fam at param) + if(dimension(IC at Curve) != dims) + stop("Dimension of IC and parameter must be equal") + + D1 <- L2Fam at distribution + if(dimension(Domain(IC at Curve[[1]])) != dimension(img(D1))) + stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") + + trafo <- trafo(L2Fam at param) + + res <- .preparedirectCheckMakeIC(L2Fam, IC, ...) + + IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable") + + cent <- res$E.IC + stand <- trafo %*% distr::solve(res$E.IC.L, generalized = TRUE) + + Y <- as(stand %*% (IC1 - cent), "EuclRandVariable") + + modifyIC <- IC at modifyIC + + if(!is.function(IC at modifyIC)) + modifyIC <- function(L2Fam, IC, withMakeIC = FALSE, ...) + return(makeIC(IC,L2Fam, ...)) + + CallL2Fam <- L2Fam at fam.call + + return(IC(name = name(IC), + Curve = EuclRandVarList(Y), + Risks = list(), + Infos=matrix(c("IC<-", + "generated by affine linear trafo to enforce consistency"), + ncol=2, dimnames=list(character(0), c("method", "message"))), + CallL2Fam = CallL2Fam, + modifyIC = modifyIC)) + }) + +## make some L2function a pIC at a model +setMethod("makeIC", signature(IC = "IC", L2Fam = "missing"), + function(IC, ...){ + L2Fam0 <- eval(IC at CallL2Fam) + getMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"))( + IC = IC, L2Fam = L2Fam, ...) + }) + +setMethod("makeIC", signature(IC = "list", L2Fam = "L2ParamFamily"), + function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL,...){ + mc <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)[-1] + mc0 <- as.list(mc) + mc0$IC <- NULL + mc0$L2Fam <- NULL + mc0$forceIC <- NULL + if(!all(as.logical(c(lapply(IC,is.function))))) + stop("First argument must be a list of functions") + + IC.1 <- lapply(IC, function(IC.2) + if(length(formals(IC.2))==0) function(x) IC.2(x) else IC.2) + + mc0$Curve <- EuclRandVarList(RealRandVariable(Map = IC.1, Domain = Reals())) + mc0$CallL2Fam <- substitute(L2Fam at fam.call) + + IC.0 <- do.call(.IC,mc0) + if(forceIC) IC.0 <- makeIC(IC.0, L2Fam,...) + return(IC.0) + }) + + + +setMethod("makeIC", signature(IC = "function", L2Fam = "L2ParamFamily"), + function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL,...){ + mc <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)[-1] + mc0 <- as.list(mc) + mc0$IC <- NULL + mc0$L2Fam <- NULL + mc0$forceIC <- NULL + IC.1 <- if(length(formals(IC))==0) function(x) IC(x) else IC + mc0$Curve <- EuclRandVarList(RealRandVariable(Map = list(IC.1), + Domain = Reals())) + mc0$CallL2Fam <- substitute(L2Fam at fam.call) + print(mc0) + + IC.0 <- do.call(.IC,mc0) + print(IC.0) + if(forceIC) IC.0 <- makeIC(IC.0, L2Fam,...) + return(IC.0) + }) +## comment 20180809: reverted changes in rev 1110 + +..IntegrateArgs <- c("lowerTruncQuantile", "upperTruncQuantile", + "IQR.fac", "subdivisions", "rel.tol", "abs.tol", "stop.on.error", + "order", "useApply") Modified: branches/robast-1.2/pkg/RobAStBase/R/IC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-11 14:59:35 UTC (rev 1127) +++ branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-12 00:07:24 UTC (rev 1128) @@ -38,6 +38,10 @@ return(IC1) } +# alias to generator function IC needed in functions makeIC in file CheckMakeIC.R +.IC <- IC + + ## access methods setMethod("CallL2Fam", "IC", function(object) object at CallL2Fam) setMethod("modifyIC", "IC", function(object) object at modifyIC) @@ -49,42 +53,8 @@ object }) -## check centering and Fisher consistency -setMethod("checkIC", signature(IC = "IC", L2Fam = "missing"), - function(IC, out = TRUE, ...){ - L2Fam <- eval(IC at CallL2Fam) - checkIC(IC, L2Fam, out = out, ...) - }) -## check centering and Fisher consistency -setMethod("checkIC", signature(IC = "IC", L2Fam = "L2ParamFamily"), - function(IC, L2Fam, out = TRUE, ...){ - D1 <- L2Fam at distribution - if(dimension(Domain(IC at Curve[[1]])) != dimension(img(D1))) - stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") +## moved checkIC and makeIC methods in file CheckMakeIC.R in rev 1128 - trafo <- trafo(L2Fam at param) - IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable") - cent <- E(D1, IC1, ...) - if(out) - cat("precision of centering:\t", cent, "\n") - - dims <- length(L2Fam at param) - L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable") - - consist <- E(D1, IC1 %*% t(L2deriv), ...) - trafo - if(out){ - cat("precision of Fisher consistency:\n") - print(consist) - cat("precision of Fisher consistency - relative error [%]:\n") - print(100*consist/trafo) - } - - prec <- max(abs(cent), abs(consist)) - names(prec) <- "maximum deviation" - - return(prec) - }) - ## evaluate IC setMethod("evalIC", signature(IC = "IC", x = "numeric"), function(IC, x){ @@ -114,110 +84,3 @@ return(evalRandVar(Curve, x)[,,1]) }) -## make some L2function a pIC at a model -setMethod("makeIC", signature(IC = "IC", L2Fam = "missing"), - function(IC){ - L2Fam <- eval(IC at CallL2Fam) - makeIC(IC, L2Fam) - }) - -## make some L2function a pIC at a model -setMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"), - function(IC, L2Fam){ - - dims <- length(L2Fam at param) - if(dimension(IC at Curve) != dims) - stop("Dimension of IC and parameter must be equal") - - D1 <- L2Fam at distribution - if(dimension(Domain(IC at Curve[[1]])) != dimension(img(D1))) - stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") - - trafo <- trafo(L2Fam at param) - IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable") - cent <- E(D1, IC1) - IC1 <- IC1 - cent - - L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable") - - E10 <- E(L2Fam, IC1 %*% t(L2deriv)) - E1 <- matrix(E10, dims, dims) - stand <- trafo %*% distr::solve(E1) - Y <- as(stand %*% IC1, "EuclRandVariable") - #ICfct <- vector(mode = "list", length = dims) - #ICfct[[1]] <- function(x){Y(x)} - - - if(!is.function(IC at modifyIC)) - IC at modifyIC <- function(L2Fam, IC, withMakeIC = FALSE) return(makeIC(IC,L2Fam)) -# modifyIC <- ..modifnew -# }else{ -# .modifyIC <- IC at modifyIC -# if(!is.null(attr(IC at modifyIC,"hasMakeICin.modifyIC"))){ -# modifyIC <- .modifyIC -# }else{ -# modifyIC <- function(L2Fam, IC){ IC. <- .modifyIC(L2Fam, IC) -# return(makeIC(IC., L2Fam)) } -# } -# } -# } -# attr(modifyIC,"hasMakeICin.modifyIC") <- TRUE - - CallL2Fam <- L2Fam at fam.call - - return(IC(name = name(IC), - Curve = EuclRandVarList(Y), - Risks = list(), - Infos=matrix(c("IC<-", - "generated by affine linear trafo to enforce consistency"), - ncol=2, dimnames=list(character(0), c("method", "message"))), - CallL2Fam = CallL2Fam, - modifyIC = IC at modifyIC)) - }) - - -# alias to IC needed here: -.IC <- IC - -setMethod("makeIC", signature(IC = "list", L2Fam = "L2ParamFamily"), - function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL){ - mc <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)[-1] - mc0 <- as.list(mc) - mc0$IC <- NULL - mc0$L2Fam <- NULL - mc0$forceIC <- NULL - if(!all(as.logical(c(lapply(IC,is.function))))) - stop("First argument must be a list of functions") - - IC.1 <- lapply(IC, function(IC.2) - if(length(formals(IC.2))==0) function(x) IC.2(x) else IC.2) - - mc0$Curve <- EuclRandVarList(RealRandVariable(Map = IC.1, Domain = Reals())) - mc0$CallL2Fam <- substitute(L2Fam at fam.call) - - IC.0 <- do.call(.IC,mc0) - if(forceIC) IC.0 <- makeIC(IC.0, L2Fam) - return(IC.0) - }) - - - -setMethod("makeIC", signature(IC = "function", L2Fam = "L2ParamFamily"), - function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL){ - mc <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)[-1] - mc0 <- as.list(mc) - mc0$IC <- NULL - mc0$L2Fam <- NULL - mc0$forceIC <- NULL - IC.1 <- if(length(formals(IC))==0) function(x) IC(x) else IC - mc0$Curve <- EuclRandVarList(RealRandVariable(Map = list(IC.1), - Domain = Reals())) - mc0$CallL2Fam <- substitute(L2Fam at fam.call) - print(mc0) - - IC.0 <- do.call(.IC,mc0) - print(IC.0) - if(forceIC) IC.0 <- makeIC(IC.0, L2Fam) - return(IC.0) - }) -## comment 20180809: reverted changes in rev 1110 \ No newline at end of file Modified: branches/robast-1.2/pkg/RobAStBase/R/getBiasIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getBiasIC.R 2018-08-11 14:59:35 UTC (rev 1127) +++ branches/robast-1.2/pkg/RobAStBase/R/getBiasIC.R 2018-08-12 00:07:24 UTC (rev 1128) @@ -5,7 +5,7 @@ neighbor = "UncondNeighborhood"), function(IC, neighbor, L2Fam, biastype = symmetricBias(), normtype = NormType(), tol = .Machine$double.eps^0.25, - numbeval = 1e5, withCheck = TRUE){ + numbeval = 1e5, withCheck = TRUE, ...){ misF <- FALSE if(missing(L2Fam)){ @@ -24,7 +24,7 @@ Bias <- .evalBiasIC(IC = IC, neighbor = neighbor, biastype = biastype, normtype = normtype, x = x, trafo = trafo(L2Fam at param)) - if(withCheck) if(misF) .checkICWithWarning(IC, tol=tol) else .checkICWithWarning(IC, L2Fam, tol=tol) + if(withCheck) if(misF) .checkICWithWarning(IC, tol=tol, ...) else .checkICWithWarning(IC, L2Fam, tol=tol, ...) return(list(asBias = list(distribution = .getDistr(L2Fam), neighborhood = neighbor at type, value = Bias))) }) Modified: branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-11 14:59:35 UTC (rev 1127) +++ branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-12 00:07:24 UTC (rev 1128) @@ -1,8 +1,8 @@ -.checkICWithWarning <- function(IC, L2Fam, tol){ +.checkICWithWarning <- function(IC, L2Fam, tol, ...){ if(!missing(L2Fam)){ - prec <- checkIC(IC, L2Fam, out = FALSE) + prec <- checkIC(IC, L2Fam, out = FALSE, ...) }else{ - prec <- checkIC(IC, out = FALSE) + prec <- checkIC(IC, out = FALSE, ...) } if(prec > tol) warning("The maximum deviation from the exact IC properties is ", prec, @@ -16,27 +16,27 @@ risk = "asCov", neighbor = "missing", L2Fam = "missing"), - function(IC, risk, tol = .Machine$double.eps^0.25, withCheck = TRUE){ + function(IC, risk, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){ if(missing(withCheck)) withCheck <- TRUE return(getRiskIC(IC = IC, risk = risk, L2Fam = eval(IC at CallL2Fam), - tol = tol, withCheck = withCheck)) + tol = tol, withCheck = withCheck, ...)) }) setMethod("getRiskIC", signature(IC = "IC", risk = "asCov", neighbor = "missing", L2Fam = "L2ParamFamily"), - function(IC, risk, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE){ + function(IC, risk, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){ if(dimension(Domain(IC at Curve[[1]])) != dimension(img(L2Fam at distribution))) stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") if(missing(withCheck)) withCheck <- TRUE IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable") - bias <- E(L2Fam, IC1) - Cov <- E(L2Fam, IC1 %*% t(IC1)) + bias <- E(L2Fam, IC1, ...) + Cov <- E(L2Fam, IC1 %*% t(IC1), ...) - if(withCheck) .checkICWithWarning(IC, L2Fam, tol) + if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...) return(list(asCov = list(distribution = .getDistr(L2Fam), value = Cov - bias %*% t(bias)))) }) @@ -48,26 +48,26 @@ risk = "trAsCov", neighbor = "missing", L2Fam = "missing"), - function(IC, risk, tol = .Machine$double.eps^0.25, withCheck = TRUE){ + function(IC, risk, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){ if(missing(withCheck)) withCheck <- TRUE return(getRiskIC(IC = IC, risk = risk, L2Fam = eval(IC at CallL2Fam), - tol = tol, withCheck = withCheck)) + tol = tol, withCheck = withCheck, ...)) }) setMethod("getRiskIC", signature(IC = "IC", risk = "trAsCov", neighbor = "missing", L2Fam = "L2ParamFamily"), - function(IC, risk, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE){ + function(IC, risk, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){ if(dimension(Domain(IC at Curve[[1]])) != dimension(img(L2Fam at distribution))) stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") if(missing(withCheck)) withCheck <- TRUE - trCov <- getRiskIC(IC, risk = asCov(), L2Fam = L2Fam, withCheck = withCheck)$asCov + trCov <- getRiskIC(IC, risk = asCov(), L2Fam = L2Fam, withCheck = withCheck, ...)$asCov trCov$value <- sum(diag(as.matrix(trCov$value))) - if(withCheck) .checkICWithWarning(IC, L2Fam, tol) + if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...) return(list(trAsCov = trCov)) }) @@ -78,7 +78,7 @@ risk = "asBias", neighbor = "UncondNeighborhood", L2Fam = "missing"), - function(IC, risk, neighbor, tol = .Machine$double.eps^0.25, withCheck = TRUE){ + function(IC, risk, neighbor, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){ if(missing(withCheck)) withCheck <- TRUE @@ -90,11 +90,11 @@ risk = "asBias", neighbor = "UncondNeighborhood", L2Fam = "L2ParamFamily"), - function(IC, risk, neighbor, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE){ + function(IC, risk, neighbor, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){ if(missing(withCheck)) withCheck <- TRUE getBiasIC(IC = IC, neighbor = neighbor, L2Fam = L2Fam, biastype = biastype(risk), normtype = normtype(risk), - tol = tol, withCheck = withCheck) + tol = tol, withCheck = withCheck, ...) }) ############################################################################### ## asymptotic MSE @@ -103,18 +103,18 @@ risk = "asMSE", neighbor = "UncondNeighborhood", L2Fam = "missing"), - function(IC, risk, neighbor, tol = .Machine$double.eps^0.25, withCheck = TRUE){ + function(IC, risk, neighbor, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){ if(missing(withCheck)) withCheck <- TRUE L2Fam <- eval(IC at CallL2Fam) getRiskIC(IC = IC, risk = risk, neighbor = neighbor, - L2Fam = L2Fam, tol = tol, withCheck = withCheck) + L2Fam = L2Fam, tol = tol, withCheck = withCheck, ...) }) setMethod("getRiskIC", signature(IC = "IC", risk = "asMSE", neighbor = "UncondNeighborhood", L2Fam = "L2ParamFamily"), - function(IC, risk, neighbor, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE){ + function(IC, risk, neighbor, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){ if(dimension(Domain(IC at Curve[[1]])) != dimension(img(L2Fam at distribution))) stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") @@ -122,10 +122,10 @@ rad <- neighbor at radius if(rad == Inf) return(Inf) - trCov <- getRiskIC(IC = IC, risk = trAsCov(), L2Fam = L2Fam, withCheck = FALSE) - Bias <- getRiskIC(IC = IC, risk = asBias(), neighbor = neighbor, L2Fam = L2Fam, withCheck = FALSE) + trCov <- getRiskIC(IC = IC, risk = trAsCov(), L2Fam = L2Fam, withCheck = FALSE, ...) + Bias <- getRiskIC(IC = IC, risk = asBias(), neighbor = neighbor, L2Fam = L2Fam, withCheck = FALSE, ...) - if(withCheck) .checkICWithWarning(IC, L2Fam, tol) + if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...) nghb <- paste(neighbor at type, "with radius", neighbor at radius) return(list(asMSE = list(distribution = .getDistr(L2Fam), Modified: branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-11 14:59:35 UTC (rev 1127) +++ branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-12 00:07:24 UTC (rev 1128) @@ -1,4 +1,10 @@ -getBoundedIC <- function(L2Fam, D=trafo(L2Fam at param)){ +getBoundedIC <- function(L2Fam, D=trafo(L2Fam at param),...){ + + dots <- list(...) + dotsI <- list() + for(item in ..IntegrateArgs) dotsI[[item]] <- dots[[item]] + if(!is.null(dotsI$useApply)) dotsI$useApply <- FALSE + FI <- FisherInfo(L2Fam) bm <- sum(diag(distr::solve(FI))) w <- new("BoundedWeight", clip = bm, weight = function(x){ @@ -13,7 +19,7 @@ L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable") ICfct <- vector(mode = "list", length = dims) - L.fct <- function(x) evalRandVar(L2deriv,x) + L.fct <- function(x) evalRandVar(L2deriv,as.matrix(x))[,,1] for(i in 1:dims){ ICfct[[i]] <- function(x){} @@ -26,10 +32,24 @@ Range = L2deriv at Range) D1 <- L2Fam at distribution - cent <- E(D1,L2w) + cent <- numeric(dims) + stand.0 <- matrix(0,dims,dims) + + for(i in 1:dims){ + fun <- function(x) {Lx <- L.fct(x); wx <- weight(w)(Lx); return(Lx[i,]*wx)} + Eargs <- c(list(object=D1, fun=fun), dotsI) + cent[i] <- do.call(E,Eargs) + } + for(i in 1:dims) + for(j in i:dims){ + fun <- function(x) {Lx <- L.fct(x); wx <- weight(w)(Lx) + return((Lx[i,]-cent[i])*(Lx[j,]-cent[j])*wx)} + Eargs <- c(list(object=D1, fun=fun), dotsI) + stand.0[i,j] <- do.call(E,Eargs) + } + stand.0[row(stand.0)>col(stand.0)] <- t(stand.0)[row(stand.0)>col(stand.0)] + + stand <- as.matrix(D %*% distr::solve(stand.0, generalized = TRUE)) L2w0 <- L2w - cent - - E1 <- matrix(E(D1, L2w0 %*% t(L2deriv-cent)), dims, dims) - stand <- as.matrix(D %*% distr::solve(E1, generalized = TRUE)) return(as(stand %*% L2w0, "EuclRandVariable")) - } +} Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-11 14:59:35 UTC (rev 1127) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-12 00:07:24 UTC (rev 1128) @@ -34,6 +34,7 @@ .ensureDim2 <- function(x){ d <- dim(x) if(length(d)==3L && d[3]==1L) dim(x) <- d[1:2] + if(length(d)==4L && d[2]==1L && d[4] == 1L) dim(x) <- d[c(1,3)] x } ### no dispatch on top layer -> keep product structure of dependence @@ -45,13 +46,16 @@ withPICList = getRobAStBaseOption("withPICList"), na.rm = TRUE, startArgList = NULL, ..., withLogScale = TRUE, withEvalAsVar = TRUE, - withMakeIC = FALSE){ + withMakeIC = FALSE, E.argList = NULL){ if(missing(IC.UpdateInKer)) IC.UpdateInKer <- NULL ## save call es.call <- match.call() es.call[[1]] <- as.name("kStepEstimator") + if(is.null(E.argList)) E.argList <- list() + if(is.null(E.argList$useApply)) E.argList$useApply <- FALSE + ## get some dimensions ##-t-## syt <- system.time({ L2Fam <- eval(CallL2Fam(IC)) @@ -148,13 +152,17 @@ pICList <- if(withPICList) vector("list", steps) else NULL ICList <- if(withICList) vector("list", steps) else NULL - cvar.fct <- function(L2, IC, dim, dimn =NULL){ + cvar.fct <- function(L2, IC, dim, dimn =NULL){} + body(cvar.fct) <- substitute({ + EcallArgs <- c(list(L2, IC %*% t(IC)), E.argList0) + Eres <- do.call(E,EcallArgs) + if(is.null(dimn)){ - return(matrix(E(L2, IC %*% t(IC)),dim,dim)) + return(matrix(Eres,dim,dim)) }else{ - return(matrix(E(L2, IC %*% t(IC)),dim,dim, dimnames = dimn)) + return(matrix(Eres,dim,dim, dimnames = dimn)) } - } + }, list(E.argList0 = E.argList)) ##-t-## updStp <- 0 ### update - function @@ -178,12 +186,14 @@ ##-t-## sytm <<- .addTime(sytm,syt,paste("modifyModel-PreModif-",updStp)) # print(L2Fam) ##-t-## syt <- system.time({ - IC <- modifyIC(IC)(L2Fam, IC, withMakeIC = FALSE) + modifyICargs <- c(list(L2Fam, IC, withMakeIC = FALSE), E.argList) + IC <- do.call(modifyIC(IC),modifyICargs) ##-t-## }) ##-t-## sytm <<- .addTime(sytm,syt,paste("modifyIC-PreModif-",updStp)) if(steps==1L && withMakeIC){ ##-t-## syt <- system.time({ - IC <- makeIC(IC, L2Fam) + makeICargs <- c(list(IC, L2Fam),E.argList) + IC <- do.call(makeIC, makeICargs) ##-t-## }) ##-t-## sytm <<- .addTime(sytm,syt,paste("modifyIC-makeIC-",updStp)) # IC at modifyIC <- oldmodifIC @@ -216,7 +226,8 @@ warning("'IC.UpdateInKer' is not of class 'IC'; we use default instead.") if(is.null(IC.UpdateInKer)){ ##-t-## syt <- system.time({ - IC.tot2 <- getBoundedIC(L2Fam, D = projker) + getBoundedICargs <- c(list(L2Fam, D = projker),E.argList) + IC.tot2 <- do.call(getBoundedIC, getBoundedICargs) ##-t-## }) ##-t-## sytm <<- .addTime(sytm,syt,paste("getBoundedIC-",updStp)) }else{ @@ -247,6 +258,7 @@ if(!IC.tot2.isnull) IC.tot <- IC.tot1 + IC.tot2 ##-t-## syt <- system.time({ indS <- liesInSupport(distribution(L2Fam),x0,checkFin=TRUE) +# print(str(evalRandVar(IC.tot, x0))) correct <- rowMeans(t(t(.ensureDim2(evalRandVar(IC.tot, x0)))*indS), na.rm = na.rm) ##-t-## }) ##-t-## sytm <<- .addTime(sytm,syt,paste("Dtau-not-Unit:correct <- rowMeans-",updStp)) @@ -327,7 +339,8 @@ ##-t-## sytm <<- .addTime(sytm,syt,paste("modifyModel-PostModif-",updStp)) # print(L2Fam) ##-t-## syt <- system.time({ - IC <- modifyIC(IC)(L2Fam, IC, withMakeIC = withMakeIC) + modifyICargs <- c(list(L2Fam, IC, withMakeIC = withMakeIC), E.argList) + IC <- do.call(modifyIC(IC),modifyICargs) ##-t-## }) ##-t-## sytm <<- .addTime(sytm,syt,paste("modifyIC-PostModif-",updStp)) # print(IC) @@ -364,7 +377,10 @@ IC <- upd$IC L2Fam <- upd$L2Fam ##-t-## syt <- system.time({ - if((i==steps)&&withMakeIC) IC <- makeIC(IC,L2Fam) + if((i==steps)&&withMakeIC){ + makeICargs <- c(list(IC, L2Fam),E.argList) + IC <- do.call(makeIC, makeICargs) + } ##-t-## }) ##-t-## sytm <- .addTime(sytm,syt,paste("makeIC-",i)) # IC at modifyIC <- modif.old @@ -412,7 +428,10 @@ Infos <- rbind(Infos, c("kStepEstimator", "computation of IC, trafo, asvar and asbias via useLast = TRUE")) ##-t-## syt <- system.time({ - if(withMakeIC) IC <- makeIC(IC, L2Fam) + if(withMakeIC){ + makeICargs <- c(list(IC, L2Fam),E.argList) + IC <- do.call(makeIC, makeICargs) + } ##-t-## }) ##-t-## sytm <- .addTime(sytm,syt,"makeIC-useLast") }else{ @@ -456,14 +475,15 @@ ## some risks # print(list(u.theta=u.theta,theta=theta,u.var=u.var,var=var0)) if(var.to.be.c){ - if("asCov" %in% names(Risks(IC))) - if(is.matrix(Risks(IC)$asCov) || length(Risks(IC)$asCov) == 1) - asVar <- Risks(IC)$asCov - else - asVar <- Risks(IC)$asCov$value - else + if("asCov" %in% names(Risks(IC))){ + asVar <- if(is.matrix(Risks(IC)$asCov) || length(Risks(IC)$asCov) == 1) + Risks(IC)$asCov else Risks(IC)$asCov$value + }else{ ##-t-## syt <- system.time({ - asVar <- getRiskIC(IC, risk = asCov(), withCheck = FALSE)$asCov$value + getRiskICasVarArgs <- c(list(IC, risk = asCov(), withCheck = FALSE),E.argList) + riskAsVar <- do.call(getRiskIC, getRiskICasVarArgs) + asVar <- riskAsVar$asCov$value + } ##-t-## }) ##-t-## sytm <- .addTime(sytm,syt,"getRiskIC-Var") Modified: branches/robast-1.2/pkg/RobAStBase/R/move2bckRefParam.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/move2bckRefParam.R 2018-08-11 14:59:35 UTC (rev 1127) +++ branches/robast-1.2/pkg/RobAStBase/R/move2bckRefParam.R 2018-08-12 00:07:24 UTC (rev 1128) @@ -109,6 +109,6 @@ setMethod("moveICBackFromRefParam", signature(IC = "HampIC", L2Fam = "L2ParamFamily"), function(IC, L2Fam, ...){ IC <- moveICBackFromRefParam(as(IC,"IC"), L2Fam,...) - IC at modifyIC(L2Fam, IC, withMakeIC = FALSE) + IC at modifyIC(L2Fam, IC, withMakeIC = FALSE, ...) return(IC)}) Modified: branches/robast-1.2/pkg/RobAStBase/R/oneStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/oneStepEstimator.R 2018-08-11 14:59:35 UTC (rev 1127) +++ branches/robast-1.2/pkg/RobAStBase/R/oneStepEstimator.R 2018-08-12 00:07:24 UTC (rev 1128) @@ -6,7 +6,8 @@ useLast = getRobAStBaseOption("kStepUseLast"), withUpdateInKer = getRobAStBaseOption("withUpdateInKer"), IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"), - na.rm = TRUE, startArgList = NULL, withMakeIC = FALSE, ...){ + na.rm = TRUE, startArgList = NULL, withMakeIC = FALSE, ..., + E.argList = NULL){ es.call <- match.call() es.call[[1]] <- as.name("oneStepEstimator") @@ -17,7 +18,8 @@ erg <- kStepEstimator(x = x, IC = IC, start = start, steps = 1L, useLast = useLast, withUpdateInKer = withUpdateInKer, IC.UpdateInKer = IC.UpdateInKer, na.rm = na.rm, - startArgList = startArgList, withMakeIC = withMakeIC, ...) + startArgList = startArgList, withMakeIC = withMakeIC, ..., + E.argList = E.argList) Infos(erg) <- gsub("kStep","oneStep", Infos(erg)) erg at estimate.call <- es.call return(erg) Modified: branches/robast-1.2/pkg/RobAStBase/R/optIC.R =================================================================== [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/robast -r 1128 From noreply at r-forge.r-project.org Sun Aug 12 07:37:33 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 07:37:33 +0200 (CEST) Subject: [Robast-commits] r1129 - in branches/robast-1.2/pkg/RobAStBase: . R inst man Message-ID: <20180812053733.79B7018A5A6@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 07:37:32 +0200 (Sun, 12 Aug 2018) New Revision: 1129 Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS branches/robast-1.2/pkg/RobAStBase/man/internals.Rd Log: [RobAStBase] branch 1.2 + introduce filter function .filterEargs to filter out relevant argumengs for E() from ... Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-12 00:07:24 UTC (rev 1128) +++ branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-12 05:37:32 UTC (rev 1129) @@ -89,4 +89,4 @@ export(".rescalefct",".plotRescaledAxis",".makedotsP",".makedotsLowLevel",".SelectOrderData") export(".merge.lists") export("InfoPlot", "ComparePlot", "PlotIC") -export(".fixInLiesInSupport", "..IntegrateArgs") \ No newline at end of file +export(".fixInLiesInSupport", "..IntegrateArgs", ".filterEargs") \ No newline at end of file Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-12 00:07:24 UTC (rev 1128) +++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-12 05:37:32 UTC (rev 1129) @@ -7,10 +7,8 @@ nrvalues <- nrow(trafo) Distr <- L2Fam at distribution - dots <- list(...) - dotsI <- list() - for(item in ..IntegrateArgs) dotsI[[item]] <- dots[[item]] - if(!is.null(dotsI$useApply)) dotsI$useApply <- FALSE + dotsI <- .filterEargs(list(...)) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE IC.v <- as(diag(nrvalues) %*% IC at Curve, "EuclRandVariable") @@ -176,3 +174,9 @@ ..IntegrateArgs <- c("lowerTruncQuantile", "upperTruncQuantile", "IQR.fac", "subdivisions", "rel.tol", "abs.tol", "stop.on.error", "order", "useApply") + +.filterEargs <- function(dots){ + dotsI <- list() + for(item in ..IntegrateArgs) dotsI[[item]] <- dots[[item]] + return(dotsI) +} \ No newline at end of file Modified: branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-12 00:07:24 UTC (rev 1128) +++ branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-12 05:37:32 UTC (rev 1129) @@ -1,9 +1,7 @@ getBoundedIC <- function(L2Fam, D=trafo(L2Fam at param),...){ - dots <- list(...) - dotsI <- list() - for(item in ..IntegrateArgs) dotsI[[item]] <- dots[[item]] - if(!is.null(dotsI$useApply)) dotsI$useApply <- FALSE + dotsI <- .filterEargs(list(...)) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE FI <- FisherInfo(L2Fam) bm <- sum(diag(distr::solve(FI))) Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-12 00:07:24 UTC (rev 1128) +++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-12 05:37:32 UTC (rev 1129) @@ -85,6 +85,7 @@ + new internal constant ..IntegrateArgs which contains the names of all arguments used for integration, i.e., currently, c("lowerTruncQuantile", "upperTruncQuantile", "IQR.fac", "subdivisions", "rel.tol", "abs.tol", "stop.on.error", "order", "useApply") + this is used to filter out arguments from dots which are meant for E() + getboundedIC now uses coordinate-wise integration with useApply = FALSE and only computing the upper half of E LL'w Modified: branches/robast-1.2/pkg/RobAStBase/man/internals.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/internals.Rd 2018-08-12 00:07:24 UTC (rev 1128) +++ branches/robast-1.2/pkg/RobAStBase/man/internals.Rd 2018-08-12 05:37:32 UTC (rev 1129) @@ -18,6 +18,7 @@ .msapply(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) .fixInLiesInSupport(IC, distr) ..IntegrateArgs +.filterEargs(dots) } \arguments{ \item{x}{a (numeric) vector} @@ -35,6 +36,7 @@ use \code{X} as names for the result unless it had names already.} \item{IC}{an object of class \code{IC}, i.e., it expects a slot \code{Curve} like an IC.} \item{distr}{a distribution} + \item{dots}{a list, obtained by \code{list(...)}.} } \details{ @@ -50,6 +52,8 @@ \code{..IntegrateArgs} is an internal constant, containing the names of all arguments used for integration, i.e., currently, \code{c("lowerTruncQuantile", "upperTruncQuantile", "IQR.fac", "subdivisions", "rel.tol", "abs.tol", "stop.on.error", "order", "useApply")}. +\code{.filterEargs} filters out of \code{dots} all named arguments which have names + contained in \code{..IntegrateArgs} and returns a list with these items. } From noreply at r-forge.r-project.org Sun Aug 12 10:15:24 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 10:15:24 +0200 (CEST) Subject: [Robast-commits] r1130 - branches/robast-1.2/pkg/RobAStBase/R Message-ID: <20180812081524.75386189359@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 10:15:22 +0200 (Sun, 12 Aug 2018) New Revision: 1130 Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R Log: [RobAStBase] branch 2.8 yet some bug fixes / in vectorized form, the indicators were not helpful... Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-12 05:37:32 UTC (rev 1129) +++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-12 08:15:22 UTC (rev 1130) @@ -24,10 +24,10 @@ return(IC.i(x)*L2.j(x)) } - erg <- matrix(0, ncol = nrvalues, nrow = nrvalues) + erg <- matrix(0, ncol = dims, nrow = nrvalues) for(i in 1:nrvalues) - for(j in 1:nrvalues){ + for(j in 1:dims){ Eargs <- c(list(object = Distr, fun = integrandA, IC.i = IC.v at Map[[i]], L2.j = L2deriv at Map[[j]]), dotsI) Modified: branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R 2018-08-12 05:37:32 UTC (rev 1129) +++ branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R 2018-08-12 08:15:22 UTC (rev 1130) @@ -19,36 +19,34 @@ ICfct[[1]] <- function(x){} if(dims==1L){ body(ICfct[[1]]) <- substitute( - { Lx <- L(x) + { Lx <- L(x); wx <- w(Lx) + print(str(a)); print(str(A));print(str(Lx)); print(str(w(Lx))) Yx <- A %*% Lx - a - ind <- 1-.eq(Yx) - (Yx*w(Lx) + zi*(1-ind)*d*b) }, + ifelse(.eq(Yx),zi*d*b,as.numeric(Yx*w(Lx))) }, list(L = L.fct, w = w, b = b, d = d, A = A, a = a, zi = sign(trafo(L2Fam at param)), .eq = .eq)) }else{ body(ICfct[[1]]) <- substitute( - { Lx <- L(x) + { Lx <- L(x); wx <- w(Lx) Yx <- A %*% Lx - a - ind <- 1-.eq(Yx) - ifelse(ind, Yx*w(Lx), NA) }, + ifelse(.eq(Yx), NA, as.numeric(Yx*w(Lx))) }, list(L = L.fct, w = w, b = b, d = d, A = A, a = a, .eq = .eq)) } }else{ ICfct[[1]] <- function(x){} - body(ICfct[[1]]) <- substitute({ Lx <- L(x) + body(ICfct[[1]]) <- substitute({ Lx <- L(x); wx <- w(Lx); #Lx <- as.matrix(Lx) Yx <- A %*% Lx - a - Yx*w(Lx) }, + as.numeric(Yx*wx) }, list(L = L.fct, A = A, a = a, w = w)) } }else{ if(!is.null(res$d)) for(i in 1:nrvalues){ ICfct[[i]] <- function(x){} - body(ICfct[[i]]) <- substitute({Lx <- L(x) + body(ICfct[[i]]) <- substitute({Lx <- L(x);wx <- w(Lx) Yix <- Ai %*% Lx - ai - ind <- 1-.eq(Yix) - (ind*Yix*w(Lx) + (1-ind)*di) + ifelse(.eq(Yix), di, as.numeric(Yix*wx)) }, list(L = L.fct, Ai = A[i,,drop=FALSE], ai = a[i], w = w, di = d[i]))#, .eq = .eq)) @@ -56,9 +54,9 @@ else for(i in 1:nrvalues){ ICfct[[i]] <- function(x){} - body(ICfct[[i]]) <- substitute({Lx <- L(x) + body(ICfct[[i]]) <- substitute({Lx <- L(x);wx <- w(Lx) Yix <- Ai %*% Lx - ai - Yix*w(Lx) }, + as.numeric(Yix*wx) }, list(L = L.fct, Ai = A[i,,drop=FALSE], ai = a[i], w = w)) } } From noreply at r-forge.r-project.org Sun Aug 12 10:54:13 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 10:54:13 +0200 (CEST) Subject: [Robast-commits] r1131 - in branches/robast-1.2/pkg/ROptEst: . R inst inst/scripts man Message-ID: <20180812085414.341B318A1E9@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 10:54:12 +0200 (Sun, 12 Aug 2018) New Revision: 1131 Added: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd Modified: branches/robast-1.2/pkg/ROptEst/NAMESPACE branches/robast-1.2/pkg/ROptEst/R/L1L2normL2deriv.R branches/robast-1.2/pkg/ROptEst/R/LowerCaseMultivariate.R branches/robast-1.2/pkg/ROptEst/R/getAsRisk.R branches/robast-1.2/pkg/ROptEst/R/getComp.R branches/robast-1.2/pkg/ROptEst/R/getInfCent.R branches/robast-1.2/pkg/ROptEst/R/getInfClip.R branches/robast-1.2/pkg/ROptEst/R/getInfGamma.R branches/robast-1.2/pkg/ROptEst/R/getInfLM.R branches/robast-1.2/pkg/ROptEst/R/getInfRad.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asBias.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asGRisk.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asHampel.R branches/robast-1.2/pkg/ROptEst/R/getInfStand.R branches/robast-1.2/pkg/ROptEst/R/getInfV.R branches/robast-1.2/pkg/ROptEst/R/getMaxIneff.R branches/robast-1.2/pkg/ROptEst/R/getModifyIC.R branches/robast-1.2/pkg/ROptEst/R/getReq.R branches/robast-1.2/pkg/ROptEst/R/getRiskIC.R branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R branches/robast-1.2/pkg/ROptEst/R/internal.roptest.R branches/robast-1.2/pkg/ROptEst/R/leastFavorableRadius.R branches/robast-1.2/pkg/ROptEst/R/optIC.R branches/robast-1.2/pkg/ROptEst/R/radiusMinimaxIC.R branches/robast-1.2/pkg/ROptEst/R/roptest.new.R branches/robast-1.2/pkg/ROptEst/inst/NEWS branches/robast-1.2/pkg/ROptEst/inst/scripts/MBRE.R branches/robast-1.2/pkg/ROptEst/man/getBiasIC.Rd branches/robast-1.2/pkg/ROptEst/man/getInfCent.Rd branches/robast-1.2/pkg/ROptEst/man/getInfClip.Rd branches/robast-1.2/pkg/ROptEst/man/getInfGamma.Rd branches/robast-1.2/pkg/ROptEst/man/getInfRad.Rd branches/robast-1.2/pkg/ROptEst/man/getInfStand.Rd branches/robast-1.2/pkg/ROptEst/man/getInfV.Rd branches/robast-1.2/pkg/ROptEst/man/getMaxIneff.Rd branches/robast-1.2/pkg/ROptEst/man/getReq.Rd branches/robast-1.2/pkg/ROptEst/man/getRiskIC.Rd branches/robast-1.2/pkg/ROptEst/man/getinfLM.Rd branches/robast-1.2/pkg/ROptEst/man/inputGenerator.Rd branches/robast-1.2/pkg/ROptEst/man/internals.Rd branches/robast-1.2/pkg/ROptEst/man/leastFavorableRadius.Rd branches/robast-1.2/pkg/ROptEst/man/minmaxBias.Rd branches/robast-1.2/pkg/ROptEst/man/optIC.Rd branches/robast-1.2/pkg/ROptEst/man/robest.Rd branches/robast-1.2/pkg/ROptEst/man/roptest.Rd Log: [ROptEst] branch 1.2 + getBiasIC for signature {HampIC,UncondNeighborhood} no longer has argument withCheck + getRiskIC gains argument "..." to pass on arguments to E() + roptest gains an argument E.argList for arguments to be passed to E() from (a) \code{MDEstimator} (here this additional argument is only used if \code{initial.est} is missing), (b) \code{getStartIC}, and (c) \code{kStepEstimator}. Potential clashes with arguments of the same name in \code{\dots} are resolved by inserting the items of argument list \code{E.argList} as named items, so in case of collisions the item of \code{E.argList} overwrites the existing one from \code{\dots}. + the input generators genkStepCtrl, genstartCtrl, genstartICCtrl gain argument E.argList to pass on arguments to E() + the help to robest is more explicit about the usage of argument E.argList at various places in the generator + the help to roptest has an extra paragraph explicating the usage of initial.est and start.Par and the different steps done in roptest + getBiasIC for signature {HampIC,UncondNeighborhood} no longer has argument withCheck + several getRiskIC and optIC methods gain argument "..." to pass on arguments to E() + revised script MBRE.R ---------------------------------------------------------------------------------- + an embarrassing error when computing E(X t(X)) (saving the lower half by symmetry) in getInfStand: a[row(a)>col(a)] <- a[row(a)col(a)] <- t(a)[row(a)>col(a)] + fix an argument collision in MBRE-method / in call to getInfRobIC_asGRisk, when called from OptIC through getInfRobIC_asBias ("upper" got into ...) ---------------------------------------------------------------------------------- + internal function .getComp, determining by symmetry slots which entries in LMs a and A have to be computed, now fills the lower triangle of A with FALSE (was not used so far, but can be used in a faster computation method for checkIC makeIC to determine whether it is cleverer to integrate in k or in p space) + particular checkIC and makeIC methods for ContICs which allow for speed up if in k space many entries of the LMs can be skipped due to symmetry + several methods (getRiskIC, getBiasIC, getBoundedIC, makeIC, checkIC, modifyIC) gain argument "..." to pass on arguments to E(). This holds in particular for the functions used to compute the optimally-robust ICs, i.e. getInfRob_asBias, getInfRob_asHampel, getInfRob_asGRisk, getInfRob_asAnscombe, leastFavorableRadius, radiusMinimaxIC, and geInfGamma, getInfRad, getInfClip, getInfCent, getInfStand, getInfV, getAsRisk, getReq, (at least as far as multivariate ICs are concerned), .LowerCaseMultivariate, getMaxIneff, getInfRad, getLagrangeMultByIter and getLagrangeMultByOptim + new internal helper function .filterEarg by means of constant ..IntegrateArgs (exported from package RobAStBase) is used to filter out arguments from dots which are meant for E() + the local .modifyIC0 functions only used to produce the new IC but not for filling slot modifyIC loose argument withMakeIC (and dots) -- this is now done in the outer modifyIC function Modified: branches/robast-1.2/pkg/ROptEst/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/ROptEst/NAMESPACE 2018-08-12 08:15:22 UTC (rev 1130) +++ branches/robast-1.2/pkg/ROptEst/NAMESPACE 2018-08-12 08:54:12 UTC (rev 1131) @@ -39,7 +39,8 @@ "getModifyIC") exportMethods("updateNorm", "scaleUpdateIC", "eff", "get.asGRisk.fct", "getStartIC", "plot", - "comparePlot", "getRiskFctBV", "roptestCall") + "comparePlot", "getRiskFctBV", "roptestCall", + "checkIC", "makeIC") export("getL2normL2deriv", "asAnscombe", "asL1", "asL4", "getReq", "getMaxIneff", "getRadius") Added: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R (rev 0) +++ branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R 2018-08-12 08:54:12 UTC (rev 1131) @@ -0,0 +1,209 @@ +#if(FALSE){ +## faster check for ContICs + +setMethod("checkIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"), + function(IC, L2Fam, out = TRUE, ...){ + + D1 <- L2Fam at distribution + if( dimension(Domain(IC at Curve[[1]])) != dimension(img(D1))) + stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") + + res <- .prepareCheckMakeIC(L2Fam, w = IC at weight, ...) + ## if it pays off to use symmetry/ to compute integrals in L2deriv space + ## we compute the following integrals: + ## G1 = E w, G2 = E Lambda w, G3 = E Lambda Lambda' w + ## we want to compute: + ## Delta1 = E (A Lambda-a) w, Delta2 = E (A Lambda-a) Lambda' w + ## where A = stand(IC), a=cent(IC) + ## hence Delta1 = A G2 - a G1, Delta2 = A G3 - a G2' + ### otherwise the return value is NULL and we use the standard method + + if(is.null(res)) + return(getMethod("checkIC", signature(IC = "IC", + L2Fam = "L2ParamFamily"))(IC,L2Fam, out = out, ...)) + + + A <- stand(IC); a <- cent(IC) + G1 <- res$G1; G2 <- res$G2; G3 <- res$G3 + Delta1 <- A%*%G2- a*G1 + Delta2 <- A%*%G3 - a%*%t(G2) - trafo(L2Fam at param) + + if(out) + cat("precision of centering:\t", Delta1, "\n") + + if(out){ + cat("precision of Fisher consistency:\n") + print(Delta2) + cat("precision of Fisher consistency - relative error [%]:\n") + print(100*Delta2/trafo) + } + + prec <- max(abs(Delta1), abs(Delta2)) + names(prec) <- "maximum deviation" + + return(prec) + }) + +## make some L2function a pIC at a model +setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"), + function(IC, L2Fam, ...){ + + D1 <- L2Fam at distribution + if( dimension(Domain(IC at Curve[[1]])) != dimension(img(D1))) + stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") + + if(dimension(IC at Curve) != dims) + stop("Dimension of IC and parameter must be equal") + + res <- .prepareCheckMakeIC(L2Fam, w = IC at weight, ...) + + ## if it pays off to use symmetry/ to compute integrals in L2deriv space + ## we compute the following integrals: + ## G1 = E w, G2 = E Lambda w, G3 = E Lambda Lambda' w + ## we want to compute: + ## Delta1 = E (A Lambda-a) w, Delta2 = E (A Lambda-a) Lambda' w + ## where A = stand(IC), a=cent(IC) + ## hence Delta1 = A G2 - a G1, Delta2 = A G3 - a G2' + ### otherwise the return value is NULL and we use the standard method + + if(is.null(res)) + return(getMethod("makeIC", signature(IC = "IC", + L2Fam = "L2ParamFamily"))(IC,L2Fam)) + + G1 <- res$G1; G2 <- res$G2; G3 <- res$G3 + trafo <- trafo(L2Fam at param) + nrvalues <- nrow(trafo) + dims <- ncol(trafo) + + cent0 <- G2/G1 + stand1 <- trafo%*%distr::solve(G3-cent0%*%t(G2)) + cent1 <- stand1%*%cent0 + + L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable") + D1 <- L2Fam at distribution + + IC1.0 <- stand1%*%L2deriv + IC1.1 <- IC1.0 -cent1 + IC1.f <- function(x) evalRandVar(IC1.1,x) + + IC1.l <- vector("list",nrvalues) + for(i in 1:nrvalues){ + IC1.l[[i]] <- function(x){} + body(IC.l[[i]]) <- substitute({indS <- liesInSupport(D0,x,checkFin=TRUE) + indS*((IC1.s(x))[i]) + }, list(IC1.s=IC1.f, D0=D1, i=i)) + } + IC1.c <- EuclRandVariable(Map = IC1.l, Domain = IC at Curve[[1]], + Range = Reals()) + + cIC1 <- new("ContIC") + cIC1 at name <- name + cIC1 at Curve <- IC1.c + cIC1 at Risks <- IC at Risks + cIC1 at Infos <- IC at Infos + cIC1 at CallL2Fam <- L2Fam at fam.call + cIC1 at clip <- IC at clip + cIC1 at cent <- cent1 + cIC1 at stand <- stand1 + cIC1 at lowerCase <- IC at lowerCase + cIC1 at neighborRadius <- IC at neighborRadius + cIC1 at weight <- IC at weight + cIC1 at biastype <- IC at biastype + cIC1 at normtype <- IC at normtype + cIC1 at modifyIC <- IC at modifyIC + addInfo(cIC1) <- c("IC<-", + "generated by affine linear trafo to enforce consistency") + return(cIC1) + }) + +.prepareCheckMakeIC <- function(L2Fam, w, ...){ + + dims <- length(L2Fam at param) + trafo <- trafo(L2Fam at param) + nrvalues <- nrow(trafo) + + z.comp <- rep(TRUE,dims) + A.comp <- matrix(rep(TRUE,dims^2),nrow=dims) + to.comp.i <- (dims+1)*(dims+2)/2 + to.comp.a <- (dims+1)*nrvalues + + L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable") + + z.comp <- rep(TRUE,dims) + A.comp <- matrix(TRUE, dims, dims) + # otherwise if trafo == unitMatrix may use symmetry info + if(.isUnitMatrix(trafo)){ + comp <- .getComp(L2deriv, L2Fam at distrSymm, L2Fam at L2derivSymm, L2Fam at L2derivDistrSymm) + z.comp <- comp$"z.comp" + A.comp <- comp$"A.comp" + t.comp.i <- sum(z.comp)+sum(A.comp)+1 + } + + if(to.comp.a < to.comp.i) return(NULL) + + + res <- .getG1G2G3Stand(L2deriv = L2deriv, Distr = L2Fam at distribution, + A.comp = A.comp, z.comp = z.comp, w = w, ...) + return(res) +} + + + +.getG1G2G3Stand <- function(L2deriv, Distr, A.comp, z.comp, w, ...){ + + dotsI <- .filterEargs(list(...)) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE + + w.fct <- function(x){ + weight(w)(evalRandVar(L2deriv, as.matrix(x)) [,,1]) + } + + + integrand2 <- function(x, L2.i){ + return(L2.i(x)*w.fct(x)) + } + + Eargs <- c(list(object = Distr, fun = w.fct), dotsI) + res1 <- do.call(E,Eargs) + + nrvalues <- length(L2deriv) + res2 <- numeric(nrvalues) + for(i in 1:nrvalues){ + if(z.comp[i]){ + Eargs <- c(list(object = Distr, fun = integrand2, + L2.i = L2deriv at Map[[i]]), dotsI) + res2[i] <- do.call(E,Eargs) + }else{ + res2[i] <- 0 + } + } + + cent <- res2/res1 + + integrandA <- function(x, L2.i, L2.j, i, j){ + return((L2.i(x) - cent[i])*(L2.j(x) - cent[j])*w.fct(x = x)) + } + + nrvalues <- length(L2deriv) + erg <- matrix(0, ncol = nrvalues, nrow = nrvalues) + + for(i in 1:nrvalues){ + for(j in i:nrvalues){ + if(A.comp[i,j]){ + Eargs <- c(list(object = Distr, fun = integrandA, + L2.i = L2deriv at Map[[i]], + L2.j = L2deriv at Map[[j]], i = i, j = j), dotsI) + erg[i, j] <- do.call(E,Eargs) + } + } + } + erg[col(erg) < row(erg)] <- t(erg)[col(erg) < row(erg)] + + return(list(G1=res1,G2=res2, G3=erg)) + } + + + + + +#} Modified: branches/robast-1.2/pkg/ROptEst/R/L1L2normL2deriv.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/L1L2normL2deriv.R 2018-08-12 08:15:22 UTC (rev 1130) +++ branches/robast-1.2/pkg/ROptEst/R/L1L2normL2deriv.R 2018-08-12 08:54:12 UTC (rev 1131) @@ -8,6 +8,10 @@ setMethod("getL1normL2deriv", signature(L2deriv = "RealRandVariable"), function(L2deriv, cent, stand, Distr, normtype, ...){ + + dotsI <- .filterEargs(list(...)) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE + integrandG <- function(x, L2, stand, cent){ X <- evalRandVar(L2, as.matrix(x))[,,1] - cent Y <- apply(X, 2, "%*%", t(stand)) @@ -15,6 +19,7 @@ return((res > 0)*res) } - return(E(object = Distr, fun = integrandG, L2 = L2deriv, - stand = stand, cent = cent, useApply = FALSE)) + + return(do.call(E, c(list(object = Distr, fun = integrandG, L2 = L2deriv, + stand = stand, cent = cent),dotsI))) }) Modified: branches/robast-1.2/pkg/ROptEst/R/LowerCaseMultivariate.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/LowerCaseMultivariate.R 2018-08-12 08:15:22 UTC (rev 1130) +++ branches/robast-1.2/pkg/ROptEst/R/LowerCaseMultivariate.R 2018-08-12 08:54:12 UTC (rev 1131) @@ -1,8 +1,11 @@ .LowerCaseMultivariate <- function(L2deriv, neighbor, biastype, normtype, Distr, Finfo, trafo, z.start = NULL, A.start = NULL, z.comp = NULL, A.comp = NULL, maxiter, tol, - verbose = NULL){ + verbose = NULL, ...){ + dotsI <- .filterEargs(list(...)) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE + if(missing(verbose)|| is.null(verbose)) verbose <- getRobAStBaseOption("all.verbose") @@ -59,8 +62,8 @@ w <<- w0 } - E1 <- E(object = Distr, fun = abs.fct, L2 = L2deriv, stand = A, - cent = z, normtype.0 = normtype, useApply = FALSE) + E1 <- do.call(E,c(list(object = Distr, fun = abs.fct, L2 = L2deriv, stand = A, + cent = z, normtype.0 = normtype), dotsI)) stA <- if (is(normtype,"QFNorm")) QuadForm(normtype)%*%A else A # erg <- E1/sum(diag(stA %*% t(trafo))) @@ -101,8 +104,11 @@ .LowerCaseMultivariateTV <- function(L2deriv, neighbor, biastype, normtype, Distr, Finfo, trafo, A.start = NULL, maxiter, tol, - verbose = NULL){ + verbose = NULL, ...){ + dotsI <- .filterEargs(list(...)) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE + if(missing(verbose)|| is.null(verbose)) verbose <- getRobAStBaseOption("all.verbose") @@ -124,8 +130,8 @@ p <- 1 A <- matrix(param, ncol = k, nrow = 1) # print(A) - E1 <- E(object = Distr, fun = pos.fct, L2 = L2deriv, stand = A, - useApply = FALSE) + E1 <- do.call(E, c(list( object = Distr, fun = pos.fct, + L2 = L2deriv, stand = A), dotsI)) erg <- E1/sum(diag(A %*% t(trafo))) return(erg) } @@ -144,10 +150,10 @@ Y <- as.numeric(A %*% X) return(as.numeric(pr.sign*Y>0)) } - p.p <- E(object = Distr, fun = pr.fct, L2 = L2deriv, - useApply = FALSE, pr.sign = 1) - m.p <- E(object = Distr, fun = pr.fct, L2 = L2deriv, - useApply = FALSE, pr.sign = -1) + p.p <- do.call(E, c(list( object = Distr, fun = pr.fct, L2 = L2deriv, + pr.sign = 1), dotsI)) + m.p <- do.call(E, c(list( object = Distr, fun = pr.fct, L2 = L2deriv, + pr.sign = -1), dotsI)) a <- -b * p.p/(p.p+m.p) Modified: branches/robast-1.2/pkg/ROptEst/R/getAsRisk.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getAsRisk.R 2018-08-12 08:15:22 UTC (rev 1130) +++ branches/robast-1.2/pkg/ROptEst/R/getAsRisk.R 2018-08-12 08:54:12 UTC (rev 1131) @@ -86,7 +86,7 @@ eerg <- .LowerCaseMultivariate(L2deriv = L2deriv, neighbor = neighbor, biastype = biastype, normtype = normtype, Distr = Distr, Finfo = Finfo, trafo = trafo, z.start = z.start, A.start = A.start, z.comp = z.comp, - A.comp = DA.comp, maxiter = maxiter, tol = tol, verbose = verbose) + A.comp = DA.comp, maxiter = maxiter, tol = tol, verbose = verbose, ...) erg <- eerg$erg bias <- 1/erg$value @@ -112,7 +112,7 @@ neighbor = neighbor, biastype = biastype, normtype = normtype, Distr = Distr, Finfo = Finfo, trafo = trafo, A.start = A.start, maxiter = maxiter, - tol = tol, verbose = verbose) + tol = tol, verbose = verbose, ...) erg <- eerg$b bias <- 1/erg$value @@ -167,7 +167,7 @@ Cov <- getInfV(L2deriv = L2deriv, neighbor = neighbor, biastype = biastype, Distr = Distr, V.comp = V.comp, cent = cent, - stand = stand, w = w) + stand = stand, w = w, ...) if(!is.null(trafo)) Cov <- trafo%*%Cov%*%t(trafo) return(list(asCov = Cov)) }) @@ -219,7 +219,7 @@ Cov <- getAsRisk(risk = asCov(), L2deriv = L2deriv, neighbor = neighbor, biastype = biastype, Distr = Distr, clip = clip, cent = cent, stand = stand, trafo = trafo, - V.comp = V.comp, w = w)$asCov + V.comp = V.comp, w = w, ...)$asCov p <- nrow(stand) std <- if(is(normtype,"QFNorm")) QuadForm(normtype) else diag(p) @@ -255,7 +255,7 @@ biastype = biastype, normtype = normtype, Distr = Distr, clip = clip, cent = cent, stand = stand, V.comp = V.comp, - w = w)$trAsCov + w = w, ...)$trAsCov return(list(asAnscombe = FI/trAsCov.0)) }) Modified: branches/robast-1.2/pkg/ROptEst/R/getComp.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getComp.R 2018-08-12 08:15:22 UTC (rev 1130) +++ branches/robast-1.2/pkg/ROptEst/R/getComp.R 2018-08-12 08:54:12 UTC (rev 1131) @@ -8,6 +8,7 @@ if(L2derivDistrSymm[[i]]@SymmCenter == 0) z.comp[i] <- FALSE } + if(nrvalues>1){ for(i in 1:(nrvalues-1)) for(j in (i+1):nrvalues){ if(is(DistrSymm, "SphericalSymmetry")){ @@ -19,6 +20,7 @@ } } A.comp[col(A.comp) < row(A.comp)] <- FALSE + } return(list(A.comp = A.comp, z.comp = z.comp)) } Modified: branches/robast-1.2/pkg/ROptEst/R/getInfCent.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfCent.R 2018-08-12 08:15:22 UTC (rev 1130) +++ branches/robast-1.2/pkg/ROptEst/R/getInfCent.R 2018-08-12 08:54:12 UTC (rev 1131) @@ -39,7 +39,11 @@ neighbor = "TotalVarNeighborhood", biastype = "BiasType"), function(L2deriv, neighbor, biastype, Distr, z.comp, w, - tol.z = .Machine$double.eps^.5){ + tol.z = .Machine$double.eps^.5, ...){ + + dotsI <- .filterEargs(list(...)) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE + stand <- stand(w) clip <- clip(w) b <- clip[2]-clip[1] @@ -51,7 +55,7 @@ Y <- as.numeric(stand%*%Lx) pmin(pmax(g,Y),g+c0) } - return(E(object = Distr, fun = fct, useApply = FALSE)) + return(do.call(E, c(list(object = Distr, fun = fct), dotsI))) } lower <- -b upper <- 0 @@ -64,7 +68,11 @@ neighbor = "ContNeighborhood", biastype = "BiasType"), function(L2deriv, neighbor, biastype, Distr, z.comp, w, - tol.z = .Machine$double.eps^.5){ + tol.z = .Machine$double.eps^.5, ...){ + + dotsI <- .filterEargs(list(...)) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE + integrand1 <- function(x){ weight(w)(evalRandVar(L2deriv, as.matrix(x)) [,,1]) } @@ -72,13 +80,13 @@ return(L2.i(x)*integrand1(x)) } - res1 <- E(object = Distr, fun = integrand1, useApply = FALSE) + res1 <- do.call(E, c(list(object = Distr, fun = integrand1),dotsI)) nrvalues <- length(L2deriv) res2 <- numeric(nrvalues) for(i in 1:nrvalues){ if(z.comp[i]){ - res2[i] <- E(object = Distr, fun = integrand2, - L2.i = L2deriv at Map[[i]], useApply = FALSE) + res2[i] <- do.call(E, c(list(object = Distr, fun = integrand2, + L2.i = L2deriv at Map[[i]]), dotsI)) }else{ res2[i] <- 0 } Modified: branches/robast-1.2/pkg/ROptEst/R/getInfClip.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfClip.R 2018-08-12 08:15:22 UTC (rev 1130) +++ branches/robast-1.2/pkg/ROptEst/R/getInfClip.R 2018-08-12 08:54:12 UTC (rev 1131) @@ -35,11 +35,11 @@ risk = "asMSE", neighbor = "UncondNeighborhood"), function(clip, L2deriv, risk, neighbor, biastype, - Distr, stand, cent, trafo){ + Distr, stand, cent, trafo, ...){ return(neighbor at radius^2*clip + getInfGamma(L2deriv = L2deriv, risk = risk, neighbor = neighbor, biastype = biastype, Distr = Distr, stand = stand, - cent = cent, clip = clip)) + cent = cent, clip = clip, ...)) }) ############################################################################### @@ -155,7 +155,11 @@ L2deriv = "UnivariateDistribution", risk = "asSemivar", neighbor = "ContNeighborhood"), - function(clip, L2deriv, risk, neighbor, biastype, cent, symm, trafo){ + function(clip, L2deriv, risk, neighbor, biastype, cent, symm, trafo, ...){ + + dotsI <- .filterEargs(list(...)) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE + biastype <- if(sign(risk)==1) positiveBias() else negativeBias() z0 <- getInfCent(L2deriv = L2deriv, risk = risk, neighbor = neighbor, biastype = biastype, @@ -168,9 +172,9 @@ r <- neighbor at radius if (sign(risk)>0) - v0 <- E(L2deriv, function(x) pmin( x-z0, clip)^2 ) + v0 <- do.call(E,c(list(L2deriv, function(x) pmin( x-z0, clip)^2),dotsI)) else - v0 <- E(L2deriv, function(x) pmax( x-z0, -clip)^2 ) + v0 <- do.call(E,c(list(L2deriv, function(x) pmax( x-z0, -clip)^2),dotsI)) s0 <- sqrt(v0) sv <- r * clip / s0 Modified: branches/robast-1.2/pkg/ROptEst/R/getInfGamma.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfGamma.R 2018-08-12 08:15:22 UTC (rev 1130) +++ branches/robast-1.2/pkg/ROptEst/R/getInfGamma.R 2018-08-12 08:54:12 UTC (rev 1131) @@ -29,7 +29,11 @@ neighbor = "ContNeighborhood", biastype = "BiasType"), function(L2deriv, risk, neighbor, biastype, Distr, - stand, cent, clip, power = 1L){ + stand, cent, clip, power = 1L, ...){ + + dotsI <- .filterEargs(list(...)) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE + integrandG <- function(x, L2, stand, cent, clip){ X <- evalRandVar(L2, as.matrix(x))[,,1] - cent Y <- stand %*% X @@ -38,8 +42,9 @@ return((res > 0)*res^power) } - return(-E(object = Distr, fun = integrandG, L2 = L2deriv, - stand = stand, cent = cent, clip = clip, useApply = FALSE)) + res <- do.call(E, c(list(object = Distr, fun = integrandG, L2 = L2deriv, + stand = stand, cent = cent, clip = clip),dotsI)) + return(-res) }) setMethod("getInfGamma", signature(L2deriv = "RealRandVariable", @@ -47,7 +52,11 @@ neighbor = "TotalVarNeighborhood", biastype = "BiasType"), function(L2deriv, risk, neighbor, biastype, Distr, - stand, cent, clip, power = 1L){ + stand, cent, clip, power = 1L, ...){ + + dotsI <- .filterEargs(list(...)) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE + integrandG <- function(x, L2, stand, cent, clip){ X <- evalRandVar(L2, as.matrix(x))[,,1] - cent Y <- stand %*% X @@ -56,8 +65,9 @@ return((res > 0)*res^power) } - return(-E(object = Distr, fun = integrandG, L2 = L2deriv, - stand = stand, cent = cent, clip = clip, useApply = FALSE)) + res <- do.call(E, c(list(object = Distr, fun = integrandG, L2 = L2deriv, + stand = stand, cent = cent, clip = clip),dotsI)) + return(-res) }) ############################################################################### ## gamma in case of asymptotic under-/overshoot risk Modified: branches/robast-1.2/pkg/ROptEst/R/getInfLM.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfLM.R 2018-08-12 08:15:22 UTC (rev 1130) +++ branches/robast-1.2/pkg/ROptEst/R/getInfLM.R 2018-08-12 08:54:12 UTC (rev 1131) @@ -6,7 +6,7 @@ neighbor, biastype, normtype, Distr, a.start, z.start, A.start, w.start, std, z.comp, A.comp, maxiter, tol, - verbose = NULL, warnit = TRUE){ + verbose = NULL, warnit = TRUE, ...){ if(missing(verbose)|| is.null(verbose)) verbose <- getRobAStBaseOption("all.verbose") if(missing(warnit)|| is.null(warnit)) warnit <- TRUE @@ -43,7 +43,7 @@ ## update centering z <- getInfCent(L2deriv = L2deriv, neighbor = neighbor, biastype = biastype, Distr = Distr, z.comp = z.comp, - w = w, tol.z = .Machine$double.eps^.5) + w = w, tol.z = .Machine$double.eps^.5, ...) # print(c("z"=z)) if(is(neighbor,"TotalVarNeighborhood")){ a <- z @@ -56,7 +56,7 @@ # update standardization A <- getInfStand(L2deriv = L2deriv, neighbor = neighbor, biastype = biastype, Distr = Distr, A.comp = A.comp, - cent = zc, trafo = trafo, w = w) + cent = zc, trafo = trafo, w = w, ...) # print(c("A"=A)) ## in case of self-standardization: update norm @@ -106,11 +106,16 @@ a.start, z.start, A.start, w.start, std, z.comp, A.comp, maxiter, tol, verbose = NULL, ...){ + if(missing(verbose)|| is.null(verbose)) verbose <- getRobAStBaseOption("all.verbose") LMcall <- match.call() ### manipulate dots in call -> set control argument for optim dots <- list(...) + + dotsI <- .filterEargs(dots) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE + if(is.null(dots$method)) dots$method <- "L-BFGS-B" if(!is.null(dots$control)){ @@ -171,7 +176,7 @@ -getInfGamma(L2deriv = L2deriv, risk = risk0, neighbor = neighbor, biastype = biastype, Distr = Distr, stand = A0, cent = z0, clip = b1, - power = 2)+radius(neighbor)^2*b1^2 + power = 2,...)+radius(neighbor)^2*b1^2 } b0 <- optimize(funint.opt, interval=c(1e-8,1e8))$minimum @@ -223,7 +228,7 @@ getInfGamma(L2deriv = L2deriv, risk = riskA, neighbor = neighbor, biastype = biastype, Distr = Distr, stand = A0, cent = z0, clip = b0, - power = 2)/2 - + power = 2,...)/2 - # ~ - E[|Y_A|_Q^2 (1-w_b(|Y_A|_Q))^2]/2 sum(diag(std0%*%A0%*%t(trafo)) )) ## ~tr_Q AD' @@ -231,32 +236,30 @@ ## in case TotalVarNeighborhood additional correction term: if(is(neighbor,"TotalVarNeighborhood")) val <- (val -a0^2/2 - - E(Distr, fun = function(x){ ## ~ - E Y_-^2/2 + do.call(E, c(list(Distr, fun = function(x){ ## ~ - E Y_-^2/2 L2 <- evalRandVar(L2deriv, as.matrix(x)) [,,1]- z0 Y <- A0 %*% L2 return(Y^2*(Y<0)) - }, useApply = FALSE)/2) + }),dotsI))/2) }else if(is(riskA,"asMSE")){ - val <- (E(object = Distr, fun = function(x){ + val <- (do.call(E, c(list(object = Distr, fun = function(x){ X <- evalRandVar(L2deriv, as.matrix(x))[,,1] - z0 Y <- A0 %*% X nY <- norm(risk0)(Y) return(nY^2*weight(w0)(X)) - }, # E|Y|^2 w - useApply=FALSE) /2 - + }),dotsI))/2 - # E|Y|^2 w sum(diag(std0%*%A0%*%t(trafo)) )) ## ~tr_Q AD' ## in case TotalVarNeighborhood additional correction term: if(is(neighbor,"TotalVarNeighborhood")) val <- (val -a0^2/2 - - E(Distr, fun = function(x){ + do.call(E,c(list(Distr, fun = function(x){ X <- evalRandVar(L2deriv, as.matrix(x))[,,1] - z0 Y <- A0 %*% X return(Y^2*(Y<0)) - }, - useApply=FALSE)/2) + }),dotsI))/2) } ## if this is the current optimum Modified: branches/robast-1.2/pkg/ROptEst/R/getInfRad.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfRad.R 2018-08-12 08:15:22 UTC (rev 1130) +++ branches/robast-1.2/pkg/ROptEst/R/getInfRad.R 2018-08-12 08:54:12 UTC (rev 1131) @@ -30,10 +30,10 @@ risk = "asMSE", neighbor = "UncondNeighborhood"), function(clip, L2deriv, risk, neighbor, biastype, - Distr, stand, cent, trafo){ + Distr, stand, cent, trafo, ...){ gamm <- getInfGamma(L2deriv = L2deriv, risk = risk, neighbor = neighbor, biastype = biastype, Distr = Distr, stand = stand, - cent = cent, clip = clip) + cent = cent, clip = clip, ...) return((-gamm/clip)^.5) }) Modified: branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R 2018-08-12 08:15:22 UTC (rev 1130) +++ branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R 2018-08-12 08:54:12 UTC (rev 1131) @@ -109,6 +109,9 @@ OptOrIter = "iterate", maxiter, tol, warn, verbose = NULL, checkBounds = TRUE, ...){ + dotsI <- .filterEargs(list(...)) + if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE + if(missing(verbose)|| is.null(verbose)) verbose <- getRobAStBaseOption("all.verbose") @@ -156,7 +159,7 @@ trafo = trafo, maxiter = maxiter, tol = tol, warn = FALSE, Finfo = Finfo, - QuadForm = std, verbose = verbose) + QuadForm = std, verbose = verbose,...) if(is.null(lower)||(lower< lowBerg$b)) {lower <- lowBerg$b @@ -212,12 +215,12 @@ chkbd <- if(it.erg<25) FALSE else checkBounds verbL <- if(it.erg<25) FALSE else verbose - erg <<- getInfRobIC(L2deriv, risk.b, neighbor, + erg <<- do.call(getInfRobIC, c(list(L2deriv, risk.b, neighbor, Distr, DistrSymm, L2derivSymm, L2derivDistrSymm, Finfo, trafo, onesetLM = onesetLM, z.start, A.start, upper = upper, lower = lower, OptOrIter = OptOrIter, maxiter = maxi, tol = toli , warn = warn, - verbose = verbL, checkBounds = chkbd, ...) + verbose = verbL, checkBounds = chkbd), dotsI)) trV <- erg$risk$trAsCov$value if(verbose) cat("Outer iteration:", it.erg," b_0=", round(b0,3), " eff=", round(trV.ML/trV,3), "\n") Modified: branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asBias.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asBias.R 2018-08-12 08:15:22 UTC (rev 1130) +++ branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asBias.R 2018-08-12 08:54:12 UTC (rev 1131) @@ -32,6 +32,9 @@ A.start, Finfo, trafo, maxiter, tol, warn, verbose = NULL, ...){ + dots <- list(...) + dotsnames <- names(dots) + if(missing(verbose)|| is.null(verbose)) verbose <- getRobAStBaseOption("all.verbose") @@ -52,14 +55,20 @@ )) if(warn) cat(warntxt) neighbor at radius <- 15 - res <- getInfRobIC(L2deriv = L2deriv, - risk = asMSE(normtype = normtype), - neighbor = neighbor, Distr = Distr, - DistrSymm = DistrSymm, L2derivSymm = L2derivSymm, - L2derivDistrSymm = L2derivDistrSymm, Finfo = Finfo, - trafo = trafo, onesetLM = FALSE, z.start = z.start, - A.start = A.start, upper = 1e4, maxiter = maxiter, + getInfRobICargList <- list(L2deriv = L2deriv, + risk = asMSE(normtype = normtype), + neighbor = neighbor, Distr = Distr, + DistrSymm = DistrSymm, L2derivSymm = L2derivSymm, + L2derivDistrSymm = L2derivDistrSymm, Finfo = Finfo, + trafo = trafo, onesetLM = FALSE, z.start = z.start, + A.start = A.start, upper = 1e4, maxiter = maxiter, tol = tol, warn = warn, verbose = verbose) + + for(item in dotsnames) + if(!item %in% names(getInfRobICargList)) + getInfRobICargList[[item]] <- dots[[item]] + + res <- do.call(getInfRobIC,getInfRobICargList) A.max <- max(abs(res$A)) res$A <- res$A/A.max @@ -189,7 +198,7 @@ biastype = "BiasType"), function(L2deriv, neighbor, biastype, normtype, Distr, z.start, A.start, z.comp, A.comp, Finfo, trafo, maxiter, tol, - verbose = NULL){ + verbose = NULL, ...){ if(missing(verbose)|| is.null(verbose)) verbose <- getRobAStBaseOption("all.verbose") @@ -197,7 +206,7 @@ eerg <- .LowerCaseMultivariate(L2deriv = L2deriv, neighbor = neighbor, biastype = biastype, normtype = normtype, Distr = Distr, Finfo = Finfo, trafo, z.start, A.start = A.start, z.comp = z.comp, - A.comp = DA.comp, maxiter = maxiter, tol = tol, verbose = verbose) + A.comp = DA.comp, maxiter = maxiter, tol = tol, verbose = verbose, ...) erg <- eerg$erg b <- 1/erg$value @@ -229,7 +238,7 @@ Cov <- getInfV(L2deriv = L2deriv, neighbor = neighbor, biastype = biastype, Distr = Distr, [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/robast -r 1131 From noreply at r-forge.r-project.org Sun Aug 12 17:52:53 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 17:52:53 +0200 (CEST) Subject: [Robast-commits] r1132 - branches/robast-1.2/pkg/RobAStBase/R Message-ID: <20180812155253.3A89118A2C5@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 17:52:52 +0200 (Sun, 12 Aug 2018) New Revision: 1132 Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R Log: [RobAStBase] 1.branch 2 + yet another time bug fixes : L2Fam instead of L2Fam0 + better vectorized code gemerated by generateICfct.R + getRisk IC caused quite a bit of delay -- now avoids this useApply issue Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-12 08:54:12 UTC (rev 1131) +++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-12 15:52:52 UTC (rev 1132) @@ -100,7 +100,8 @@ cent <- res$E.IC stand <- trafo %*% distr::solve(res$E.IC.L, generalized = TRUE) - Y <- as(stand %*% (IC1 - cent), "EuclRandVariable") + IC1.0 <- IC1 - cent + Y <- as(stand %*% IC1.0, "EuclRandVariable") modifyIC <- IC at modifyIC @@ -123,7 +124,7 @@ ## make some L2function a pIC at a model setMethod("makeIC", signature(IC = "IC", L2Fam = "missing"), function(IC, ...){ - L2Fam0 <- eval(IC at CallL2Fam) + L2Fam <- eval(IC at CallL2Fam) getMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"))( IC = IC, L2Fam = L2Fam, ...) }) Modified: branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R 2018-08-12 08:54:12 UTC (rev 1131) +++ branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R 2018-08-12 15:52:52 UTC (rev 1132) @@ -3,7 +3,7 @@ setMethod("generateIC.fct", signature(neighbor = "UncondNeighborhood", L2Fam = "L2ParamFamily"), function(neighbor, L2Fam, res){ A <- as.matrix(res$A) - a <- if(is(neighbor,"TotalVarNeighborhood")) 0 else res$a + a <- if(is(neighbor,"TotalVarNeighborhood")) 0 else res$a b <- res$b d <- if(!is.null(res$d)) res$d else 0 w <- weight(res$w) @@ -20,16 +20,15 @@ if(dims==1L){ body(ICfct[[1]]) <- substitute( { Lx <- L(x); wx <- w(Lx) - print(str(a)); print(str(A));print(str(Lx)); print(str(w(Lx))) Yx <- A %*% Lx - a - ifelse(.eq(Yx),zi*d*b,as.numeric(Yx*w(Lx))) }, + ifelse(1-.eq(Yx),as.numeric(Yx*w(Lx)),zi*d*b) }, list(L = L.fct, w = w, b = b, d = d, A = A, a = a, zi = sign(trafo(L2Fam at param)), .eq = .eq)) }else{ body(ICfct[[1]]) <- substitute( { Lx <- L(x); wx <- w(Lx) Yx <- A %*% Lx - a - ifelse(.eq(Yx), NA, as.numeric(Yx*w(Lx))) }, + ifelse(1-.eq(Yx), as.numeric(Yx*w(Lx)), NA) }, list(L = L.fct, w = w, b = b, d = d, A = A, a = a, .eq = .eq)) } @@ -44,9 +43,9 @@ if(!is.null(res$d)) for(i in 1:nrvalues){ ICfct[[i]] <- function(x){} - body(ICfct[[i]]) <- substitute({Lx <- L(x);wx <- w(Lx) - Yix <- Ai %*% Lx - ai - ifelse(.eq(Yix), di, as.numeric(Yix*wx)) + body(ICfct[[i]]) <- substitute({Lx <- L(x) + Yix <- Ai %*% Lx - ai ; # print(dim(Yix)); print(head(Yix[,1:10])); + as.numeric(Yix*w(Lx) + .eq(Yix)*di) }, list(L = L.fct, Ai = A[i,,drop=FALSE], ai = a[i], w = w, di = d[i]))#, .eq = .eq)) @@ -54,9 +53,9 @@ else for(i in 1:nrvalues){ ICfct[[i]] <- function(x){} - body(ICfct[[i]]) <- substitute({Lx <- L(x);wx <- w(Lx) + body(ICfct[[i]]) <- substitute({Lx <- L(x) Yix <- Ai %*% Lx - ai - as.numeric(Yix*wx) }, + as.numeric(Yix*w(Lx)) }, list(L = L.fct, Ai = A[i,,drop=FALSE], ai = a[i], w = w)) } } Modified: branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-12 08:54:12 UTC (rev 1131) +++ branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-12 15:52:52 UTC (rev 1132) @@ -30,15 +30,33 @@ if(dimension(Domain(IC at Curve[[1]])) != dimension(img(L2Fam at distribution))) stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") + dotsI <- .filterEargs(list(...)) + if(!is.null(dotsI$useApply)) dotsI$useApply <- FALSE + if(missing(withCheck)) withCheck <- TRUE IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable") - bias <- E(L2Fam, IC1, ...) - Cov <- E(L2Fam, IC1 %*% t(IC1), ...) + Distr <- L2Fam at distribution + nrvalues <- nrow(trafo(L2Fam)) - if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...) + cent <- numeric(nrvalues) + for(i in 1:nrvalues){ + cent[i] <- do.call(E,c(list(object = Distr, fun = IC1 at Map[[i]]), dotsI)) + } - return(list(asCov = list(distribution = .getDistr(L2Fam), value = Cov - bias %*% t(bias)))) + Cova <- matrix(0, ncol = nrvalues, nrow = nrvalues) + + for(i in 1:nrvalues){ + for(j in i:nrvalues){ + Cova[i,j] <- do.call(E,c(list(object = Distr, + fun = function(x){ + return((IC1 at Map[[i]](x)-cent[i])*(IC1 at Map[[j]](x)-cent[j]))}), + dotsI)) + } + } + Cova[col(Cova) < row(Cova)] <- t(Cova)[col(Cova) < row(Cova)] + # if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...) + return(list(asCov = list(distribution = .getDistr(L2Fam), value = Cova))) }) ############################################################################### Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-12 08:54:12 UTC (rev 1131) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-12 15:52:52 UTC (rev 1132) @@ -152,18 +152,17 @@ pICList <- if(withPICList) vector("list", steps) else NULL ICList <- if(withICList) vector("list", steps) else NULL - cvar.fct <- function(L2, IC, dim, dimn =NULL){} - body(cvar.fct) <- substitute({ - EcallArgs <- c(list(L2, IC %*% t(IC)), E.argList0) - Eres <- do.call(E,EcallArgs) + cvar.fct <- function(L2, IC, dim, dimn =NULL){ + Eres <- matrix(NA,dim,dim) + if(!is.null(dimn)) dimnames(Eres) <- dimn + L2M <- L2 at Curve[[1]]@Map + for(i in 1: dim) + for(j in i: dim) + Eres[i,j] <- E(L2 at distribution, + fun = function(x) L2M[[i]](x)*L2M[[j]](x), + useApply = FALSE) + return(res)} - if(is.null(dimn)){ - return(matrix(Eres,dim,dim)) - }else{ - return(matrix(Eres,dim,dim, dimnames = dimn)) - } - }, list(E.argList0 = E.argList)) - ##-t-## updStp <- 0 ### update - function updateStep <- function(u.theta, theta, IC, L2Fam, Param, @@ -483,8 +482,8 @@ getRiskICasVarArgs <- c(list(IC, risk = asCov(), withCheck = FALSE),E.argList) riskAsVar <- do.call(getRiskIC, getRiskICasVarArgs) asVar <- riskAsVar$asCov$value - } ##-t-## }) + } ##-t-## sytm <- .addTime(sytm,syt,"getRiskIC-Var") }else asVar <- var0 From noreply at r-forge.r-project.org Sun Aug 12 17:54:52 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 17:54:52 +0200 (CEST) Subject: [Robast-commits] r1133 - branches/robast-1.2/pkg/ROptEst/R Message-ID: <20180812155452.57D8818A2C5@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 17:54:52 +0200 (Sun, 12 Aug 2018) New Revision: 1133 Modified: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R branches/robast-1.2/pkg/ROptEst/R/getInfV.R Log: [ROptEst] branch 1.2 bugfixes in the new, faster CheckIC /MakeIC method (in particular the Curve in make IC was completely wrong!) Modified: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R 2018-08-12 15:52:52 UTC (rev 1132) +++ branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R 2018-08-12 15:54:52 UTC (rev 1133) @@ -26,7 +26,8 @@ A <- stand(IC); a <- cent(IC) G1 <- res$G1; G2 <- res$G2; G3 <- res$G3 Delta1 <- A%*%G2- a*G1 - Delta2 <- A%*%G3 - a%*%t(G2) - trafo(L2Fam at param) + Delta2 <- A%*%G3 - a%*%t(G2) + Delta2 <- Delta2 - trafo(L2Fam) if(out) cat("precision of centering:\t", Delta1, "\n") @@ -52,6 +53,7 @@ if( dimension(Domain(IC at Curve[[1]])) != dimension(img(D1))) stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") + dims <- nrow(trafo(L2Fam)) if(dimension(IC at Curve) != dims) stop("Dimension of IC and parameter must be equal") @@ -71,34 +73,32 @@ L2Fam = "L2ParamFamily"))(IC,L2Fam)) G1 <- res$G1; G2 <- res$G2; G3 <- res$G3 - trafo <- trafo(L2Fam at param) - nrvalues <- nrow(trafo) - dims <- ncol(trafo) + trafO <- trafo(L2Fam at param) + nrvalues <- nrow(trafO) + dims <- ncol(trafO) - cent0 <- G2/G1 - stand1 <- trafo%*%distr::solve(G3-cent0%*%t(G2)) - cent1 <- stand1%*%cent0 - - L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable") + cent0 <- c(G2/G1) + stand1 <- trafO%*%distr::solve(G3-cent0%*%t(G2)) + cent1 <- c(stand1%*%cent0) +# print(list(stand1,stand(IC),cent1,cent(IC))) + L2.f <- as(diag(nrvalues) %*% L2Fam at L2deriv , "EuclRandVariable") D1 <- L2Fam at distribution - IC1.0 <- stand1%*%L2deriv - IC1.1 <- IC1.0 -cent1 - IC1.f <- function(x) evalRandVar(IC1.1,x) + IC1.f <- function(x){ indS <- liesInSupport(D1,x,checkFin=TRUE) + Lx <- sapply(x, function(y) evalRandVar(L2.f,y)) + indS* (stand1%*%Lx-cent1) * weight(IC at weight)(Lx)} IC1.l <- vector("list",nrvalues) for(i in 1:nrvalues){ IC1.l[[i]] <- function(x){} - body(IC.l[[i]]) <- substitute({indS <- liesInSupport(D0,x,checkFin=TRUE) - indS*((IC1.s(x))[i]) - }, list(IC1.s=IC1.f, D0=D1, i=i)) + body(IC1.l[[i]]) <- substitute( c((IC1.s(x))[i,]), list(IC1.s=IC1.f, i=i)) } - IC1.c <- EuclRandVariable(Map = IC1.l, Domain = IC at Curve[[1]], + IC1.c <- EuclRandVariable(Map = IC1.l, Domain = Domain(IC at Curve[[1]]), Range = Reals()) cIC1 <- new("ContIC") - cIC1 at name <- name - cIC1 at Curve <- IC1.c + cIC1 at name <- IC at name + cIC1 at Curve <- EuclRandVarList(IC1.c) cIC1 at Risks <- IC at Risks cIC1 at Infos <- IC at Infos cIC1 at CallL2Fam <- L2Fam at fam.call @@ -131,6 +131,7 @@ z.comp <- rep(TRUE,dims) A.comp <- matrix(TRUE, dims, dims) +# print(list(z.comp,A.comp)) # otherwise if trafo == unitMatrix may use symmetry info if(.isUnitMatrix(trafo)){ comp <- .getComp(L2deriv, L2Fam at distrSymm, L2Fam at L2derivSymm, L2Fam at L2derivDistrSymm) Modified: branches/robast-1.2/pkg/ROptEst/R/getInfV.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfV.R 2018-08-12 15:52:52 UTC (rev 1132) +++ branches/robast-1.2/pkg/ROptEst/R/getInfV.R 2018-08-12 15:54:52 UTC (rev 1133) @@ -51,7 +51,6 @@ integrandV <- function(x, L2.i, L2.j, i, j){ return((L2.i(x) - cent0[i])*(L2.j(x) - cent0[j])*w.fct(x = x)) } - nrvalues <- length(L2deriv) erg <- matrix(0, ncol = nrvalues, nrow = nrvalues) for(i in 1:nrvalues) From noreply at r-forge.r-project.org Sun Aug 12 17:57:03 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 17:57:03 +0200 (CEST) Subject: [Robast-commits] r1134 - in branches/robast-1.2/pkg/RobExtremes: R inst/scripts man Message-ID: <20180812155703.109A418A2C5@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 17:57:02 +0200 (Sun, 12 Aug 2018) New Revision: 1134 Modified: branches/robast-1.2/pkg/RobExtremes/R/asvarMedkMAD.R branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R branches/robast-1.2/pkg/RobExtremes/R/internal-getpsi.R branches/robast-1.2/pkg/RobExtremes/R/makeIC.R branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R branches/robast-1.2/pkg/RobExtremes/man/internal-interpolate.Rd Log: [RobEstremes] branch 2.8 + as with the interpolating - getStartIC methods in ROptEst, the makeIC-task is removed from the inner .modifyIC.0 function and delegated to the outer .modifyIC , so .getPsi, getPsi.wL, and .getPsi.P loose their argument withMakeIC + in asvarMedkMAD we now use distr::solve + in the getStartIC methods for interpolators, we now produce slots modifyIC with argument withMakeIC (as before) and with ... to pass on arguments to E() (e.g., when makeIC is called) + the timings are now about ~ 2s per estimator for GEV and GPD and check/makeIC are much faster + script updated + makeIC also gains ... argument Modified: branches/robast-1.2/pkg/RobExtremes/R/asvarMedkMAD.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/asvarMedkMAD.R 2018-08-12 15:54:52 UTC (rev 1133) +++ branches/robast-1.2/pkg/RobExtremes/R/asvarMedkMAD.R 2018-08-12 15:57:02 UTC (rev 1134) @@ -54,7 +54,7 @@ D1 <- matrix(c(dG1_beta,dG2_beta,dG1_xi,dG2_xi),2,2) D2 <- matrix(c(dG1_M,dG2_M,dG1_m,dG2_m),2,2) - D <- -solve(D1)%*%D2 + D <- - distr::solve(D1)%*%D2 }else{ psi_med <- function(x) (0.5-(x<=m))/dm psi_kMad <- function(x){ @@ -71,7 +71,7 @@ E12 <- E(distribution(model),fun=function(x) psi_kMad(x) * L_xi.f(x)) E21 <- E(distribution(model),fun=function(x) psi_med(x) * L_beta.f(x)) E22 <- E(distribution(model),fun=function(x) psi_med(x) * L_xi.f(x)) - D <- solve(matrix(c(E11,E21,E12,E22),2,2)) + D <- distr::solve(matrix(c(E11,E21,E12,E22),2,2)) } ASV_Med <- PosSemDefSymmMatrix(D %*% V %*% t(D)) Modified: branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R 2018-08-12 15:54:52 UTC (rev 1133) +++ branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R 2018-08-12 15:57:02 UTC (rev 1134) @@ -26,36 +26,36 @@ if(length(nsng)){ if(gridn %in% nsng){ interpolfct <- famg[[gridn]][[.versionSuff("fun")]] - rm(famg, nsgn, gridn) + rm(famg, nsng, gridn) .modifyIC0 <- function(L2Fam, IC, withMakeIC = FALSE){ para <- param(L2Fam) if(!.is.na.Psi(para, interpolfct, shnam)) - return(.getPsi(para, interpolfct, L2Fam, type(risk), - withMakeIC = withMakeIC)) + return(.getPsi(para, interpolfct, L2Fam, type(risk))) else{ IC0 <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2)) - if(withMakeIC) IC0 <- makeIC(IC0, L2Fam) return(IC0) } } - .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE){ - psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC = withMakeIC) + .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE, ...){ + psi.0 <- .modifyIC0(L2Fam,IC) psi.0 at modifyIC <- .modifyIC + if(withMakeIC) psi.0 <- makeIC(psi.0, L2Fam, ...) return(psi.0) } if(!.is.na.Psi(param1, interpolfct, shnam)){ - IC0 <- .getPsi(param1, interpolfct, model, type(risk), withMakeIC = withMakeIC) + IC0 <- .getPsi(param1, interpolfct, model, type(risk)) IC0 at modifyIC <- .modifyIC + if(withMakeIC) IC0 <- makeIC(IC0, model, ...) return(IC0) } rm(mc) } } - rm(famg, nsgn,gridn) + rm(famg, nsng,gridn) IC <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2)) - if(withMakeIC) IC <- makeIC(IC,model) + if(withMakeIC) IC <- makeIC(IC,model,...) return(IC) }) @@ -78,39 +78,39 @@ shnam <- locscshnm["shape"] nsng <- character(0) famg <- try(getFromNamespace(nam, ns = "RobAStRDA"), silent=TRUE) - #sng <- try(getFromNamespace(gridn, ns = "RobAStRDA"), silent=TRUE) if(!is(famg,"try-error")) nsng <- names(famg) if(length(nsng)){ if(gridn %in% nsng){ interpolfct <- famg[[gridn]][[.versionSuff("fun")]] - .modifyIC0 <- function(L2Fam, IC, withMakeIC = FALSE){ + rm(famg, nsng, gridn) + .modifyIC0 <- function(L2Fam, IC){ para <- param(L2Fam) if(!.is.na.Psi(para, interpolfct, shnam)) - return(.getPsi.wL(para, interpolfct, L2Fam, type(risk), - withMakeIC = withMakeIC)) + return(.getPsi.wL(para, interpolfct, L2Fam, type(risk))) else{ IC0 <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2)) - if(withMakeIC) IC0 <- makeIC(IC0, L2Fam) return(IC0) } } - .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE){ - psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC = withMakeIC) + .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE, ...){ + psi.0 <- .modifyIC0(L2Fam,IC) psi.0 at modifyIC <- .modifyIC + if(withMakeIC) psi.0 <- makeIC(psi.0, L2Fam, ...) return(psi.0) } if(!.is.na.Psi(param1, interpolfct, shnam)){ - IC0 <- .getPsi.wL(param1, interpolfct, model, type(risk), - withMakeIC = withMakeIC) + IC0 <- .getPsi.wL(param1, interpolfct, model, type(risk)) IC0 at modifyIC <- .modifyIC + if(withMakeIC) IC0 <- makeIC(IC0, model, ...) return(IC0) } } } + rm(famg, nsng,gridn) IC <- do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2)) - if(withMakeIC) IC <- makeIC(IC,model) + if(withMakeIC) IC <- makeIC(IC,model,...) return(IC) }) Modified: branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R 2018-08-12 15:54:52 UTC (rev 1133) +++ branches/robast-1.2/pkg/RobExtremes/R/getStartICPareto.R 2018-08-12 15:57:02 UTC (rev 1134) @@ -3,21 +3,23 @@ param1 <- param(model) xi <- main(param1) - .modifyIC0 <- function(L2Fam, IC, withMakeIC = FALSE){ + .modifyIC0 <- function(L2Fam, IC){ xi0 <- main(param(L2Fam)) - return(.getPsi.P(xi0, L2Fam, type(risk), withMakeIC = withMakeIC)) + return(.getPsi.P(xi0, L2Fam, type(risk))) } - .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE){ - psi.0 <- .modifyIC0(L2Fam,IC, withMakeIC = withMakeIC) + .modifyIC <- function(L2Fam,IC, withMakeIC = FALSE, ...){ + psi.0 <- .modifyIC0(L2Fam,IC) psi.0 at modifyIC <- .modifyIC + if(withMakeIC) psi.0 <- makeIC(psi.0, L2Fam, ...) return(psi.0) } - IC0 <- .getPsi.P(xi, model, type(risk), withMakeIC = withMakeIC) + IC0 <- .getPsi.P(xi, model, type(risk)) IC0 at modifyIC <- .modifyIC + if(withMakeIC) IC0 <- makeIC(IC0, model, ...) return(IC0) }) -.getPsi.P <- function(xi, L2Fam, type, withMakeIC){ +.getPsi.P <- function(xi, L2Fam, type){ ## the respective LMs have been computed ahead of time ## and stored in sysdata.rda of this package ## the code for this computation is in AddMaterial/getLMPareto.R @@ -68,6 +70,5 @@ IC <- generateIC(nb, L2Fam, res) - if(withMakeIC) IC <- makeIC(IC,L2Fam) return(IC) } Modified: branches/robast-1.2/pkg/RobExtremes/R/internal-getpsi.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/internal-getpsi.R 2018-08-12 15:54:52 UTC (rev 1133) +++ branches/robast-1.2/pkg/RobExtremes/R/internal-getpsi.R 2018-08-12 15:57:02 UTC (rev 1134) @@ -2,7 +2,7 @@ xi <- main(param)[nam] return(is.na(fct[[1]](xi))) } -.getPsi <- function(param, fct, L2Fam , type, withMakeIC = FALSE){ +.getPsi <- function(param, fct, L2Fam , type){ scshnm <- scaleshapename(L2Fam) shnam <- scshnm["shape"] @@ -29,7 +29,7 @@ ai <- Ai %*% zi Am <- (Ai+Aa)/2; Ai <- Aa <- Am am <- (ai+aa)/2; ai <- aa <- am - zi <- solve(Ai,ai) + zi <- distr::solve(Ai,ai) } a <- c(.dbeta%*%aa) aw <- c(.dbeta1%*%zi) @@ -61,12 +61,11 @@ IC <- generateIC(nb, L2Fam, res) - if(withMakeIC) IC <- makeIC(IC,L2Fam) return(IC) } -.getPsi.wL <- function(param, fct, L2Fam , type, withMakeIC = FALSE){ +.getPsi.wL <- function(param, fct, L2Fam , type){ scshnm <- scaleshapename(L2Fam) shnam <- scshnm["shape"] @@ -96,7 +95,7 @@ ai <- Ai %*% zi Am <- (Ai+Aa)/2; Ai <- Aa <- Am am <- (ai+aa)/2; ai <- aa <- am - zi <- solve(Ai,ai) + zi <- distr::solve(Ai,ai) } a <- c(.dbeta%*%aa) aw <- c(.dbeta1%*%zi) @@ -128,7 +127,6 @@ IC <- generateIC(nb, L2Fam, res) - if(withMakeIC) IC <- makeIC(IC,L2Fam) return(IC) } Modified: branches/robast-1.2/pkg/RobExtremes/R/makeIC.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/makeIC.R 2018-08-12 15:54:52 UTC (rev 1133) +++ branches/robast-1.2/pkg/RobExtremes/R/makeIC.R 2018-08-12 15:57:02 UTC (rev 1134) @@ -1,4 +1,4 @@ -..makeIC.qtl <- function (IC, L2Fam){ +..makeIC.qtl <- function (IC, L2Fam, ...){ mc <- match.call() mcl <- as.list(mc)[-1] mcl$IC <- IC Modified: branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-12 15:54:52 UTC (rev 1133) +++ branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-12 15:57:02 UTC (rev 1134) @@ -54,8 +54,17 @@ checkIC(pIC(RMXi)) system.time(RMXiw <- RMXEstimator(portpiriei, GEVFam,withMakeIC=TRUE)) checkIC(pIC(RMXiw)) +## uses contIC 0 - 1 standardization... +## for a moment remove this method +oldM <- setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily")) +removeMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily")) +system.time(RMXiw2 <- RMXEstimator(portpiriei, GEVFam,withMakeIC=TRUE)) +checkIC(pIC(RMXiw2)) +setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily")) <- oldM + estimate(RMXi) estimate(RMXiw) +estimate(RMXiw2) ## our output: mlEi Modified: branches/robast-1.2/pkg/RobExtremes/man/internal-interpolate.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/internal-interpolate.Rd 2018-08-12 15:54:52 UTC (rev 1133) +++ branches/robast-1.2/pkg/RobExtremes/man/internal-interpolate.Rd 2018-08-12 15:57:02 UTC (rev 1134) @@ -19,9 +19,9 @@ to be stored in the respective \file{sysdata.rda} file. } \usage{ -.getPsi(param, fct, L2Fam , type, withMakeIC) -.getPsi.wL(param, fct, L2Fam , type, withMakeIC) -.getPsi.P(xi, L2Fam , type, withMakeIC) +.getPsi(param, fct, L2Fam , type) +.getPsi.wL(param, fct, L2Fam , type) +.getPsi.P(xi, L2Fam , type) .is.na.Psi(param, fct, nam = "shape") @@ -102,8 +102,6 @@ \item{namFzus}{character; infix for the name of the \file{.csv}-File to which the results are written; used to split the work on xi-grids into chunks.} - \item{withMakeIC}{logical; if \code{TRUE} the [p]IC is passed through - \code{makeIC} before return.} } \details{ \code{.getpsi} reads the respective interpolating function From noreply at r-forge.r-project.org Sun Aug 12 17:58:23 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 17:58:23 +0200 (CEST) Subject: [Robast-commits] r1135 - in branches/robast-1.2/pkg/RobLox: . R Message-ID: <20180812155823.BCDB818A2C5@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 17:58:23 +0200 (Sun, 12 Aug 2018) New Revision: 1135 Modified: branches/robast-1.2/pkg/RobLox/DESCRIPTION branches/robast-1.2/pkg/RobLox/R/rlOptIC.R branches/robast-1.2/pkg/RobLox/R/rlsOptIC_AL.R branches/robast-1.2/pkg/RobLox/R/roblox.R branches/robast-1.2/pkg/RobLox/R/rsOptIC.R Log: [RobLox] branch 2.8: the modifyIC and makeIC methods gain "..." Modified: branches/robast-1.2/pkg/RobLox/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobLox/DESCRIPTION 2018-08-12 15:57:02 UTC (rev 1134) +++ branches/robast-1.2/pkg/RobLox/DESCRIPTION 2018-08-12 15:58:23 UTC (rev 1135) @@ -4,8 +4,8 @@ Title: Optimally Robust Influence Curves and Estimators for Location and Scale Description: Functions for the determination of optimally robust influence curves and estimators in case of normal location and/or scale. -Depends: R(>= 2.14.0), stats, distrMod(>= 2.5.2), RobAStBase(>= 0.9) -Imports: methods, lattice, RColorBrewer, Biobase, RandVar(>= 0.9.2), distr(>= 2.5.2) +Depends: R(>= 2.14.0), stats, distrMod(>= 2.8.0), RobAStBase(>= 1.2.0) +Imports: methods, lattice, RColorBrewer, Biobase, RandVar(>= 1.1.0), distr(>= 2.8.0) Suggests: MASS Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph"), email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", role=c("aut", Modified: branches/robast-1.2/pkg/RobLox/R/rlOptIC.R =================================================================== --- branches/robast-1.2/pkg/RobLox/R/rlOptIC.R 2018-08-12 15:57:02 UTC (rev 1134) +++ branches/robast-1.2/pkg/RobLox/R/rlOptIC.R 2018-08-12 15:58:23 UTC (rev 1135) @@ -18,12 +18,12 @@ biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC, withMakeIC){ + modIC <- function(L2Fam, IC, withMakeIC, ...){ if(is(L2Fam, "L2LocationFamily") && is(distribution(L2Fam), "Norm")){ CallL2Fam(IC) <- L2Fam at fam.call return(IC) }else{ - makeIC(IC, L2Fam) + makeIC(IC, L2Fam, ...) } } Modified: branches/robast-1.2/pkg/RobLox/R/rlsOptIC_AL.R =================================================================== --- branches/robast-1.2/pkg/RobLox/R/rlsOptIC_AL.R 2018-08-12 15:57:02 UTC (rev 1134) +++ branches/robast-1.2/pkg/RobLox/R/rlsOptIC_AL.R 2018-08-12 15:58:23 UTC (rev 1135) @@ -157,7 +157,7 @@ biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC, withMakeIC){ + modIC <- function(L2Fam, IC, withMakeIC, ...){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2LocationScaleFamily") && is(distribution(L2Fam), "Norm")){ sdneu <- main(L2Fam)[2] @@ -191,7 +191,7 @@ } return(IC) }else{ - makeIC(IC, L2Fam) + makeIC(IC, L2Fam, ...) } } Modified: branches/robast-1.2/pkg/RobLox/R/roblox.R =================================================================== --- branches/robast-1.2/pkg/RobLox/R/roblox.R 2018-08-12 15:57:02 UTC (rev 1134) +++ branches/robast-1.2/pkg/RobLox/R/roblox.R 2018-08-12 15:58:23 UTC (rev 1135) @@ -362,7 +362,7 @@ biastype = symmetricBias(), normW = NormType()) mse <- robEst$A1 + robEst$A2 - modIC <- function(L2Fam, IC, withMakeIC){ + modIC <- function(L2Fam, IC, withMakeIC, ...){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2LocationScaleFamily") && is(distribution(L2Fam), "Norm")){ sdneu <- main(L2Fam)[2] @@ -397,7 +397,7 @@ } return(IC) }else{ - makeIC(L2Fam, IC) + makeIC(L2Fam, IC, ...) } } L2Fam <- substitute(NormLocationScaleFamily(mean = m1, sd = s1), @@ -491,7 +491,7 @@ biastype = symmetricBias(), normW = NormType()) mse <- robEst$A1 + robEst$A2 - modIC <- function(L2Fam, IC, withMakeIC){ + modIC <- function(L2Fam, IC, withMakeIC, ...){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2LocationScaleFamily") && is(distribution(L2Fam), "Norm")){ sdneu <- main(L2Fam)[2] @@ -526,7 +526,7 @@ } return(IC) }else{ - makeIC(L2Fam, IC) + makeIC(L2Fam, IC, ...) } } L2Fam <- substitute(NormLocationScaleFamily(mean = m1, sd = s1), @@ -601,14 +601,14 @@ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = r), biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC, withMakeIC){ + modIC <- function(L2Fam, IC, withMakeIC, ...){ if(is(L2Fam, "L2LocationFamily") && is(distribution(L2Fam), "Norm")){ CallL2New <- call("NormLocationFamily", mean = main(L2Fam)) CallL2Fam(IC) <- CallL2New return(IC) }else{ - makeIC(L2Fam, IC) + makeIC(L2Fam, IC, ...) } } L2Fam <- substitute(NormLocationFamily(mean = m1, sd = s1), @@ -690,14 +690,14 @@ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = r), biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC, withMakeIC){ + modIC <- function(L2Fam, IC, withMakeIC, ...){ if(is(L2Fam, "L2LocationFamily") && is(distribution(L2Fam), "Norm")){ CallL2New <- call("NormLocationFamily", mean = main(L2Fam)) CallL2Fam(IC) <- CallL2New return(IC) }else{ - makeIC(L2Fam, IC) + makeIC(L2Fam, IC, ...) } } L2Fam <- substitute(NormLocationFamily(mean = m1, sd = s1), @@ -777,7 +777,7 @@ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = r), biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC, withMakeIC){ + modIC <- function(L2Fam, IC, withMakeIC, ...){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), "Norm")){ sdneu <- main(L2Fam) @@ -805,7 +805,7 @@ } return(IC) }else{ - makeIC(L2Fam, IC) + makeIC(L2Fam, IC, ...) } } L2Fam <- substitute(NormScaleFamily(mean = m1, sd = s1), @@ -890,7 +890,7 @@ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = r), biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC, withMakeIC){ + modIC <- function(L2Fam, IC, withMakeIC, ...){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), "Norm")){ sdneu <- main(L2Fam) @@ -918,7 +918,7 @@ } return(IC) }else{ - makeIC(L2Fam, IC) + makeIC(L2Fam, IC, ...) } } L2Fam <- substitute(NormScaleFamily(mean = m1, sd = s1), Modified: branches/robast-1.2/pkg/RobLox/R/rsOptIC.R =================================================================== --- branches/robast-1.2/pkg/RobLox/R/rsOptIC.R 2018-08-12 15:57:02 UTC (rev 1134) +++ branches/robast-1.2/pkg/RobLox/R/rsOptIC.R 2018-08-12 15:58:23 UTC (rev 1135) @@ -70,7 +70,7 @@ biastype = symmetricBias(), normW = NormType()) - modIC <- function(L2Fam, IC, withMakeIC){ + modIC <- function(L2Fam, IC, withMakeIC, ...){ ICL2Fam <- eval(CallL2Fam(IC)) if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), "Norm")){ sdneu <- main(L2Fam) @@ -97,7 +97,7 @@ } return(IC) }else{ - makeIC(IC, L2Fam) + makeIC(IC, L2Fam, ...) } } From noreply at r-forge.r-project.org Sun Aug 12 17:59:13 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 17:59:13 +0200 (CEST) Subject: [Robast-commits] r1136 - branches/robast-1.2/pkg/RobRex Message-ID: <20180812155913.9907A18A2C5@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 17:59:13 +0200 (Sun, 12 Aug 2018) New Revision: 1136 Modified: branches/robast-1.2/pkg/RobRex/DESCRIPTION Log: [RobRex] DESCRIPTION requires more recent versions Modified: branches/robast-1.2/pkg/RobRex/DESCRIPTION =================================================================== --- branches/robast-1.2/pkg/RobRex/DESCRIPTION 2018-08-12 15:58:23 UTC (rev 1135) +++ branches/robast-1.2/pkg/RobRex/DESCRIPTION 2018-08-12 15:59:13 UTC (rev 1136) @@ -6,7 +6,7 @@ linear regression with unknown scale and standard normal distributed errors where the regressor is random. Depends: R (>= 2.14.0), ROptRegTS(>= 1.1.0) -Imports: distr(>= 2.7.0), RandVar(>= 1.1.0), RobAStBase(>= 1.1.0), methods +Imports: distr(>= 2.8.0), RandVar(>= 1.1.0), RobAStBase(>= 1.2.0), methods Authors at R: person("Matthias", "Kohl", role=c("aut", "cre", "cph"), email="Matthias.Kohl at stamats.de") ByteCompile: yes From noreply at r-forge.r-project.org Sun Aug 12 18:05:45 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 18:05:45 +0200 (CEST) Subject: [Robast-commits] r1137 - branches/robast-1.2/pkg/RobAStBase/R Message-ID: <20180812160546.0C87718A2C5@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 18:05:45 +0200 (Sun, 12 Aug 2018) New Revision: 1137 Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R Log: [RobAStBase] ... a typo in kStepEstimator.R Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-12 15:59:13 UTC (rev 1136) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-12 16:05:45 UTC (rev 1137) @@ -161,7 +161,7 @@ Eres[i,j] <- E(L2 at distribution, fun = function(x) L2M[[i]](x)*L2M[[j]](x), useApply = FALSE) - return(res)} + return(Eres)} ##-t-## updStp <- 0 ### update - function From noreply at r-forge.r-project.org Sun Aug 12 18:34:28 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 18:34:28 +0200 (CEST) Subject: [Robast-commits] r1138 - branches/robast-1.2/pkg/RobExtremes/inst/scripts Message-ID: <20180812163428.7E8A018A778@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 18:34:28 +0200 (Sun, 12 Aug 2018) New Revision: 1138 Modified: branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R Log: some cleanups in RobExtremes main script Modified: branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-12 16:05:45 UTC (rev 1137) +++ branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-12 16:34:28 UTC (rev 1138) @@ -64,7 +64,7 @@ estimate(RMXi) estimate(RMXiw) -estimate(RMXiw2) +estimate(RMXiw) ## our output: mlEi @@ -359,13 +359,13 @@ GF <- GammaFamily() system.time(mlE5i <- MLEstimator(grbsi, GF)) -system.time(OMS5i <- MBREstimator(grbsi, GF)) -system.time(RMX5i <- OMSEstimator(grbsi, GF)) -system.time(MBR5i <- RMXEstimator(grbsi, GF)) +system.time(MBR5i <- MBREstimator(grbsi, GF)) +system.time(OMS5i <- OMSEstimator(grbsi, GF)) +system.time(RMX5i <- RMXEstimator(grbsi, GF)) system.time(mlE5c <- MLEstimator(grbsc, GF)) -system.time(OMS5c <- MBREstimator(grbsc, GF)) -system.time(RMX5c <- OMSEstimator(grbsc, GF)) -system.time(MBR5c <- RMXEstimator(grbsc, GF)) +system.time(MBR5c <- MBREstimator(grbsc, GF)) +system.time(OMS5c <- OMSEstimator(grbsc, GF)) +system.time(RMX5c <- RMXEstimator(grbsc, GF)) estimate(mlE5i) estimate(RMX5i) estimate(OMS5i) From noreply at r-forge.r-project.org Sun Aug 12 23:41:45 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 23:41:45 +0200 (CEST) Subject: [Robast-commits] r1139 - in branches/robast-1.2/pkg/RobAStBase: R inst Message-ID: <20180812214145.B2458180509@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 23:41:45 +0200 (Sun, 12 Aug 2018) New Revision: 1139 Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS Log: [RobASt] branch 2.8 + in addition, .filterEargs() also checks if an argument "E.argList" is hidden in "..." and if so, filters in its entries (and in case of collision overwrites existing entries). Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-12 16:34:28 UTC (rev 1138) +++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-12 21:41:45 UTC (rev 1139) @@ -179,5 +179,14 @@ .filterEargs <- function(dots){ dotsI <- list() for(item in ..IntegrateArgs) dotsI[[item]] <- dots[[item]] + if(!is.null(dots[["E.argList"]])){ + E.argList <- dots[["E.argList"]] + if(is.call(E.argList)) eval(E.argList) + if(is.list(E.argList) && length(E.argList)>0){ + nms.E.argList <- names(E.argList) + for( item in nms.E.argList) dotsI[[item]] <- E.argList[[item]] + } + } + return(dotsI) } \ No newline at end of file Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-12 16:34:28 UTC (rev 1138) +++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-12 21:41:45 UTC (rev 1139) @@ -86,6 +86,9 @@ used for integration, i.e., currently, c("lowerTruncQuantile", "upperTruncQuantile", "IQR.fac", "subdivisions", "rel.tol", "abs.tol", "stop.on.error", "order", "useApply") this is used to filter out arguments from dots which are meant for E() + by means of exported helper function .filterEargs(); in addition, .filterEargs() + also checks if an argument "E.argList" is hidden in "..." and if so, filters in + its entries (and in case of collision overwrites existing entries). + getboundedIC now uses coordinate-wise integration with useApply = FALSE and only computing the upper half of E LL'w From noreply at r-forge.r-project.org Sun Aug 12 23:43:47 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Aug 2018 23:43:47 +0200 (CEST) Subject: [Robast-commits] r1140 - in branches/robast-1.2/pkg/ROptEst: R inst man Message-ID: <20180812214347.91D87180509@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-12 23:43:47 +0200 (Sun, 12 Aug 2018) New Revision: 1140 Modified: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R branches/robast-1.2/pkg/ROptEst/inst/NEWS branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd Log: [ROptEst] branch 2.8: + particular checkIC, makeIC methods for ContICs: They compute the integrals E w, E L w, E LL w using symmetry information through .getComp, and based on these numbers computes does checking / the affine transformation to give the proper pIC. These methods by default are only used if it pays off, i.e., if the number of computed integrals is smaller than in the default method. [was there already] NEW: This can be overriden by new argument forceContICMethod. Modified: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R 2018-08-12 21:41:45 UTC (rev 1139) +++ branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R 2018-08-12 21:43:47 UTC (rev 1140) @@ -2,13 +2,13 @@ ## faster check for ContICs setMethod("checkIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"), - function(IC, L2Fam, out = TRUE, ...){ + function(IC, L2Fam, out = TRUE, forceContICMethod = FALSE, ...){ D1 <- L2Fam at distribution if( dimension(Domain(IC at Curve[[1]])) != dimension(img(D1))) stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") - res <- .prepareCheckMakeIC(L2Fam, w = IC at weight, ...) + res <- .prepareCheckMakeIC(L2Fam, w = IC at weight, forceContICMethod, ...) ## if it pays off to use symmetry/ to compute integrals in L2deriv space ## we compute the following integrals: ## G1 = E w, G2 = E Lambda w, G3 = E Lambda Lambda' w @@ -47,7 +47,7 @@ ## make some L2function a pIC at a model setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"), - function(IC, L2Fam, ...){ + function(IC, L2Fam, forceContICMethod = FALSE, ...){ D1 <- L2Fam at distribution if( dimension(Domain(IC at Curve[[1]])) != dimension(img(D1))) @@ -57,7 +57,7 @@ if(dimension(IC at Curve) != dims) stop("Dimension of IC and parameter must be equal") - res <- .prepareCheckMakeIC(L2Fam, w = IC at weight, ...) + res <- .prepareCheckMakeIC(L2Fam, w = IC at weight, forceContICMethod, ...) ## if it pays off to use symmetry/ to compute integrals in L2deriv space ## we compute the following integrals: @@ -70,7 +70,7 @@ if(is.null(res)) return(getMethod("makeIC", signature(IC = "IC", - L2Fam = "L2ParamFamily"))(IC,L2Fam)) + L2Fam = "L2ParamFamily"))(IC,L2Fam,...)) G1 <- res$G1; G2 <- res$G2; G3 <- res$G3 trafO <- trafo(L2Fam at param) @@ -116,7 +116,7 @@ return(cIC1) }) -.prepareCheckMakeIC <- function(L2Fam, w, ...){ +.prepareCheckMakeIC <- function(L2Fam, w, forceContICMethod, ...){ dims <- length(L2Fam at param) trafo <- trafo(L2Fam at param) @@ -132,15 +132,16 @@ z.comp <- rep(TRUE,dims) A.comp <- matrix(TRUE, dims, dims) # print(list(z.comp,A.comp)) - # otherwise if trafo == unitMatrix may use symmetry info - if(.isUnitMatrix(trafo)){ + # otherwise if nrvalues > 1 # formerly: trafo == unitMatrix # + # may use symmetry info + if(dims>1){ comp <- .getComp(L2deriv, L2Fam at distrSymm, L2Fam at L2derivSymm, L2Fam at L2derivDistrSymm) z.comp <- comp$"z.comp" A.comp <- comp$"A.comp" t.comp.i <- sum(z.comp)+sum(A.comp)+1 } - if(to.comp.a < to.comp.i) return(NULL) + if(to.comp.a < to.comp.i && !forceContICMethod) return(NULL) res <- .getG1G2G3Stand(L2deriv = L2deriv, Distr = L2Fam at distribution, Modified: branches/robast-1.2/pkg/ROptEst/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-12 21:41:45 UTC (rev 1139) +++ branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-12 21:43:47 UTC (rev 1140) @@ -58,8 +58,6 @@ have to be computed, now fills the lower triangle of A with FALSE (was not used so far, but can be used in a faster computation method for checkIC makeIC to determine whether it is cleverer to integrate in k or in p space) -+ particular checkIC and makeIC methods for ContICs which allow for speed up - if in k space many entries of the LMs can be skipped due to symmetry + several methods (getRiskIC, getBiasIC, getBoundedIC, makeIC, checkIC, modifyIC) gain argument "..." to pass on arguments to E(). This holds in particular for the functions used to compute the optimally-robust ICs, i.e. getInfRob_asBias, getInfRob_asHampel, @@ -72,6 +70,11 @@ + the local .modifyIC0 functions only used to produce the new IC but not for filling slot modifyIC loose argument withMakeIC (and dots) -- this is now done in the outer modifyIC function ++ particular checkIC, makeIC methods for ContICs: They compute the integrals E w, E L w, + E LL w using symmetry information through .getComp, and based on these numbers computes + does checking / the affine transformation to give the proper pIC. These methods by + default are only used if it pays off, i.e., if the number of computed integrals is smaller + than in the default method. This can be overriden by argument forceContICMethod. ####################################### version 1.1 Modified: branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd 2018-08-12 21:41:45 UTC (rev 1139) +++ branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd 2018-08-12 21:43:47 UTC (rev 1140) @@ -11,13 +11,32 @@ IC possibly violating the conditions so far. } \usage{ -\S4method{checkIC}{ContIC,L2ParamFamily}(IC, L2Fam, out = TRUE,...) -\S4method{makeIC}{ContIC,L2ParamFamily}(IC, L2Fam, ...) +\S4method{checkIC}{ContIC,L2ParamFamily}(IC, L2Fam, out = TRUE, + forceContICMethod = FALSE, ...) +\S4method{makeIC}{ContIC,L2ParamFamily}(IC, L2Fam, + forceContICMethod = FALSE, ...) } \arguments{ \item{IC}{ object of class \code{"IC"} } \item{L2Fam}{ L2-differentiable family of probability measures. } \item{out}{ logical: Should the values of the checks be printed out?} + \item{forceContICMethod}{ logical: Should we force to use the method for + signature \code{ContIC,L2ParamFamily} + in any case (even if it is not indicated by symmetry arguments)? + Otherwise it uses internal method \code{.getComp} to compute the number + of integrals to be computed, taking care of symmetries as indicated through + the symmetry slots of the model \code{L2Fam}. Only if this + number is smaller than the number of integrals to be computed in the range + of the pIC the present method is used, otherwise it switches back to the + \code{IC,L2ParamFamily} method. + -- The \code{ContIC,L2ParamFamily} up to skipped entries due to further + symmetry arguments is $\code{(k+1)k/2+k+1=(k+1)(k+2)/2} for \code{k} the + length of the unknown parameter / length of slot \code{L2deriv} of \code{L2Fam}, + while the number of integrals on the pIC scale underlying the more general + method for signature \code{ContIC,L2ParamFamily} is \code{p (k+1)} where + \code{p} is the length of the pIC / the length of the parameter of interest + as indicated in the number of rows in the \code{trafo} slot of the underlying + slot \code{param} of \code{L2Fam}.} \item{\dots}{ additional parameters to be passed on to expectation \code{E}. } } From noreply at r-forge.r-project.org Mon Aug 13 00:00:00 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 13 Aug 2018 00:00:00 +0200 (CEST) Subject: [Robast-commits] r1141 - in branches/robast-1.2/pkg/RobExtremes/inst: . scripts Message-ID: <20180812220001.0397718A7D0@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-13 00:00:00 +0200 (Mon, 13 Aug 2018) New Revision: 1141 Modified: branches/robast-1.2/pkg/RobExtremes/inst/NEWS branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R Log: [RobExtremes] branch 2.8: small update in script RobFitsAtRealData.R Modified: branches/robast-1.2/pkg/RobExtremes/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobExtremes/inst/NEWS 2018-08-12 21:43:47 UTC (rev 1140) +++ branches/robast-1.2/pkg/RobExtremes/inst/NEWS 2018-08-12 22:00:00 UTC (rev 1141) @@ -14,10 +14,20 @@ under the hood + moved quantile integration methods for expectation for Weibull and Gamma distribution to pkg distrEx (>= 2.8.0) ++ in asvarMedkMAD we now use distr::solve + made a helper function .qtlIntegrate out of existing code in RobExtremes 1.1.0 and moved it to distrEx where it is exported from version 2.8.0; it is reused in RobExtremes for the GEV methods - ++ as with the interpolating - getStartIC methods in ROptEst, + the makeIC-task is removed from the inner .modifyIC.0 function and + delegated to the outer .modifyIC , so .getPsi, getPsi.wL, and + .getPsi.P loose their argument withMakeIC ++ in the getStartIC methods for interpolRisks, we now produce slots modifyIC with argument + withMakeIC (as before) and with "..." to pass on arguments to E() (e.g., when makeIC is called) ++ the timings are now about ~ 2s per estimator for GEV and GPD and check/makeIC are much faster ++ script updated ++ the makeIC methods for GPD/GEV... also gain an "..." argument + ####################################### version 1.1 ####################################### Modified: branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-12 21:43:47 UTC (rev 1140) +++ branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-12 22:00:00 UTC (rev 1141) @@ -53,7 +53,7 @@ ## little to the situation where we enforce IC conditions checkIC(pIC(RMXi)) system.time(RMXiw <- RMXEstimator(portpiriei, GEVFam,withMakeIC=TRUE)) -checkIC(pIC(RMXiw)) +checkIC(pIC(RMXiw), forceContICMethod = TRUE) ## uses contIC 0 - 1 standardization... ## for a moment remove this method oldM <- setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily")) From noreply at r-forge.r-project.org Wed Aug 15 19:50:33 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 15 Aug 2018 19:50:33 +0200 (CEST) Subject: [Robast-commits] r1142 - in branches/robast-1.2/pkg/RandVar: R inst Message-ID: <20180815175033.C457A18A6CC@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-15 19:50:33 +0200 (Wed, 15 Aug 2018) New Revision: 1142 Modified: branches/robast-1.2/pkg/RandVar/R/Expectation.R branches/robast-1.2/pkg/RandVar/inst/NEWS Log: [RandVar] branch 1.2 + E methods for RandVariables gain argument diagnostic (like E()-methods in distrEx v 2.8.0) + E methods for RandVariables use filtering of dots arguments (like E()-methods in distrEx v 2.8.0) Modified: branches/robast-1.2/pkg/RandVar/R/Expectation.R =================================================================== --- branches/robast-1.2/pkg/RandVar/R/Expectation.R 2018-08-12 22:00:00 UTC (rev 1141) +++ branches/robast-1.2/pkg/RandVar/R/Expectation.R 2018-08-15 17:50:33 UTC (rev 1142) @@ -1,138 +1,282 @@ -setMethod("E", signature(object = "UnivariateDistribution", - fun = "EuclRandVariable", - cond = "missing"), - function(object, fun, useApply = TRUE, ...){ - if(!is(fun at Domain, "EuclideanSpace")) - stop("'Domain' of the random variable is no Euclidean space") - if(dimension(fun at Domain) != 1) - stop("dimension of 'Domain' of the random variable has to be 1") - if(dimension(fun at Range) != 1) - stop("dimension of 'Range' of the random variable has to be 1") +.locEfunLoop <- function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + dimn <- length(fun) + nrdim <- fun at Range@dimension + res <- numeric(dimn) + if(nrdim > 1) + res <- matrix(0, nrow = dimn, ncol = nrdim) + diagn <- NULL + if(diagnostic) diagn <- vector("list", dimn) + for(i in 1:dimn){ + buf <- E(object, fun = Map(fun)[[i]], useApply = useApply, ..., diagnostic = diagnostic) + if(diagnostic) diagn[[i]] <- attr(buf, "diagnostic") + if(nrdim>1) res[i,] <- buf else res[i] <- buf + } + if(!is.null(diagn)) attr(res,"diagnostic") <- diagn + return(res) + } +.locEfunLoopCond <- function(object, fun, cond, withCond = FALSE, useApply = TRUE, ..., diagnostic = FALSE){ dimn <- length(fun) res <- numeric(dimn) - for(i in 1:dimn) res[i] <- E(object, fun = Map(fun)[[i]], useApply = useApply, ...) + diagn <- if(diagnostic) vector("list", dimn) else NULL + dots <- list(...) + dotsI <- .filterEargs(dots) + Eargs0 <- list(object=object) + Eargs1 <- list(cond=cond, withCond=withCond, useApply = useApply, diagnostic = diagnostic) + for(i in 1:dimn){ + dotsFun <- .filterFunargs(dots, fun at Map[[i]]) + + funwD <- function(x) do.call(fun at Map[[i]], c(list(x), dotsFun)) + funwDc <- function(x,cond){ y <- c(x,cond); do.call(fun at Map[[i]], c(list(x=y), dotsFun))} + + Eargs <- c(Eargs0, list(fun=if(withCond)funwDc else funwD), Eargs1, dotsI) + res[i] <- buf <- do.call(E, Eargs) + if(diagnostic) diagn[[i]] <- attr(buf, "diagnostic") + } + if(!is.null(diagn)) attr(res,"diagnostic") <- diagn return(res) - }) -setMethod("E", signature(object = "AbscontDistribution", - fun = "EuclRandVariable", - cond = "missing"), - function(object, fun, useApply = TRUE, ...){ + } + +.locEfun <- function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ if(!is(fun at Domain, "EuclideanSpace")) stop("'Domain' of the random variable is no Euclidean space") if(dimension(fun at Domain) != 1) stop("dimension of 'Domain' of the random variable has to be 1") if(dimension(fun at Range) != 1) stop("dimension of 'Range' of the random variable has to be 1") + .locEfunLoop(object = object, fun = fun, useApply = useApply, ..., diagnostic = diagnostic) + } - dimn <- length(fun) - res <- numeric(dimn) - for(i in 1:dimn) res[i] <- E(object, fun = Map(fun)[[i]], useApply = useApply, ...) +.locEmatfun <- function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + diagn <- NULL + res <- E(object, as(fun, "EuclRandVariable"), useApply = useApply, ..., diagnostic = diagnostic) + if(diagnostic) diagn <- attr(res, "diagnostic") + res <- matrix(res, nrow = nrow(fun)) + if(!is.null(diagn)) attr(res,"diagnostic") <- diagn + return(res) + } +.locElistfun <- function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + nrvalues <- length(fun) + res <- vector("list", nrvalues) + diagn <- NULL + if(diagnostic) diagn <- vector("list", nrvalues) + for(i in 1:nrvalues){ +# print(list(object, fun = fun[[i]], useApply = useApply, ..., diagnostic = diagnostic)) + res[[i]] <- buf <- E(object, fun = fun[[i]], useApply = useApply, ..., diagnostic = diagnostic) + if(diagnostic) diagn[[i]] <- attr(buf, "diagnostic") + } + if(!is.null(diagn)) attr(res,"diagnostic") <- diagn + return(res) + } +.locEMVfun <- function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ +# print(list(object, fun, useApply, ..., diagnostic)) + if(!is(fun at Domain, "EuclideanSpace")) + stop("'Domain' of the random variable is no Euclidean space") + if(fun at Domain@dimension != object at img@dimension) + stop("dimension of 'Domain' of the random variable is not equal\n", + "to dimension of 'img' of the distribution") + res <- .locEfunLoop(object = object, fun = fun, useApply = useApply, ..., diagnostic = diagnostic) + dim(res) <- c(length(fun),fun at Range@dimension) return(res) - }) -setMethod("E", signature(object = "DiscreteDistribution", - fun = "EuclRandVariable", - cond = "missing"), - function(object, fun, useApply = TRUE, ...){ + } + + +.locEfunCond <- + function(object, fun, cond, withCond = FALSE, useApply = TRUE, ..., diagnostic = FALSE){ if(!is(fun at Domain, "EuclideanSpace")) - stop("'Domain' of the random variable is no Euclidean space") - if(dimension(fun at Domain) != 1) - stop("dimension of 'Domain' of the random variable has to be 1") + stop("'Domain' of the random variable has to be a Euclidean Space") + if(withCond){ + if(fun at Domain@dimension != (1+length(cond))) + stop("wrong dimension of 'Domain' of 'fun'") + }else{ + if(fun at Domain@dimension != 1) + stop("dimension of 'Domain' of 'fun' has to be 1") + } if(dimension(fun at Range) != 1) stop("dimension of 'Range' of the random variable has to be 1") - dimn <- length(fun) - res <- numeric(dimn) - for(i in 1:dimn) res[i] <- E(object, fun = Map(fun)[[i]], useApply = useApply, ...) + return(.locEfunLoopCond(object = object, fun = fun, cond = cond, withCond = withCond, + useApply = useApply, ..., diagnostic = diagnostic)) + } +.locEmatfunCond <- function(object, fun, cond, withCond = FALSE, useApply = TRUE, ..., diagnostic = FALSE){ + diagn <- NULL + res <- E(object, as(fun, "EuclRandVariable"), cond = cond, + withCond = withCond, useApply = useApply, ..., diagnostic = diagnostic) + if(diagnostic) diagn <- attr(res, "diagnostic") + res <- matrix(res, nrow = nrow(fun)) + if(!is.null(diagn)) attr(res,"diagnostic") <- diagn return(res) - }) + } + +.locElistfunCond <- function(object, fun, cond, withCond = FALSE, useApply = TRUE, ..., diagnostic = FALSE){ + nrvalues <- length(fun) + diagn <- if(diagnostic) vector("list", nrvalues) else NULL + res <- vector("list", nrvalues) + for(i in 1:nrvalues){ + res[[i]] <- buf <- E(object, fun=fun[[i]], cond = cond, withCond = withCond, useApply = useApply, ..., diagnostic = diagnostic) + if(diagnostic) diagn[[i]] <- attr(buf, "diagnostic") + } + if(!is.null(diagn)) attr(res,"diagnostic") <- diagn + return(res) + } + + + setMethod("E", signature(object = "UnivariateDistribution", + fun = "EuclRandVariable", + cond = "missing"), + function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + mc <- match.call() + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locEfun, c(list(object=object, fun= fun, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- mc + attr(res,"diagnostic") <- diagn + } + return(res) + }) +setMethod("E", signature(object = "AbscontDistribution", + fun = "EuclRandVariable", + cond = "missing"), + function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locEfun, c(list(object=object, fun= fun, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) +setMethod("E", signature(object = "DiscreteDistribution", + fun = "EuclRandVariable", + cond = "missing"), + function(object, fun, useApply = TRUE, ...){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + do.call(.locEfun,c(list(object = object, fun = fun, useApply = useApply, diagnostic= FALSE), dotsI)) + }) + +setMethod("E", signature(object = "UnivariateDistribution", fun = "EuclRandMatrix", cond = "missing"), - function(object, fun, useApply = TRUE, ...){ - matrix(E(object, as(fun, "EuclRandVariable"), useApply = useApply, ...), nrow = nrow(fun)) - }) + function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locEmatfun, c(list(object=object, fun= fun, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) + setMethod("E", signature(object = "AbscontDistribution", fun = "EuclRandMatrix", cond = "missing"), - function(object, fun, useApply = TRUE, ...){ - matrix(E(object, as(fun, "EuclRandVariable"), useApply = useApply, ...), nrow = nrow(fun)) - }) -setMethod("E", signature(object = "DiscreteDistribution", + function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locEmatfun, c(list(object=object, fun= fun, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) + +setMethod("E", signature(object = "DiscreteDistribution", fun = "EuclRandMatrix", cond = "missing"), function(object, fun, useApply = TRUE, ...){ - matrix(E(object, as(fun, "EuclRandVariable"), useApply = useApply, ...), nrow = nrow(fun)) + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + do.call(.locEmatfun,c(list(object = object, fun = fun, useApply = useApply, diagnostic= FALSE), dotsI)) }) + setMethod("E", signature(object = "UnivariateDistribution", fun = "EuclRandVarList", cond = "missing"), - function(object, fun, useApply = TRUE, ...){ - nrvalues <- length(fun) - res <- vector("list", nrvalues) - for(i in 1:nrvalues) res[[i]] <- E(object, fun[[i]], useApply = useApply, ...) + function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locElistfun, c(list(object=object, fun= fun, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) - return(res) - }) setMethod("E", signature(object = "AbscontDistribution", fun = "EuclRandVarList", cond = "missing"), - function(object, fun, useApply = TRUE, ...){ - nrvalues <- length(fun) - res <- vector("list", nrvalues) - for(i in 1:nrvalues) res[[i]] <- E(object, fun[[i]], useApply = useApply, ...) + function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locElistfun, c(list(object=object, fun= fun, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) - return(res) - }) -setMethod("E", signature(object = "DiscreteDistribution", +setMethod("E", signature(object = "DiscreteDistribution", fun = "EuclRandVarList", cond = "missing"), function(object, fun, useApply = TRUE, ...){ - nrvalues <- length(fun) - res <- vector("list", nrvalues) - for(i in 1:nrvalues) res[[i]] <- E(object, fun[[i]], useApply = useApply, ...) + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + do.call(.locElistfun,c(list(object = object, fun = fun, useApply = useApply, diagnostic= FALSE), dotsI)) + }) - return(res) - }) setMethod("E", signature(object = "MultivariateDistribution", fun = "EuclRandVariable", cond = "missing"), - function(object, fun, useApply = TRUE, ...){ - if(!is(fun at Domain, "EuclideanSpace")) - stop("'Domain' of the random variable is no Euclidean space") - if(fun at Domain@dimension != object at img@dimension) - stop("dimension of 'Domain' of the random variable is not equal\n", - "to dimension of 'img' of the distribution") - dimn <- length(fun) - res <- matrix(0, nrow = dimn, ncol = fun at Range@dimension) - for(i in 1:dimn) res[i,] <- E(object, fun at Map[[i]], useApply = useApply, ...) + function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locEMVfun, c(list(object=object, fun= fun, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) - return(res) - }) + setMethod("E", signature(object = "DiscreteMVDistribution", fun = "EuclRandVariable", cond = "missing"), function(object, fun, useApply = TRUE, ...){ - if(!is(fun at Domain, "EuclideanSpace")) - stop("'Domain' of the random variable is no Euclidean space") - if(fun at Domain@dimension != object at img@dimension) - stop("dimension of 'Domain' of the random variable is not equal\n", - "to dimension of 'img' of the distribution") - dimn <- length(fun) - res <- matrix(0, nrow = dimn, ncol = fun at Range@dimension) - for(i in 1:dimn) res[i,] <- E(object, fun at Map[[i]], useApply = useApply, ...) + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + do.call(.locEMVfun,c(list(object = object, fun = fun, useApply = useApply, diagnostic= FALSE), dotsI)) + }) - return(res) - }) -setMethod("E", signature(object = "MultivariateDistribution", +setMethod("E", signature(object = "MultivariateDistribution", fun = "EuclRandMatrix", cond = "missing"), - function(object, fun, useApply = TRUE, ...){ - array(E(object, as(fun, "EuclRandVariable"), useApply = useApply, ...), - c(nrow(fun), ncol(fun), fun at Range@dimension)) + function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + if(!diagnostic){ + return(array(E(object, as(fun, "EuclRandVariable"), useApply = useApply, ..., diagnostic = diagnostic), + c(nrow(fun), ncol(fun), fun at Range@dimension))) + }else{ + res <- E(object, as(fun, "EuclRandVariable"), useApply = useApply, ..., diagnostic = diagnostic) + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + res <- array(res, c(nrow(fun), ncol(fun), fun at Range@dimension)) + attr(res, "diagnostic") <- diagn + return(res) + } }) setMethod("E", signature(object = "DiscreteMVDistribution", fun = "EuclRandMatrix", @@ -144,166 +288,146 @@ setMethod("E", signature(object = "MultivariateDistribution", fun = "EuclRandVarList", cond = "missing"), - function(object, fun, useApply = TRUE, ...){ - nrvalues <- length(fun) - res <- vector("list", nrvalues) - for(i in 1:nrvalues) - res[[i]] <- E(object, fun[[i]], useApply = useApply, ...) + function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locElistfun, c(list(object=object, fun= fun, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) - return(res) - }) -setMethod("E", signature(object = "DiscreteMVDistribution", +setMethod("E", signature(object = "DiscreteMVDistribution", fun = "EuclRandVarList", cond = "missing"), function(object, fun, useApply = TRUE, ...){ - nrvalues <- length(fun) - res <- vector("list", nrvalues) - for(i in 1:nrvalues) - res[[i]] <- E(object, fun[[i]], useApply = useApply, ...) + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + do.call(.locElistfun,c(list(object = object, fun = fun, useApply = useApply, diagnostic= FALSE), dotsI)) + }) - return(res) - }) setMethod("E", signature(object = "UnivariateCondDistribution", fun = "EuclRandVariable", cond = "numeric"), - function(object, fun, cond, withCond = FALSE, useApply = TRUE, ...){ - if(!is(fun at Domain, "EuclideanSpace")) - stop("'Domain' of the random variable has to be a Euclidean Space") - if(withCond){ - if(fun at Domain@dimension != (1+length(cond))) - stop("wrong dimension of 'Domain' of 'fun'") - }else{ - if(fun at Domain@dimension != 1) - stop("dimension of 'Domain' of 'fun' has to be 1") - } - if(dimension(fun at Range) != 1) - stop("dimension of 'Range' of the random variable has to be 1") + function(object, fun, cond, withCond = FALSE, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locEfunCond, c(list(object=object, fun= fun, cond=cond, + withCond = withCond, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) - dimn <- length(fun) - res <- numeric(dimn) - if(withCond){ - for(i in 1:dimn){ - fun1 <- function(x, cond, fct){ fct(c(x, cond)) } - res[i] <- E(object, fun1, cond, fct = fun at Map[[i]], - withCond, useApply = useApply, ...) - } - }else{ - for(i in 1:dimn) res[i] <- E(object, fun at Map[[i]], cond, useApply = useApply, ...) - } - - return(res) - }) -setMethod("E", signature(object = "AbscontCondDistribution", +setMethod("E", signature(object = "AbscontCondDistribution", fun = "EuclRandVariable", cond = "numeric"), - function(object, fun, cond, withCond = FALSE, useApply = TRUE, ...){ - if(!is(fun at Domain, "EuclideanSpace")) - stop("'Domain' of the random variable has to be a Euclidean Space") - if(withCond){ - if(fun at Domain@dimension != (1+length(cond))) - stop("wrong dimension of 'Domain' of 'fun'") - }else{ - if(fun at Domain@dimension != 1) - stop("dimension of 'Domain' of 'fun' has to be 1") - } - if(dimension(fun at Range) != 1) - stop("dimension of 'Range' of the random variable has to be 1") + function(object, fun, cond, withCond = FALSE, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locEfunCond, c(list(object=object, fun= fun, cond=cond, + withCond = withCond, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) - dimn <- length(fun) - res <- numeric(dimn) - if(withCond){ - for(i in 1:dimn){ - fun1 <- function(x, cond, fct){ fct(c(x, cond)) } - res[i] <- E(object, fun1, cond, fct = fun at Map[[i]], - withCond, useApply = useApply, ...) - } - }else{ - for(i in 1:dimn) res[i] <- E(object, fun at Map[[i]], cond, useApply = useApply, ...) - } - - return(res) - }) -setMethod("E", signature(object = "DiscreteCondDistribution", +setMethod("E", signature(object = "DiscreteCondDistribution", fun = "EuclRandVariable", cond = "numeric"), function(object, fun, cond, withCond = FALSE, useApply = TRUE, ...){ - if(!is(fun at Domain, "EuclideanSpace")) - stop("'Domain' of the random variable has to be a Euclidean Space") - if(withCond){ - if(fun at Domain@dimension != (1+length(cond))) - stop("wrong dimension of 'Domain' of 'fun'") - }else{ - if(fun at Domain@dimension != 1) - stop("dimension of 'Domain' of 'fun' has to be 1") - } - if(dimension(fun at Range) != 1) - stop("dimension of 'Range' of the random variable has to be 1") + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + do.call(.locEfunCond,c(list(object = object, fun = fun, cond=cond, withCond = withCond, + useApply = useApply, diagnostic= FALSE), dotsI)) + }) - dimn <- length(fun) - res <- numeric(dimn) - if(withCond){ - for(i in 1:dimn){ - fun1 <- function(x, cond, fct){ fct(c(x, cond)) } - res[i] <- E(object, fun1, cond, fct = fun at Map[[i]], - withCond, useApply = useApply, ...) - } - }else{ - for(i in 1:dimn) res[i] <- E(object, fun at Map[[i]], cond, useApply = useApply, ...) - } - - return(res) - }) setMethod("E", signature(object = "UnivariateCondDistribution", fun = "EuclRandMatrix", cond = "numeric"), - function(object, fun, cond, withCond = FALSE, useApply = TRUE, ...){ - matrix(E(object, as(fun, "EuclRandVariable"), cond, withCond, - useApply = useApply, ...), nrow = nrow(fun)) - }) -setMethod("E", signature(object = "AbscontCondDistribution", + function(object, fun, cond, withCond = FALSE, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locEmatfunCond, c(list(object=object, fun= fun, cond=cond, + withCond = withCond, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) + +setMethod("E", signature(object = "AbscontCondDistribution", fun = "EuclRandMatrix", cond = "numeric"), - function(object, fun, cond, withCond = FALSE, useApply = TRUE, ...){ - matrix(E(object, as(fun, "EuclRandVariable"), cond, withCond, - useApply = useApply, ...), nrow = nrow(fun)) - }) -setMethod("E", signature(object = "DiscreteCondDistribution", + function(object, fun, cond, withCond = FALSE, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locEmatfunCond, c(list(object=object, fun= fun, cond=cond, + withCond = withCond, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) + +setMethod("E", signature(object = "DiscreteCondDistribution", fun = "EuclRandMatrix", cond = "numeric"), function(object, fun, cond, withCond = FALSE, useApply = TRUE, ...){ - matrix(E(object, as(fun, "EuclRandVariable"), cond, withCond, - useApply = useApply, ...), nrow = nrow(fun)) - }) + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + do.call(.locEmatfunCond,c(list(object = object, fun = fun, cond=cond, withCond = withCond, + useApply = useApply, diagnostic= FALSE), dotsI)) + }) + setMethod("E", signature(object = "UnivariateCondDistribution", fun = "EuclRandVarList", cond = "numeric"), - function(object, fun, cond, withCond = FALSE, useApply = TRUE, ...){ - nrvalues <- length(fun) - res <- vector("list", nrvalues) - for(i in 1:nrvalues) - res[[i]] <- E(object, fun[[i]], cond, withCond, useApply = useApply, ...) + function(object, fun, cond, withCond = FALSE, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locElistfunCond, c(list(object=object, fun= fun, cond=cond, + withCond = withCond, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) - return(res) - }) setMethod("E", signature(object = "AbscontCondDistribution", fun = "EuclRandVarList", cond = "numeric"), - function(object, fun, cond, withCond = FALSE, useApply = TRUE, ...){ - nrvalues <- length(fun) - res <- vector("list", nrvalues) - for(i in 1:nrvalues) - res[[i]] <- E(object, fun[[i]], cond, withCond, useApply = useApply, ...) + function(object, fun, cond, withCond = FALSE, useApply = TRUE, ..., diagnostic = FALSE){ + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + res <- do.call(.locElistfunCond, c(list(object=object, fun= fun, cond=cond, + withCond = withCond, useApply = useApply, + diagnostic = diagnostic), dotsI)) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) + }) - return(res) - }) -setMethod("E", signature(object = "DiscreteCondDistribution", +setMethod("E", signature(object = "DiscreteCondDistribution", fun = "EuclRandVarList", cond = "numeric"), function(object, fun, cond, withCond = FALSE, useApply = TRUE, ...){ - nrvalues <- length(fun) - res <- vector("list", nrvalues) - for(i in 1:nrvalues) - res[[i]] <- E(object, fun[[i]], cond, withCond, useApply = useApply, ...) + dots <- list(...); dotsI <- .filterEargs(dots); dotsI$diagnostic <- NULL + do.call(.locElistfunCond,c(list(object = object, fun = fun, cond=cond, withCond = withCond, + useApply = useApply, diagnostic= FALSE), dotsI)) + }) - return(res) - }) Modified: branches/robast-1.2/pkg/RandVar/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RandVar/inst/NEWS 2018-08-12 22:00:00 UTC (rev 1141) +++ branches/robast-1.2/pkg/RandVar/inst/NEWS 2018-08-15 17:50:33 UTC (rev 1142) @@ -13,11 +13,15 @@ user-visible CHANGES: + require more recent distr/distrEx versions ++ E methods for RandVariables gain argument diagnostic + (like E()-methods in distrEx v 2.8.0) under the hood: + for consistency to the univariate methods, the liesInSupport() method for DiscreteMVDistribution is called with an extra argument checkFin, which is not yet used. ++ E methods for RandVariables use filtering of dots arguments + (like E()-methods in distrEx v 2.8.0) ####################################### version 1.1 From noreply at r-forge.r-project.org Wed Aug 15 22:40:57 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 15 Aug 2018 22:40:57 +0200 (CEST) Subject: [Robast-commits] r1143 - in branches/robast-1.2/pkg/RobAStBase: . R inst man Message-ID: <20180815204057.8775618A175@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-15 22:40:56 +0200 (Wed, 15 Aug 2018) New Revision: 1143 Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS branches/robast-1.2/pkg/RobAStBase/man/internals.Rd branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd Log: [RobAStBase] branch 1.2: + .filterEargs is renamed to .filterEargsWEargList and now calls distrEx::.filterEargs + the respective calls to it are renamed + in kStepEstimator, the solution with timings to be commented in and out has been replaced by permanent calls to proc.time() (without creating new environments through functions calls to system.time) Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-15 17:50:33 UTC (rev 1142) +++ branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-15 20:40:56 UTC (rev 1143) @@ -89,4 +89,4 @@ export(".rescalefct",".plotRescaledAxis",".makedotsP",".makedotsLowLevel",".SelectOrderData") export(".merge.lists") export("InfoPlot", "ComparePlot", "PlotIC") -export(".fixInLiesInSupport", "..IntegrateArgs", ".filterEargs") \ No newline at end of file +export(".fixInLiesInSupport", ".filterEargsWEargList") Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-15 17:50:33 UTC (rev 1142) +++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-15 20:40:56 UTC (rev 1143) @@ -7,7 +7,7 @@ nrvalues <- nrow(trafo) Distr <- L2Fam at distribution - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE @@ -20,17 +20,13 @@ res[i] <- do.call(E, Eargs) } - integrandA <- function(x, IC.i, L2.j){ - return(IC.i(x)*L2.j(x)) - } erg <- matrix(0, ncol = dims, nrow = nrvalues) for(i in 1:nrvalues) for(j in 1:dims){ - Eargs <- c(list(object = Distr, fun = integrandA, - IC.i = IC.v at Map[[i]], L2.j = L2deriv at Map[[j]]), - dotsI) + integrandA <- function(x)IC.v at Map[[i]](x)*L2deriv at Map[[j]](x) + Eargs <- c(list(object = Distr, fun = integrandA),dotsI) erg[i, j] <- do.call(E, Eargs) } @@ -172,13 +168,8 @@ }) ## comment 20180809: reverted changes in rev 1110 -..IntegrateArgs <- c("lowerTruncQuantile", "upperTruncQuantile", - "IQR.fac", "subdivisions", "rel.tol", "abs.tol", "stop.on.error", - "order", "useApply") - -.filterEargs <- function(dots){ - dotsI <- list() - for(item in ..IntegrateArgs) dotsI[[item]] <- dots[[item]] +.filterEargsWEargList <- function(dots){ + dotsI <- .filterEargs(dots) if(!is.null(dots[["E.argList"]])){ E.argList <- dots[["E.argList"]] if(is.call(E.argList)) eval(E.argList) @@ -189,4 +180,4 @@ } return(dotsI) -} \ No newline at end of file +} Modified: branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-15 17:50:33 UTC (rev 1142) +++ branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-15 20:40:56 UTC (rev 1143) @@ -30,7 +30,7 @@ if(dimension(Domain(IC at Curve[[1]])) != dimension(img(L2Fam at distribution))) stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(!is.null(dotsI$useApply)) dotsI$useApply <- FALSE if(missing(withCheck)) withCheck <- TRUE Modified: branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-15 17:50:33 UTC (rev 1142) +++ branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-15 20:40:56 UTC (rev 1143) @@ -1,6 +1,6 @@ getBoundedIC <- function(L2Fam, D=trafo(L2Fam at param),...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE FI <- FisherInfo(L2Fam) Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-15 17:50:33 UTC (rev 1142) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-15 20:40:56 UTC (rev 1143) @@ -24,10 +24,9 @@ setMethod("neighborRadius","ANY",function(object)NA) -.addTime <- function(timold,timnew,namenew){ - nameold <- rownames(timold) - tim <- rbind(timold,timnew) - rownames(tim) <- c(nameold,namenew) +.addTime <- function(timold,namenew){ + tim <- rbind(timold,proc.time()) + rownames(tim) <- c(rownames(timold),namenew) return(tim) } @@ -37,6 +36,16 @@ if(length(d)==4L && d[2]==1L && d[4] == 1L) dim(x) <- d[c(1,3)] x } +### taken from: base::system.time :: +ppt <- function(y) { + if (!is.na(y[4L])) + y[1L] <- y[1L] + y[4L] + if (!is.na(y[5L])) + y[2L] <- y[2L] + y[5L] + paste(formatC(y[1L:3L]), collapse = " ") +} + + ### no dispatch on top layer -> keep product structure of dependence kStepEstimator <- function(x, IC, start = NULL, steps = 1L, useLast = getRobAStBaseOption("kStepUseLast"), @@ -48,21 +57,20 @@ withLogScale = TRUE, withEvalAsVar = TRUE, withMakeIC = FALSE, E.argList = NULL){ - if(missing(IC.UpdateInKer)) IC.UpdateInKer <- NULL + time <- proc.time() + on.exit(message("Timing stopped at: ", ppt(proc.time() - time))) ## save call es.call <- match.call() es.call[[1]] <- as.name("kStepEstimator") if(is.null(E.argList)) E.argList <- list() if(is.null(E.argList$useApply)) E.argList$useApply <- FALSE + if(missing(IC.UpdateInKer)) IC.UpdateInKer <- NULL ## get some dimensions -##-t-## syt <- system.time({ L2Fam <- eval(CallL2Fam(IC)) -##-t-## }) -##-t-## sytm <- matrix(syt,nrow=1) -##-t-## rownames(sytm) <- "eval(CallL2Fam(IC))" -##-t-## colnames(sytm) <- names(syt) + sytm <- rbind(time,"eval(CallL2Fam(IC))"=proc.time()) + colnames(sytm) <- names(time) Param <- param(L2Fam) tf <- trafo(L2Fam,Param) @@ -112,20 +120,17 @@ ### use dispatch here (dispatch only on start) #a.var <- if( is(start, "Estimate")) asvar(start) else NULL -##-t-## syt <- system.time({ + IC.UpdateInKer.0 <- if(is(start,"ALEstimate")) pIC(start) else NULL -##-t-## }) -##-t-## sytm <- .addTime(sytm,syt,"pIC(start)") + sytm <- .addTime(sytm,"pIC(start)") ## pIC(start) instead of start at pIC to potentially eval a call force(startArgList) -##-t-## syt <- system.time({ start.val <- kStepEstimator.start(start, x=x0, nrvalues = k, na.rm = na.rm, L2Fam = L2Fam, startList = startArgList) -##-t-## }) -##-t-## sytm <- .addTime(sytm,syt,"kStepEstimator.start") + sytm <- .addTime(sytm,"kStepEstimator.start") ### use Logtransform here in scale models sclname <- "" @@ -163,7 +168,7 @@ useApply = FALSE) return(Eres)} -##-t-## updStp <- 0 + updStp <- 0 ### update - function updateStep <- function(u.theta, theta, IC, L2Fam, Param, withPreModif = FALSE, @@ -171,39 +176,29 @@ withEvalAsVar.0 = FALSE ){ -##-t-## updStp <<- updStp + 1 + updStp <<- updStp + 1 if(withPreModif){ main(Param)[] <- .deleteDim(u.theta[idx]) # print(Param) if (lnx) nuisance(Param)[] <- .deleteDim(u.theta[nuis.idx]) # print(Param) # print(L2Fam) -##-t-## syt <- system.time({ L2Fam <- modifyModel(L2Fam, Param, .withL2derivDistr = L2Fam at .withEvalL2derivDistr) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("modifyModel-PreModif-",updStp)) + sytm <<- .addTime(sytm,paste("modifyModel-PreModif-",updStp)) # print(L2Fam) -##-t-## syt <- system.time({ modifyICargs <- c(list(L2Fam, IC, withMakeIC = FALSE), E.argList) IC <- do.call(modifyIC(IC),modifyICargs) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("modifyIC-PreModif-",updStp)) + sytm <<- .addTime(sytm,paste("modifyIC-PreModif-",updStp)) if(steps==1L && withMakeIC){ -##-t-## syt <- system.time({ makeICargs <- c(list(IC, L2Fam),E.argList) IC <- do.call(makeIC, makeICargs) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("modifyIC-makeIC-",updStp)) -# IC at modifyIC <- oldmodifIC + sytm <<- .addTime(sytm,paste("modifyIC-makeIC-",updStp)) } - # print(IC) } -##-t-## syt <- system.time({ IC.c <- as(diag(p) %*% IC at Curve, "EuclRandVariable") -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("IC.c <- as(diag(p) %*%-",updStp)) + sytm <<- .addTime(sytm,paste("IC.c <- as(diag(p) %*%-",updStp)) # print(theta) tf <- trafo(L2Fam, Param) @@ -211,7 +206,6 @@ IC.tot.0 <- NULL # print(Dtau) if(!.isUnitMatrix(Dtau)){ - # print("HU1!") Dminus <- distr::solve(Dtau, generalized = TRUE) projker <- diag(k) - Dminus %*% Dtau @@ -224,43 +218,32 @@ if(!is.null(IC.UpdateInKer)&&!is(IC.UpdateInKer,"IC")) warning("'IC.UpdateInKer' is not of class 'IC'; we use default instead.") if(is.null(IC.UpdateInKer)){ -##-t-## syt <- system.time({ getBoundedICargs <- c(list(L2Fam, D = projker),E.argList) IC.tot2 <- do.call(getBoundedIC, getBoundedICargs) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("getBoundedIC-",updStp)) + sytm <<- .addTime(sytm,paste("getBoundedIC-",updStp)) }else{ -##-t-## syt <- system.time({ IC.tot2 <- as(projker %*% IC.UpdateInKer at Curve, "EuclRandVariable") -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("IC.tot2<-as(projker...-",updStp)) + sytm <<- .addTime(sytm,paste("IC.tot2<-as(projker...-",updStp)) } IC.tot2.isnull <- FALSE IC.tot.0 <- IC.tot1 + IC.tot2 }else{ if(is.null(IC.UpdateInKer.0)){ IC.tot.0 <- NULL }else{ -##-t-## syt <- system.time({ if(is.call(IC.UpdateInKer.0)) IC.UpdateInKer.0 <- eval(IC.UpdateInKer.0) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("eval(IC.UpdateInKer.0)-",updStp)) -##-t-## syt <- system.time({ + sytm <<- .addTime(sytm,paste("eval(IC.UpdateInKer.0)-",updStp)) IC.tot.0 <- IC.tot1 + as(projker %*% IC.UpdateInKer.0 at Curve, "EuclRandVariable") -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("IC.tot.0 <- IC.tot1 + as(proj-",updStp)) + sytm <<- .addTime(sytm,paste("IC.tot.0 <- IC.tot1 + as(proj-",updStp)) } } IC.tot <- IC.tot1 if(!IC.tot2.isnull) IC.tot <- IC.tot1 + IC.tot2 -##-t-## syt <- system.time({ indS <- liesInSupport(distribution(L2Fam),x0,checkFin=TRUE) -# print(str(evalRandVar(IC.tot, x0))) correct <- rowMeans(t(t(.ensureDim2(evalRandVar(IC.tot, x0)))*indS), na.rm = na.rm) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("Dtau-not-Unit:correct <- rowMeans-",updStp)) + sytm <<- .addTime(sytm,paste("Dtau-not-Unit:correct <- rowMeans-",updStp)) iM <- is.matrix(u.theta) names(correct) <- if(iM) rownames(u.theta) else names(u.theta) if(logtrf){ @@ -272,16 +255,10 @@ theta <- (tf$fct(u.theta[idx]))$fval }else{ -# print("HU2!") -##-t-## syt <- system.time({ indS <- liesInSupport(distribution(L2Fam),x0,checkFin=TRUE) correct <- rowMeans(t(t(.ensureDim2(evalRandVar(IC.c, x0)))*indS), na.rm = na.rm) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("Dtau=Unit:correct <- rowMeans-",updStp)) + sytm <<- .addTime(sytm,paste("Dtau=Unit:correct <- rowMeans-",updStp)) iM <- is.matrix(theta) -# print(sclname) -# print(names(theta)) -# print(str(theta)) names(correct) <- if(iM) rownames(theta) else names(theta) if(logtrf){ scl <- if(iM) theta[sclname,1] else theta[sclname] @@ -294,63 +271,43 @@ IC.tot <- IC.c u.theta <- theta } -# print("HU3!") var0 <- u.var <- NULL if(with.u.var){ cnms <- if(is.null(names(u.theta))) colnames(Dtau) else names(u.theta) if(!is.null(IC.tot.0)){ -##-t-## syt <- system.time({ u.var <- substitute(do.call(cfct, args = list(L2F0, IC0, dim0, dimn0)), list(cfct = cvar.fct, L2F0 = L2Fam, IC0 = IC.tot.0, dim0 = k, dimn0 = list(cnms,cnms))) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("u.var-",updStp)) -##-t-## syt <- system.time({ + sytm <<- .addTime(sytm,paste("u.var-",updStp)) if(withEvalAsVar.0) u.var <- eval(u.var) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("u.var-eval-",updStp)) - # matrix(E(L2Fam, IC.tot.0 %*% t(IC.tot.0)), - # k,k, dimnames = list(cnms,cnms)) + sytm <<- .addTime(sytm,paste("u.var-eval-",updStp)) } if(!var.to.be.c){ -##-t-## syt <- system.time({ var0 <- substitute(do.call(cfct, args = list(L2F0, IC0, dim0, dimn0)), list(cfct = cvar.fct, L2F0 = L2Fam, IC0 = IC.c, dim0 = p)) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("var0-",updStp)) -##-t-## syt <- system.time({ + sytm <<- .addTime(sytm,paste("var0-",updStp)) if(withEvalAsVar.0) var0 <- eval(var0) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("var0-eval-",updStp)) + sytm <<- .addTime(sytm,paste("var0-eval-",updStp)) } } if(withPostModif){ main(Param)[] <- .deleteDim(u.theta[idx]) if (lnx) nuisance(Param)[] <- .deleteDim(u.theta[nuis.idx]) -# print(L2Fam) -##-t-## syt <- system.time({ L2Fam <- modifyModel(L2Fam, Param, .withL2derivDistr = L2Fam at .withEvalL2derivDistr) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("modifyModel-PostModif-",updStp)) -# print(L2Fam) -##-t-## syt <- system.time({ + sytm <<- .addTime(sytm,paste("modifyModel-PostModif-",updStp)) modifyICargs <- c(list(L2Fam, IC, withMakeIC = withMakeIC), E.argList) IC <- do.call(modifyIC(IC),modifyICargs) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("modifyIC-PostModif-",updStp)) -# print(IC) + sytm <<- .addTime(sytm,paste("modifyIC-PostModif-",updStp)) } -##-t-## syt <- system.time({ li <- list(IC = IC, Param = Param, L2Fam = L2Fam, theta = theta, u.theta = u.theta, u.var = u.var, var = var0, IC.tot = IC.tot, IC.c = IC) -##-t-## }) -##-t-## sytm <<- .addTime(sytm,syt,paste("li <- list(IC = IC,...-",updStp)) + sytm <<- .addTime(sytm,paste("li <- list(IC = IC,...-",updStp)) return(li) } @@ -362,46 +319,33 @@ ### iteration -# print(IC at Risks$asCov) -# print(Risks(IC)$asCov) - ksteps <- matrix(0,ncol=steps, nrow = p) uksteps <- matrix(0,ncol=steps, nrow = k) rownames(ksteps) <- est.names rownames(uksteps) <- u.est.names if(!is(modifyIC(IC), "NULL") ){ for(i in 1:steps){ -# modif.old <- modifyIC(IC) if(i>1){ IC <- upd$IC L2Fam <- upd$L2Fam -##-t-## syt <- system.time({ if((i==steps)&&withMakeIC){ makeICargs <- c(list(IC, L2Fam),E.argList) IC <- do.call(makeIC, makeICargs) + sytm <- .addTime(sytm,paste("makeIC-",i)) } -##-t-## }) -##-t-## sytm <- .addTime(sytm,syt,paste("makeIC-",i)) -# IC at modifyIC <- modif.old Param <- upd$Param tf <- trafo(L2Fam, Param) withPre <- FALSE }else withPre <- TRUE -##-t-## syt <- system.time({ upd <- updateStep(u.theta,theta,IC, L2Fam, Param, withPreModif = withPre, withPostModif = (steps>i) | useLast, with.u.var = (i==steps), withEvalAsVar.0 = (i==steps)) -##-t-## }) -##-t-## sytm <- .addTime(sytm,syt,paste("UpdStep-",i)) # print(upd$u.theta); print(upd$theta) uksteps[,i] <- u.theta <- upd$u.theta -# print(str(upd$theta)) -# print(nrow(ksteps)) ksteps[,i] <- theta <- upd$theta -##-t-## syt <- system.time({ if(withICList) ICList[[i]] <- .fixInLiesInSupport( new("InfluenceCurve", @@ -410,8 +354,7 @@ Infos = matrix(c("",""),ncol=2), Curve = EuclRandVarList(upd$IC.tot)), distr = distribution(upd$L2Fam)) -##-t-## }) -##-t-## sytm <- .addTime(sytm,syt,paste("ICList-",i)) + sytm <- .addTime(sytm,paste("ICList-",i)) if(withPICList) pICList[[i]] <- .fixInLiesInSupport(upd$IC.c,distribution(upd$L2Fam)) u.var <- upd$u.var @@ -426,13 +369,11 @@ tf <- trafo(L2Fam, Param) Infos <- rbind(Infos, c("kStepEstimator", "computation of IC, trafo, asvar and asbias via useLast = TRUE")) -##-t-## syt <- system.time({ if(withMakeIC){ makeICargs <- c(list(IC, L2Fam),E.argList) IC <- do.call(makeIC, makeICargs) + sytm <- .addTime(sytm,"makeIC-useLast") } -##-t-## }) -##-t-## sytm <- .addTime(sytm,syt,"makeIC-useLast") }else{ Infos <- rbind(Infos, c("kStepEstimator", "computation of IC, trafo, asvar and asbias via useLast = FALSE")) @@ -440,11 +381,8 @@ }else{ if(steps > 1) stop("slot 'modifyIC' of 'IC' is 'NULL'!") -##-t-## syt <- system.time({ upd <- updateStep(u.theta,theta,IC, L2Fam, Param,withPreModif = FALSE, withPostModif = TRUE) -##-t-## }) -##-t-## sytm <- .addTime(sytm,syt,paste("UpdStep-",i)) theta <- upd$theta u.theta <- upd$u.theta var0 <- upd$var @@ -478,13 +416,11 @@ asVar <- if(is.matrix(Risks(IC)$asCov) || length(Risks(IC)$asCov) == 1) Risks(IC)$asCov else Risks(IC)$asCov$value }else{ -##-t-## syt <- system.time({ getRiskICasVarArgs <- c(list(IC, risk = asCov(), withCheck = FALSE),E.argList) riskAsVar <- do.call(getRiskIC, getRiskICasVarArgs) asVar <- riskAsVar$asCov$value -##-t-## }) + sytm <- .addTime(sytm,"getRiskIC-Var") } -##-t-## sytm <- .addTime(sytm,syt,"getRiskIC-Var") }else asVar <- var0 # print(asVar) @@ -497,11 +433,9 @@ }else{ if(is(IC, "HampIC")){ r <- neighborRadius(IC) -##-t-## syt <- system.time({ asBias <- r*getRiskIC(IC, risk = asBias(), neighbor = neighbor(IC), withCheck = FALSE)$asBias$value -##-t-## }) -##-t-## sytm <- .addTime(sytm,syt,"getRiskIC-Bias") + sytm <- .addTime(sytm,"getRiskIC-Bias") }else{ asBias <- NULL } @@ -526,7 +460,6 @@ IC <- .fixInLiesInSupport(IC, distribution(L2Fam)) -##-t-## syt <- system.time({ estres <- new("kStepEstimate", estimate.call = es.call, name = paste(steps, "-step estimate", sep = ""), estimate = theta, samplesize = nrow(x0), asvar = asVar, @@ -536,13 +469,10 @@ steps = steps, Infos = Infos, start = start, startval = start.val, ustartval = u.start.val, ksteps = ksteps, uksteps = uksteps, pICList = pICList, ICList = ICList) -##-t-## }) -##-t-## sytm <- .addTime(sytm,syt,"new('kStepEstimate'...") -##-t-## syt <- system.time({ + sytm <- .addTime(sytm,"new('kStepEstimate'...") estres <- .checkEstClassForParamFamily(L2Fam,estres) -##-t-## }) -##-t-## sytm <- .addTime(sytm,syt,".checkEstClassForParamFamily") -##-t-## attr(estres,"timings") <- sytm + + attr(estres,"timings") <- apply(sytm,2,diff) return(estres) } Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-15 17:50:33 UTC (rev 1142) +++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-15 20:40:56 UTC (rev 1143) @@ -73,8 +73,12 @@ + for time checking use file TimingChecks.R (with the preparation that the lines commented out by ##-t-## in kStepEstimator.R have to be activated; this uses helper function .addTime to produce a matrix with detailed timing - information which can be read out as argument ) -- it is in package - system folder "chkTimeCode" (in inst/chkTimeCode in r-forge) + information which can be read out as argument ) ++ for time checking in kStepEstimator, the preliminary solution with timings + to be commented (special comments ##-t-##) in and out has been replaced by + permanent calls to proc.time(); this way we avoid creating new environments + (which is time-consuming!) through functions calls to system.time. + helper function .addTime has been adapted accordingly + now specified that we want to use distr::solve + now generateIC.fct produces vectorized functions (can now use useApply=FALSE in E()) + checkIC and makeIC now both use helper function .preparedirectCheckMakeIC @@ -82,13 +86,11 @@ useApply = FALSE to gain speed (code has moved from file IC.R to file CheckMakeIC.R) + several methods (getRiskIC, getBiasIC, getBoundedIC, makeIC, checkIC, modifyIC) gain argument "..." to pass on arguments to E() -+ new internal constant ..IntegrateArgs which contains the names of all arguments - used for integration, i.e., currently, c("lowerTruncQuantile", "upperTruncQuantile", - "IQR.fac", "subdivisions", "rel.tol", "abs.tol", "stop.on.error", "order", "useApply") - this is used to filter out arguments from dots which are meant for E() - by means of exported helper function .filterEargs(); in addition, .filterEargs() - also checks if an argument "E.argList" is hidden in "..." and if so, filters in - its entries (and in case of collision overwrites existing entries). ++ .filterEargs from distrEx is used to filter out arguments from dots which are + meant for E(); this is extended in RobAStBase::.filterEargsWEargList(): + .filterEargsWEargList() also checks if an argument "E.argList" is hidden + in "..." and if so, filters in its entries (and in case of collision + overwrites existing entries). + getboundedIC now uses coordinate-wise integration with useApply = FALSE and only computing the upper half of E LL'w Modified: branches/robast-1.2/pkg/RobAStBase/man/internals.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/internals.Rd 2018-08-15 17:50:33 UTC (rev 1142) +++ branches/robast-1.2/pkg/RobAStBase/man/internals.Rd 2018-08-15 20:40:56 UTC (rev 1143) @@ -4,7 +4,6 @@ \alias{.getDistr} \alias{.msapply} \alias{.fixInLiesInSupport} -\alias{..IntegrateArgs} \title{Internal / Helper functions of package RobAStBase} @@ -17,8 +16,7 @@ .evalListRec(list0) .msapply(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) .fixInLiesInSupport(IC, distr) -..IntegrateArgs -.filterEargs(dots) +.filterEargsWEargList(dots) } \arguments{ \item{x}{a (numeric) vector} @@ -49,11 +47,13 @@ the influence curve (IC), whether the arguments at which the IC is to be evaluated lie in the support of the distribution and accordingly either returns the function value of the IC, or \code{0}; the check is done via calling \code{\link[distr]{liesInSupport}}. -\code{..IntegrateArgs} is an internal constant, containing the names of all arguments - used for integration, i.e., currently, \code{c("lowerTruncQuantile", "upperTruncQuantile", - "IQR.fac", "subdivisions", "rel.tol", "abs.tol", "stop.on.error", "order", "useApply")}. -\code{.filterEargs} filters out of \code{dots} all named arguments which have names - contained in \code{..IntegrateArgs} and returns a list with these items. +\code{.filterEargsWEargList} calls \code{distrEx::.filterEargs} to filter out of \code{dots} +all relevant arguments for the integrators, \code{integrate}, \code{GLIntegrate}, +and \code{distrExIntegrate}; in addition, \code{.filterEargsWEargList} +checks if an argument "E.argList" is hidden in the \code{dots} argument +and if so, filters in its entries; in case of collisions with entries filtered +from \code{distrEx::.filterEargs}, it overwrites existing entries. In the +end it returns a list with the filtered items. } Modified: branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd 2018-08-15 17:50:33 UTC (rev 1142) +++ branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd 2018-08-15 20:40:56 UTC (rev 1143) @@ -79,6 +79,9 @@ used to re-compute the IC for a different parameter), the computation of \code{asvar}, \code{asbias} and \code{IC} is based on the k-step estimate. + + Timings for the several substeps are available as attribute + \code{timings} of the return value. } \value{Object of class \code{"kStepEstimate"}.} @@ -112,6 +115,7 @@ ksteps(est1) pICList(est1) start(est1) +attr(est1,"timings") ## a transformed model tfct <- function(x){ From noreply at r-forge.r-project.org Wed Aug 15 22:45:41 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 15 Aug 2018 22:45:41 +0200 (CEST) Subject: [Robast-commits] r1144 - branches/robast-1.2/pkg/ROptEst/R Message-ID: <20180815204541.13790188E93@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-15 22:45:40 +0200 (Wed, 15 Aug 2018) New Revision: 1144 Modified: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R branches/robast-1.2/pkg/ROptEst/R/L1L2normL2deriv.R branches/robast-1.2/pkg/ROptEst/R/LowerCaseMultivariate.R branches/robast-1.2/pkg/ROptEst/R/getInfCent.R branches/robast-1.2/pkg/ROptEst/R/getInfClip.R branches/robast-1.2/pkg/ROptEst/R/getInfGamma.R branches/robast-1.2/pkg/ROptEst/R/getInfLM.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asGRisk.R branches/robast-1.2/pkg/ROptEst/R/getInfStand.R branches/robast-1.2/pkg/ROptEst/R/getInfV.R branches/robast-1.2/pkg/ROptEst/R/leastFavorableRadius.R branches/robast-1.2/pkg/ROptEst/R/radiusMinimaxIC.R Log: [ROptEst] branch 1.2 + renamed .filterEargs by .filterEargsWEargList Modified: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -153,7 +153,7 @@ .getG1G2G3Stand <- function(L2deriv, Distr, A.comp, z.comp, w, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE w.fct <- function(x){ Modified: branches/robast-1.2/pkg/ROptEst/R/L1L2normL2deriv.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/L1L2normL2deriv.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/L1L2normL2deriv.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -9,7 +9,7 @@ setMethod("getL1normL2deriv", signature(L2deriv = "RealRandVariable"), function(L2deriv, cent, stand, Distr, normtype, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE integrandG <- function(x, L2, stand, cent){ Modified: branches/robast-1.2/pkg/ROptEst/R/LowerCaseMultivariate.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/LowerCaseMultivariate.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/LowerCaseMultivariate.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -3,7 +3,7 @@ A.start = NULL, z.comp = NULL, A.comp = NULL, maxiter, tol, verbose = NULL, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE if(missing(verbose)|| is.null(verbose)) @@ -106,7 +106,7 @@ A.start = NULL, maxiter, tol, verbose = NULL, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE if(missing(verbose)|| is.null(verbose)) Modified: branches/robast-1.2/pkg/ROptEst/R/getInfCent.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfCent.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/getInfCent.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -41,7 +41,7 @@ function(L2deriv, neighbor, biastype, Distr, z.comp, w, tol.z = .Machine$double.eps^.5, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE stand <- stand(w) @@ -70,7 +70,7 @@ function(L2deriv, neighbor, biastype, Distr, z.comp, w, tol.z = .Machine$double.eps^.5, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE integrand1 <- function(x){ Modified: branches/robast-1.2/pkg/ROptEst/R/getInfClip.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfClip.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/getInfClip.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -157,7 +157,7 @@ neighbor = "ContNeighborhood"), function(clip, L2deriv, risk, neighbor, biastype, cent, symm, trafo, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE biastype <- if(sign(risk)==1) positiveBias() else negativeBias() Modified: branches/robast-1.2/pkg/ROptEst/R/getInfGamma.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfGamma.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/getInfGamma.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -31,7 +31,7 @@ function(L2deriv, risk, neighbor, biastype, Distr, stand, cent, clip, power = 1L, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE integrandG <- function(x, L2, stand, cent, clip){ @@ -54,7 +54,7 @@ function(L2deriv, risk, neighbor, biastype, Distr, stand, cent, clip, power = 1L, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE integrandG <- function(x, L2, stand, cent, clip){ Modified: branches/robast-1.2/pkg/ROptEst/R/getInfLM.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfLM.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/getInfLM.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -113,7 +113,7 @@ ### manipulate dots in call -> set control argument for optim dots <- list(...) - dotsI <- .filterEargs(dots) + dotsI <- .filterEargsWEargList(dots) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE if(is.null(dots$method)) dots$method <- "L-BFGS-B" Modified: branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -109,7 +109,7 @@ OptOrIter = "iterate", maxiter, tol, warn, verbose = NULL, checkBounds = TRUE, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE if(missing(verbose)|| is.null(verbose)) Modified: branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asGRisk.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asGRisk.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asGRisk.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -597,7 +597,7 @@ .checkPIC <- function(L2deriv, neighbor, Distr, trafo, z, A, w, z.comp, A.comp, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE cat("some check:\n-----------\n") Modified: branches/robast-1.2/pkg/ROptEst/R/getInfStand.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfStand.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/getInfStand.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -24,7 +24,7 @@ function(L2deriv, neighbor, biastype, Distr, A.comp, cent, trafo, w, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE w.fct <- function(x){ @@ -54,7 +54,7 @@ neighbor = "ContNeighborhood", biastype = "onesidedBias"), function(L2deriv, neighbor, biastype, clip, cent, trafo, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE c1 <- if (sign(biastype)<0) cent - clip else -Inf c2 <- if (sign(biastype)>0) cent + clip else Inf Modified: branches/robast-1.2/pkg/ROptEst/R/getInfV.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getInfV.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/getInfV.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -33,7 +33,7 @@ function(L2deriv, neighbor, biastype, Distr, V.comp, cent, stand, w, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE w.fct <- function(x){ @@ -71,7 +71,7 @@ function(L2deriv, neighbor, biastype, Distr, V.comp, cent, stand, w, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE w.fct <- function(x){ @@ -97,7 +97,7 @@ biastype = "onesidedBias"), function(L2deriv, neighbor, biastype, clip, cent, stand, ...){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE c1 <- if (sign(biastype)<0) cent - clip else -Inf Modified: branches/robast-1.2/pkg/ROptEst/R/leastFavorableRadius.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/leastFavorableRadius.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/leastFavorableRadius.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -17,7 +17,7 @@ if((rho <= 0)||(rho >= 1)) stop("'rho' not in (0,1)") - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE biastype <- biastype(risk) Modified: branches/robast-1.2/pkg/ROptEst/R/radiusMinimaxIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/radiusMinimaxIC.R 2018-08-15 20:40:56 UTC (rev 1143) +++ branches/robast-1.2/pkg/ROptEst/R/radiusMinimaxIC.R 2018-08-15 20:45:40 UTC (rev 1144) @@ -12,7 +12,7 @@ verbose = NULL, loRad0 = 1e-3, ..., returnNAifProblem = FALSE, loRad.s = NULL, upRad.s = NULL, modifyICwarn = NULL){ - dotsI <- .filterEargs(list(...)) + dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE if(missing(verbose)|| is.null(verbose)) From noreply at r-forge.r-project.org Wed Aug 15 22:56:26 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 15 Aug 2018 22:56:26 +0200 (CEST) Subject: [Robast-commits] r1145 - branches/robast-1.2/pkg/ROptEst/man Message-ID: <20180815205627.01113188E93@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-15 22:56:26 +0200 (Wed, 15 Aug 2018) New Revision: 1145 Modified: branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd branches/robast-1.2/pkg/ROptEst/man/roptest.Rd Log: [ROptEst] branch 2.8: - mention the possibility to inspect timings in help to roptest / RMXE/MBRE/OBRE/OMSEstimators, Modified: branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd 2018-08-15 20:45:40 UTC (rev 1144) +++ branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd 2018-08-15 20:56:26 UTC (rev 1145) @@ -178,6 +178,10 @@ All these estimators are realized as wrappers to function \code{roptest}. + Timings for the steps run through in these estimators are available + in attributes \code{timings}, and for the step of the + \code{kStepEstimator} in \code{kStepTimings}. + } \value{Object of class \code{"kStepEstimate"}. In addition, it has an attribute \code{"timings"} where computation time is stored.} Modified: branches/robast-1.2/pkg/ROptEst/man/roptest.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/roptest.Rd 2018-08-15 20:45:40 UTC (rev 1144) +++ branches/robast-1.2/pkg/ROptEst/man/roptest.Rd 2018-08-15 20:56:26 UTC (rev 1145) @@ -194,6 +194,10 @@ If \code{useLast} is set to \code{TRUE} the computation of \code{asvar}, \code{asbias} and \code{IC} is based on the k-step estimate. + + Timings for the steps run through in \code{roptest} are available + in attributes \code{timings}, and for the step of the + \code{kStepEstimator} in \code{kStepTimings}. } \value{Object of class \code{"kStepEstimate"}. In addition, it has an attribute \code{"timings"} where computation time is stored.} From noreply at r-forge.r-project.org Thu Aug 16 00:26:14 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 00:26:14 +0200 (CEST) Subject: [Robast-commits] r1146 - in branches/robast-1.2/pkg/RobExtremes: . R inst/scripts man Message-ID: <20180815222615.0557A18A425@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 00:26:14 +0200 (Thu, 16 Aug 2018) New Revision: 1146 Modified: branches/robast-1.2/pkg/RobExtremes/NAMESPACE branches/robast-1.2/pkg/RobExtremes/R/AllClass.R branches/robast-1.2/pkg/RobExtremes/R/Expectation.R branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R branches/robast-1.2/pkg/RobExtremes/R/startEstGEV.R branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R branches/robast-1.2/pkg/RobExtremes/man/E.Rd branches/robast-1.2/pkg/RobExtremes/man/GEVFamily.Rd branches/robast-1.2/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd Log: [RobExtremes] branch 2.8: + fixed minor issues in scripts/RobFitsAtRealData.R + expectation E() of Pareto, GPD, and GEV gain argument diagnostic and use dot-filtering (like in distrEx) + minor bugfixes in .getBetaXiGEW + new S4 classes "GPDML.ALEstimate", "GPDCvMMD.ALEstimate", and "GEVML.ALEstimate", "GEVCvMMD.ALEstimate" + warning/caveat in the help to GEVFamily/GEVFamilyMuUnknown as to the accuracy of PickandsEstimator for GEV + deleted classes "GPDMCALEstimate", "GEVMCALEstimate" as not every MCE is an ALE -> this gave misleading error messages Modified: branches/robast-1.2/pkg/RobExtremes/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/RobExtremes/NAMESPACE 2018-08-15 20:56:26 UTC (rev 1145) +++ branches/robast-1.2/pkg/RobExtremes/NAMESPACE 2018-08-15 22:26:14 UTC (rev 1146) @@ -29,10 +29,13 @@ exportClasses("DistributionsIntegratingByQuantiles") exportClasses("ParamWithLocAndScaleAndShapeFamParameter") exportClasses("L2LocScaleShapeUnion") -exportClasses("GPDEstimate","GPDMCEstimate","GPDMCALEstimate","GPDLDEstimate", +exportClasses("GPDEstimate","GPDMCEstimate","GPDLDEstimate", "GPDkStepEstimate","GEVEstimate","GEVLDEstimate", - "GEVkStepEstimate","GEVMCEstimate", "GEVMCALEstimate", - "GPDORobEstimate","GEVORobEstimate") + "GEVkStepEstimate","GEVMCEstimate", + "GPDORobEstimate","GEVORobEstimate", + GEVCvMMD.ALEstimate,GEVML.ALEstimate, + GPDCvMMD.ALEstimate,GPDML.ALEstimate) + exportMethods("initialize", "show", "rescaleFunction") exportMethods("loc", "loc<-", "kMAD", "Sn", "Qn") exportMethods("validParameter", Modified: branches/robast-1.2/pkg/RobExtremes/R/AllClass.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/AllClass.R 2018-08-15 20:56:26 UTC (rev 1145) +++ branches/robast-1.2/pkg/RobExtremes/R/AllClass.R 2018-08-15 22:26:14 UTC (rev 1146) @@ -284,15 +284,20 @@ setOldClass("gev.fit") setOldClass("gpd.fit") + setClass("GPDEstimate", contains="Estimate") setClass("GPDMCEstimate", contains=c("MCEstimate", "GPDEstimate")) -setClass("GPDMCALEstimate", contains=c("MCALEstimate", "GPDEstimate")) +setClass("GPDML.ALEstimate", contains=c("ML.ALEstimate", "GPDEstimate")) +setClass("GPDCvMMD.ALEstimate", contains=c("CvMMD.ALEstimate", "GPDEstimate")) setClass("GPDLDEstimate", contains=c("LDEstimate", "GPDEstimate")) setClass("GPDkStepEstimate", contains=c("kStepEstimate", "GPDEstimate")) setClass("GPDORobEstimate", contains=c("ORobEstimate", "GPDkStepEstimate")) + setClass("GEVEstimate", contains="Estimate") setClass("GEVLDEstimate", contains=c("LDEstimate", "GEVEstimate")) setClass("GEVkStepEstimate", contains=c("kStepEstimate", "GEVEstimate")) setClass("GEVORobEstimate", contains=c("ORobEstimate", "GEVkStepEstimate")) setClass("GEVMCEstimate", contains=c("MCEstimate", "GEVEstimate")) -setClass("GEVMCALEstimate", contains=c("MCALEstimate", "GEVEstimate")) +setClass("GEVML.ALEstimate", contains=c("ML.ALEstimate", "GEVEstimate")) +setClass("GEVCvMMD.ALEstimate", contains=c("CvMMD.ALEstimate", "GEVEstimate")) + Modified: branches/robast-1.2/pkg/RobExtremes/R/Expectation.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/Expectation.R 2018-08-15 20:56:26 UTC (rev 1145) +++ branches/robast-1.2/pkg/RobExtremes/R/Expectation.R 2018-08-15 22:26:14 UTC (rev 1146) @@ -7,7 +7,7 @@ setMethod("E", signature(object = "Pareto", fun = "missing", cond = "missing"), - function(object, low = NULL, upp = NULL, ...){ + function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){ if(!is.null(low)) if(low <= Min(object)) low <- NULL a <- shape(object); b <- Min(object) if(is.null(low) && is.null(upp)){ @@ -15,7 +15,8 @@ else return(b*a/(a-1)) } else - return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...)) + return(E(object=object,fun=function(x)x, low=low, upp=upp, ..., + diagnostic = diagnostic)) }) ### source http://mathworld.wolfram.com/ParetoDistribution.html @@ -24,18 +25,20 @@ setMethod("E", signature(object = "Gumbel", fun = "missing", cond = "missing"), - function(object, low = NULL, upp = NULL, ...){a <- loc(object); b <- scale(object) + function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){ + a <- loc(object); b <- scale(object) if(is.null(low) && is.null(upp)) return(a- EULERMASCHERONICONSTANT * b) else - return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...)) + return(E(object=object,fun=function(x)x, low=low, upp=upp, ..., + diagnostic = diagnostic)) }) ## http://mathworld.wolfram.com/GumbelDistribution.html setMethod("E", signature(object = "GPareto", fun = "missing", cond = "missing"), - function(object, low = NULL, upp = NULL, ...){ + function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){ if(!is.null(low)) if(low <= Min(object)) low <- NULL k <- shape(object); s <- scale(object); mu <- loc(object) if(is.null(low) && is.null(upp)){ @@ -43,7 +46,8 @@ else return(mu+s/(1-k)) } else - return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...)) + return(E(object=object,fun=function(x)x, low=low, upp=upp, ..., + diagnostic = diagnostic)) }) ### source http://en.wikipedia.org/wiki/Pareto_distribution @@ -55,13 +59,20 @@ rel.tol= getdistrExOption("ErelativeTolerance"), lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), - IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ... - ){ - .qtlIntegrate(object = object, fun = fun, low = low, upp = upp, + IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ..., + diagnostic = FALSE){ + + dots <- list(...) + dotsI <- .filterEargs(dots) + dotsFun <- .filterFunargs(dots,fun) + funwD <- function(x) do.call(fun, c(list(x=x),dotsFun)) + + do.call(.qtlIntegrate, c(list(object = object, fun = funwD, low = low, upp = upp, rel.tol= rel.tol, lowerTruncQuantile = lowerTruncQuantile, upperTruncQuantile = upperTruncQuantile, IQR.fac = IQR.fac, ..., - .withLeftTail = FALSE, .withRightTail = TRUE) + .withLeftTail = FALSE, .withRightTail = TRUE, + diagnostic = diagnostic),dotsI)) }) setMethod("E", signature(object = "GPareto", @@ -71,11 +82,11 @@ rel.tol= getdistrExOption("ErelativeTolerance"), lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), - IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ... - ){ + IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ..., + diagnostic = FALSE){ dots <- list(...) - dots.withoutUseApply <- dots + dots.withoutUseApply <- .filterEargs(dots) useApply <- TRUE if(!is.null(dots$useApply)) useApply <- dots$useApply dots.withoutUseApply$useApply <- NULL @@ -100,7 +111,8 @@ lower = low, upper = upp, rel.tol = rel.tol, - distr = object, dfun = d(object)), dots.withoutUseApply))) + distr = object, dfun = d(object)), dots.withoutUseApply, + diagnostic = diagnostic))) }) @@ -108,7 +120,7 @@ setMethod("E", signature(object = "GEV", fun = "missing", cond = "missing"), - function(object, low = NULL, upp = NULL, ...){ + function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){ if(!is.null(low)) if(low <= Min(object)) low <- NULL xi <- shape(object); sigma <- scale(object); mu <- loc(object) if(is.null(low) && is.null(upp)){ @@ -117,7 +129,8 @@ else return(mu+sigma*(gamma(1-xi)-1)/xi) } else - return(E(object, low=low, upp=upp, fun = function(x)x, ...)) + return(E(object, low=low, upp=upp, fun = function(x)x, ..., + diagnostic = diagnostic)) }) setMethod("E", signature(object = "GEV", fun = "function", cond = "missing"), Modified: branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-08-15 20:56:26 UTC (rev 1145) +++ branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-08-15 22:26:14 UTC (rev 1146) @@ -1,3 +1,19 @@ +.castToALE <- function(PFam, estimator, toclass){ + fromSlotNames <- slotNames(class(estimator)) + to <- new(toclass) + for(item in fromSlotNames) slot(to, item) <- slot(estimator,item) + to at pIC <- substitute(getPIC(estimator0), list(estimator0=estimator)) + return(to) +} + +setClass("GPDEstimate", contains="Estimate") +setClass("GPDLDEstimate", contains=c("LDEstimate", "GPDEstimate")) +setClass("GPDkStepEstimate", contains=c("kStepEstimate", "GPDEstimate")) +setClass("GPDORobEstimate", contains=c("ORobEstimate", "GPDkStepEstimate")) +setClass("GPDMCEstimate", contains=c("MCEstimate", "GPDEstimate")) +setClass("GPDML.ALEstimate", contains=c("ML.ALEstimate", "GPDEstimate")) +setClass("GPDCvMMD.ALEstimate", contains=c("CvMMD.ALEstimate", "GPDEstimate")) + setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GParetoFamily",estimator="Estimate"), function(PFam, estimator) as(estimator,"GPDEstimate")) @@ -12,28 +28,13 @@ function(PFam, estimator) as(estimator,"GPDORobEstimate")) setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GParetoFamily",estimator="MCEstimate"), - function(PFam, estimator){# ret0 <- as(estimator,"GPDMCEstimate") - fromSlotNames <- slotNames(class(estimator)) - to <- new("GPDMCALEstimate") - for(item in fromSlotNames) slot(to, item) <- slot(estimator,item) - to at pIC <- substitute(getPIC(estimator0), list(estimator0=estimator)) - return(to) - }) + function(PFam, estimator) as(estimator,"GPDMCEstimate")) setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GParetoFamily",estimator="MLEstimate"), - getMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GParetoFamily",estimator="MCEstimate"))) + function(PFam,estimator) .castToALE(PFam, estimator, "GPDML.ALEstimate")) setMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GParetoFamily",estimator="MDEstimate"), - getMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GParetoFamily",estimator="MCEstimate"))) -setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GParetoFamily",estimator="CvMMDEstimate"), - getMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GParetoFamily",estimator="MCEstimate"))) -setMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GParetoFamily",estimator="MCALEstimate"), - function(PFam, estimator) as(estimator,"GPDMCALEstimate")) + function(PFam,estimator) .castToALE(PFam, estimator, "GPDCvMMD.ALEstimate")) setMethod(".checkEstClassForParamFamily", @@ -50,28 +51,13 @@ function(PFam, estimator) as(estimator,"GEVORobEstimate")) setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamily",estimator="MCEstimate"), - function(PFam, estimator){ #ret0 <- as(estimator,"GEVMCEstimate") - fromSlotNames <- slotNames(class(estimator)) - to <- new("GEVMCALEstimate") - for(item in fromSlotNames) slot(to, item) <- slot(estimator,item) - to at pIC <- substitute(getPIC(estimator0), list(estimator0=estimator)) - return(to) - }) + function(PFam, estimator) as(estimator,"GEVMCEstimate")) setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamily",estimator="MLEstimate"), - getMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GEVFamily",estimator="MCEstimate"))) + function(PFam,estimator) .castToALE(PFam, estimator, "GEVML.ALEstimate")) setMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GEVFamily",estimator="MDEstimate"), - getMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GEVFamily",estimator="MCEstimate"))) -setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamily",estimator="CvMMDEstimate"), - getMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GEVFamily",estimator="MCEstimate"))) -setMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GEVFamily",estimator="MCALEstimate"), - function(PFam, estimator) as(estimator,"GEVMCALEstimate")) + function(PFam,estimator) .castToALE(PFam, estimator, "GPDCvMMD.ALEstimate")) setMethod(".checkEstClassForParamFamily", @@ -88,25 +74,10 @@ function(PFam, estimator) as(estimator,"GEVORobEstimate")) setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCEstimate"), - function(PFam, estimator){ #ret0 <- as(estimator,"GEVMCEstimate") - fromSlotNames <- slotNames(class(estimator)) - to <- new("GEVMCALEstimate") - for(item in fromSlotNames) slot(to, item) <- slot(estimator,item) - to at pIC <- substitute(getPIC(estimator0), list(estimator0=estimator)) - return(to) - }) + function(PFam, estimator) as(estimator,"GEVMCEstimate")) setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamilyMuUnknown",estimator="MLEstimate"), - getMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCEstimate"))) + function(PFam,estimator) .castToALE(PFam, estimator, "GEVML.ALEstimate")) setMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GEVFamilyMuUnknown",estimator="MDEstimate"), - getMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCEstimate"))) -setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamilyMuUnknown",estimator="CvMMDEstimate"), - getMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCEstimate"))) -setMethod(".checkEstClassForParamFamily", - signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCALEstimate"), - function(PFam, estimator) as(estimator,"GEVMCALEstimate")) + function(PFam,estimator) .castToALE(PFam, estimator, "GPDCvMMD.ALEstimate") ) Modified: branches/robast-1.2/pkg/RobExtremes/R/startEstGEV.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/startEstGEV.R 2018-08-15 20:56:26 UTC (rev 1145) +++ branches/robast-1.2/pkg/RobExtremes/R/startEstGEV.R 2018-08-15 22:26:14 UTC (rev 1146) @@ -30,14 +30,15 @@ names(e0) <- c("scale","shape") return(e0) } - mygev <- GEVFamily(loc=0,scale=e0[1],shape=e0[2], withPos=withPos, + mygev <- GEVFamily(loc=0,scale=e0[1],shape=e0[2], + withPos=withPos, start0Est = fu, ..withWarningGEV=FALSE) mde0 <- try(MDEstimator(x0, mygev, distance=CvMDist, startPar=c("scale"=e0[1],"shape"=e0[2])),silent=TRUE) if(!is(mde0,"try-error")){ es <- estimate(mde0) crit1 <- criterion(mde0) if(.issueIntermediateParams){ - cat("1st candidate:\n", round(es,6), " crit:", round(crit1,6), , " ") + cat("1st candidate:\n", round(es,6), " crit:", round(crit1,6), "\n") } if(quantile(1+es[2]*x0/es[1], epsn/n)>0){ validi <- 1 @@ -114,8 +115,8 @@ } } } - names(es) <- c("scale","shape") - return(es) + names(es0) <- c("scale","shape") + return(es0) } .getMuBetaXiGEV <- function(x, xiGrid = .getXiGrid(), withPos=TRUE, secLevel = 0.7, Modified: branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-15 20:56:26 UTC (rev 1145) +++ branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-15 22:26:14 UTC (rev 1146) @@ -56,7 +56,7 @@ checkIC(pIC(RMXiw), forceContICMethod = TRUE) ## uses contIC 0 - 1 standardization... ## for a moment remove this method -oldM <- setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily")) +oldM <- getMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily")) removeMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily")) system.time(RMXiw2 <- RMXEstimator(portpiriei, GEVFam,withMakeIC=TRUE)) checkIC(pIC(RMXiw2)) @@ -64,7 +64,7 @@ estimate(RMXi) estimate(RMXiw) -estimate(RMXiw) +estimate(RMXiw2) ## our output: mlEi Modified: branches/robast-1.2/pkg/RobExtremes/man/E.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/E.Rd 2018-08-15 20:56:26 UTC (rev 1145) +++ branches/robast-1.2/pkg/RobExtremes/man/E.Rd 2018-08-15 22:26:14 UTC (rev 1146) @@ -20,21 +20,21 @@ \usage{ E(object, fun, cond, ...) -\S4method{E}{GEV,missing,missing}(object, low = NULL, upp = NULL, ...) +\S4method{E}{GEV,missing,missing}(object, low = NULL, upp = NULL, ..., diagnostic = FALSE) \S4method{E}{DistributionsIntegratingByQuantiles,function,missing}(object, fun, low = NULL, upp = NULL, rel.tol= getdistrExOption("ErelativeTolerance"), lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), - IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...) -\S4method{E}{Gumbel,missing,missing}(object, low = NULL, upp = NULL, ...) -\S4method{E}{GPareto,missing,missing}(object, low = NULL, upp = NULL, ...) + IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ..., diagnostic = FALSE) +\S4method{E}{Gumbel,missing,missing}(object, low = NULL, upp = NULL, ..., diagnostic = FALSE) +\S4method{E}{GPareto,missing,missing}(object, low = NULL, upp = NULL, ..., diagnostic = FALSE) \S4method{E}{GPareto,function,missing}(object, fun, low = NULL, upp = NULL, rel.tol= getdistrExOption("ErelativeTolerance"), lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), - IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...) -\S4method{E}{Pareto,missing,missing}(object, low = NULL, upp = NULL, ...) + IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ..., diagnostic = FALSE) +\S4method{E}{Pareto,missing,missing}(object, low = NULL, upp = NULL, ..., diagnostic = FALSE) } \arguments{ \item{object}{ object of class \code{"Distribution"}} @@ -50,6 +50,12 @@ \item{IQR.fac}{factor for scale based integration range (i.e.; median of the distribution \eqn{\pm}{+-}\code{IQR.fac}\eqn{\times}{*}IQR).} \item{\dots}{ additional arguments to \code{fun} } + \item{diagnostic}{ logical; if \code{TRUE}, the return value obtains + an attribute \code{"diagnostic"} with diagnostic information on the + integration, i.e., a list with entries \code{method} (\code{"integrate"} + or \code{"GLIntegrate"}), \code{call}, \code{result} (the complete return + value of the method), \code{args} (the args with which the + method was called), and \code{time} (the time to compute the integral). } } \details{The precision of the computations can be controlled via certain global options; cf. \code{\link{distrExOptions}}. Modified: branches/robast-1.2/pkg/RobExtremes/man/GEVFamily.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/GEVFamily.Rd 2018-08-15 20:56:26 UTC (rev 1145) +++ branches/robast-1.2/pkg/RobExtremes/man/GEVFamily.Rd 2018-08-15 22:26:14 UTC (rev 1146) @@ -38,7 +38,12 @@ be computed? Defaults to \code{FALSE} (to speed up computations).} \item{withMDE}{logical: should Minimum Distance Estimators be used to find a good starting value for the parameter search? - Defaults to \code{FALSE} (to speed up computations).} + Defaults to \code{FALSE} (to speed up computations). + We have seen cases though, where the use of the then + employed \code{PickandsEstimator} was drastically misleading + and subsequently led to bad estimates where it is used + as starting value; so where feasible it is a good idea + to also try argument \code{withMDE=TRUE} for control purposes.} \item{..ignoreTrafo}{logical: only used internally in \code{kStepEstimator}; do not change this.} \item{..withWarningGEV}{logical: shall warnings be issued if shape is large?} } Modified: branches/robast-1.2/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd 2018-08-15 20:56:26 UTC (rev 1145) +++ branches/robast-1.2/pkg/RobExtremes/man/GEVFamilyMuUnknown.Rd 2018-08-15 22:26:14 UTC (rev 1146) @@ -39,7 +39,12 @@ be computed? Defaults to \code{FALSE} (to speed up computations).} \item{withMDE}{logical: should Minimum Distance Estimators be used to find a good starting value for the parameter search? - Defaults to \code{FALSE} (to speed up computations).} + Defaults to \code{FALSE} (to speed up computations). + We have seen cases though, where the use of the then + employed \code{PickandsEstimator} was drastically misleading + and subsequently led to bad estimates where it is used + as starting value; so where feasible it is a good idea + to also try argument \code{withMDE=TRUE} for control purposes.} \item{..ignoreTrafo}{logical: only used internally in \code{kStepEstimator}; do not change this.} \item{..withWarningGEV}{logical: shall warnings be issued if shape is large?} \item{..name}{character: optional alternative name for the parametric family; Modified: branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd 2018-08-15 20:56:26 UTC (rev 1145) +++ branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd 2018-08-15 22:26:14 UTC (rev 1146) @@ -7,27 +7,21 @@ \alias{.checkEstClassForParamFamily,GParetoFamily,MCEstimate-method} \alias{.checkEstClassForParamFamily,GParetoFamily,kStepEstimate-method} \alias{.checkEstClassForParamFamily,GParetoFamily,ORobEstimate-method} -\alias{.checkEstClassForParamFamily,GParetoFamily,MCALEstimate-method} \alias{.checkEstClassForParamFamily,GParetoFamily,MLEstimate-method} -\alias{.checkEstClassForParamFamily,GParetoFamily,MDEstimate-method} \alias{.checkEstClassForParamFamily,GParetoFamily,CvMMDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,Estimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,MCEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,LDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,kStepEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,ORobEstimate-method} -\alias{.checkEstClassForParamFamily,GEVFamily,MCALEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,MLEstimate-method} -\alias{.checkEstClassForParamFamily,GEVFamily,MDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,CvMMDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,Estimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,MCEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,LDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,kStepEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,ORobEstimate-method} -\alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,MCALEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,MLEstimate-method} -\alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,MDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,CvMMDEstimate-method} \title{ Methods for Function .checkEstClassForParamFamily in Package `RobExtremes' } \description{.checkEstClassForParamFamily-methods} Modified: branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd 2018-08-15 20:56:26 UTC (rev 1145) +++ branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd 2018-08-15 22:26:14 UTC (rev 1146) @@ -5,14 +5,16 @@ \alias{GEVEstimate-class} \alias{GPDMCEstimate-class} \alias{GEVMCEstimate-class} -\alias{GPDMCALEstimate-class} -\alias{GEVMCALEstimate-class} \alias{GPDLDEstimate-class} \alias{GEVLDEstimate-class} \alias{GPDkStepEstimate-class} \alias{GEVkStepEstimate-class} \alias{GPDORobEstimate-class} \alias{GEVORobEstimate-class} +\alias{GPDCvMMD.ALEstimate-class} +\alias{GEVCvMMD.ALEstimate-class} +\alias{GPDML.ALEstimate-class} +\alias{GEVML.ALEstimate-class} \title{Internal Estimator Return Classes in 'RobExtremes'} \description{S4 classes for return values of estimators in package \pkg{RobExtremes} defined for internal @@ -21,10 +23,11 @@ \section{Described classes}{ The S4 classes described here are \code{GPDEstimate}, \code{GEVEstimate}, \code{GPDMCEstimate}, \code{GEVMCEstimate}, - \code{GPDMCALEstimate}, \code{GEVMCALEstimate}, \code{GPDLDEstimate}, \code{GEVLDEstimate}, - \code{GPDkStepEstimate}, \code{GEVkStepEstimate} - \code{GPDORobEstimate}, \code{GEVORobEstimate}.} + \code{GPDkStepEstimate}, \code{GEVkStepEstimate}, + \code{GPDORobEstimate}, \code{GEVORobEstimate}, +\code{GPDML.ALEstimate}, \code{GEVML.ALEstimate}, +\code{GPDCvMMD.ALEstimate}, \code{GEVCvMMD.ALEstimate}.} \section{Objects from the Class}{These classes are used internally to provide specific S4 methods for different estimators later on; @@ -55,6 +58,14 @@ \code{ORobEstimate}, directly.\cr Class \code{GEVORobEstimate} extends classes \code{GEVkStepEstimate}, \code{ORobEstimate}, directly.\cr +Class \code{GPDML.ALEstimate} extends classes \code{GPDEstimate}, +\code{ML.ALEstimate}, directly.\cr +Class \code{GEVML.ALEstimate} extends classes \code{GEVEstimate}, +\code{ML.ALEstimate}, directly.\cr +Class \code{GPDCvMMD.ALEstimate} extends classes \code{GPDEstimate}, +\code{CvMMD.ALEstimate}, directly.\cr +Class \code{GEVCvMMD.ALEstimate} extends classes \code{GEVEstimate}, +\code{CvMMD.ALEstimate}, directly.\cr } %\references{} \author{Peter Ruckdeschel \email{peter.ruckdeschel at uni-oldenburg.de}} From noreply at r-forge.r-project.org Thu Aug 16 09:58:34 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 09:58:34 +0200 (CEST) Subject: [Robast-commits] r1147 - branches/robast-1.2/pkg/RobAStBase/R Message-ID: <20180816075834.77A251884BE@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 09:58:34 +0200 (Thu, 16 Aug 2018) New Revision: 1147 Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R Log: [RobAStBase] branch 1.2 small issue: forgot to "delete" the on.exit() message in kStepEstimator.R Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-15 22:26:14 UTC (rev 1146) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-16 07:58:34 UTC (rev 1147) @@ -473,6 +473,7 @@ estres <- .checkEstClassForParamFamily(L2Fam,estres) attr(estres,"timings") <- apply(sytm,2,diff) + on.exit() return(estres) } From noreply at r-forge.r-project.org Thu Aug 16 10:07:01 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 10:07:01 +0200 (CEST) Subject: [Robast-commits] r1148 - in branches/robast-1.2/pkg/RobExtremes: inst/scripts man Message-ID: <20180816080701.49147180257@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 10:07:00 +0200 (Thu, 16 Aug 2018) New Revision: 1148 Modified: branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd Log: [RobExtremes] branch 1.2 + minor changes in scripts/RobFitsAtRealData.R + added documentation to new classes (forgotten in last commit) Modified: branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-16 07:58:34 UTC (rev 1147) +++ branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-16 08:07:00 UTC (rev 1148) @@ -60,7 +60,7 @@ removeMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily")) system.time(RMXiw2 <- RMXEstimator(portpiriei, GEVFam,withMakeIC=TRUE)) checkIC(pIC(RMXiw2)) -setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily")) <- oldM +setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"),oldM) estimate(RMXi) estimate(RMXiw) @@ -80,6 +80,7 @@ estimate(RMXiw) ### where do the robust estimators spend their time? attr(MBRi, "timings") +attr(MBRi, "kStepTimings") ## our return values can be plugged into ismev-diagnostics: devNew() Modified: branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd 2018-08-16 07:58:34 UTC (rev 1147) +++ branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd 2018-08-16 08:07:00 UTC (rev 1148) @@ -54,25 +54,45 @@ the \code{GParetoFamily,LDEstimate}-method cast to S4 class \code{GPDLDEstimate},\cr the \code{GParetoFamily,MCEstimate}-method cast to -S4 class \code{GPDMCALEstimate},\cr +S4 class \code{GPDMCEstimate},\cr the \code{GParetoFamily,kStepEstimate}-method cast to -S4 class \code{GPDkStepstimate},\cr -the \code{GEVFamily,Estimate}-method cast to -S4 class \code{GEVEstimate},\cr +S4 class \code{GPDkStepEstimate},\cr +the \code{GParetoFamily,ORobEstimate}-method cast to +S4 class \code{GPDORobEstimate},\cr +the \code{GParetoFamily,MLEstimate}-method cast to +S4 class \code{GPDML.ALEstimate},\cr +the \code{GParetoFamily,CvMMDEstimate}-method cast to +S4 class \code{GPDCvMMD.ALEstimate},\cr + +The \code{GEVFamily,Estimate}-method returns the estimator cast to +S4 class \code{GEVEstimate},\cr the \code{GEVFamily,LDEstimate}-method cast to S4 class \code{GEVLDEstimate},\cr the \code{GEVFamily,MCEstimate}-method cast to -S4 class \code{GEVMCALEstimate},\cr +S4 class \code{GEVMCEstimate},\cr the \code{GEVFamily,kStepEstimate}-method cast to -S4 class \code{GEVkStepstimate},\cr +S4 class \code{GEVkStepEstimate},\cr +the \code{GEVFamily,ORobEstimate}-method cast to +S4 class \code{GEVORobEstimate},\cr +the \code{GEVFamily,MLEstimate}-method cast to +S4 class \code{GEVML.ALEstimate},\cr +the \code{GEVFamily,CvMMDEstimate}-method cast to +S4 class \code{GEVCvMMD.ALEstimate},\cr + the \code{GEVFamilyMuUnknown,Estimate}-method cast to S4 class \code{GEVEstimate},\cr the \code{GEVFamilyMuUnknown,LDEstimate}-method cast to S4 class \code{GEVLDEstimate},\cr the \code{GEVFamilyMuUnknown,MCEstimate}-method cast to -S4 class \code{GEVMCALEstimate},\cr +S4 class \code{GEVMCEstimate},\cr the \code{GEVFamilyMuUnknown,kStepEstimate}-method cast to S4 class \code{GEVkStepstimate}.\cr +the \code{GEVFamilyMuUnknown,ORobEstimate}-method cast to +S4 class \code{GEVORobEstimate},\cr +the \code{GEVFamilyMuUnknown,MLEstimate}-method cast to +S4 class \code{GEVML.ALEstimate},\cr +the \code{GEVFamilyMuUnknown,CvMMDEstimate}-method cast to +S4 class \code{GEVCvMMD.ALEstimate}. } \author{ Peter Ruckdeschel \email{peter.ruckdeschel at uni-oldenburg.de} From noreply at r-forge.r-project.org Thu Aug 16 13:16:09 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 13:16:09 +0200 (CEST) Subject: [Robast-commits] r1149 - in branches/robast-1.2/pkg/RobAStBase: R inst man Message-ID: <20180816111609.6C50F180257@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 13:16:09 +0200 (Thu, 16 Aug 2018) New Revision: 1149 Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd branches/robast-1.2/pkg/RobAStBase/man/getBoundedIC.Rd branches/robast-1.2/pkg/RobAStBase/man/getRiskIC.Rd branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd Log: [RobAStBase] branch 1.2 + getboundedIC, getRiskIC for signature (IC, asCov, missing, L2ParamFamily), checkIC and makeIC gain argument diagnostic to be able to show diagnostic information on integrations Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-16 08:07:00 UTC (rev 1148) +++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-16 11:16:09 UTC (rev 1149) @@ -1,6 +1,6 @@ ## new helper function for make and check IC to speed up things -.preparedirectCheckMakeIC <- function(L2Fam, IC, ...){ +.preparedirectCheckMakeIC <- function(L2Fam, IC, ..., diagnostic = FALSE){ dims <- length(L2Fam at param) trafo <- trafo(L2Fam at param) @@ -14,21 +14,28 @@ IC.v <- as(diag(nrvalues) %*% IC at Curve, "EuclRandVariable") L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable") + diagn <- if(diagnostic) vector("list",(nrvalues+3)*nrvalues/2) else NULL + if(diagnostic) dotsI$diagnostic <- TRUE + k <- 0 + res <- numeric(nrvalues) for(i in 1:nrvalues){ Eargs <- c(list(object = Distr, fun = IC.v at Map[[i]]), dotsI) - res[i] <- do.call(E, Eargs) + res[i] <- buf <- do.call(E, Eargs) + if(diagnostic){ k <- k + 1; diagn[[k]] <- attr(buf,"diagnostic") } } + if(diagnostic) attr(res, "diagnostic") <- diagn[1:nrvalues] - erg <- matrix(0, ncol = dims, nrow = nrvalues) for(i in 1:nrvalues) for(j in 1:dims){ integrandA <- function(x)IC.v at Map[[i]](x)*L2deriv at Map[[j]](x) Eargs <- c(list(object = Distr, fun = integrandA),dotsI) - erg[i, j] <- do.call(E, Eargs) + erg[i, j] <- buf <- do.call(E, Eargs) + if(diagnostic){ k <- k + 1; diagn[[k]] <- attr(buf,"diagnostic") } } + if(diagnostic) attr(erg, "diagnostic") <- diagn[-(1:nrvalues)] return(list(E.IC=res,E.IC.L=erg)) } @@ -37,22 +44,22 @@ ## check centering and Fisher consistency setMethod("checkIC", signature(IC = "IC", L2Fam = "missing"), - function(IC, out = TRUE, ...){ + function(IC, out = TRUE, ..., diagnostic = FALSE){ L2Fam <- eval(IC at CallL2Fam) getMethod("checkIC", signature(IC = "IC", L2Fam = "L2ParamFamily"))( - IC = IC, L2Fam = L2Fam, out = out, ...) + IC = IC, L2Fam = L2Fam, out = out, ..., diagnostic = diagnostic) }) ## check centering and Fisher consistency setMethod("checkIC", signature(IC = "IC", L2Fam = "L2ParamFamily"), - function(IC, L2Fam, out = TRUE, ...){ + function(IC, L2Fam, out = TRUE, ..., diagnostic = FALSE){ D1 <- L2Fam at distribution if(dimension(Domain(IC at Curve[[1]])) != dimension(img(D1))) stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") trafo <- trafo(L2Fam at param) - res <- .preparedirectCheckMakeIC(L2Fam, IC, ...) + res <- .preparedirectCheckMakeIC(L2Fam, IC, ..., diagnostic = diagnostic) cent <- res$E.IC if(out) @@ -71,13 +78,18 @@ prec <- max(abs(cent), abs(consist)) names(prec) <- "maximum deviation" + if(diagnostic && out){ + print(attr(res$E.IC,"diagnostic")) + print(attr(res$E.IC.L,"diagnostic")) + } + return(prec) }) ## make some L2function a pIC at a model setMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"), - function(IC, L2Fam, ...){ + function(IC, L2Fam, ..., diagnostic = FALSE){ dims <- length(L2Fam at param) if(dimension(IC at Curve) != dims) @@ -89,8 +101,13 @@ trafo <- trafo(L2Fam at param) - res <- .preparedirectCheckMakeIC(L2Fam, IC, ...) + res <- .preparedirectCheckMakeIC(L2Fam, IC, ..., diagnostic = diagnostic) + if(diagnostic){ + print(attr(res$E.IC,"diagnostic")) + print(attr(res$E.IC.L,"diagnostic")) + } + IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable") cent <- res$E.IC @@ -119,14 +136,14 @@ ## make some L2function a pIC at a model setMethod("makeIC", signature(IC = "IC", L2Fam = "missing"), - function(IC, ...){ + function(IC, ..., diagnostic = FALSE){ L2Fam <- eval(IC at CallL2Fam) getMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"))( - IC = IC, L2Fam = L2Fam, ...) + IC = IC, L2Fam = L2Fam, ..., diagnostic = diagnostic) }) setMethod("makeIC", signature(IC = "list", L2Fam = "L2ParamFamily"), - function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL,...){ + function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL,..., diagnostic = FALSE){ mc <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)[-1] mc0 <- as.list(mc) mc0$IC <- NULL @@ -142,14 +159,15 @@ mc0$CallL2Fam <- substitute(L2Fam at fam.call) IC.0 <- do.call(.IC,mc0) - if(forceIC) IC.0 <- makeIC(IC.0, L2Fam,...) + if(forceIC) IC.0 <- makeIC(IC.0, L2Fam,..., diagnostic = diagnostic) return(IC.0) }) setMethod("makeIC", signature(IC = "function", L2Fam = "L2ParamFamily"), - function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL,...){ + function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, + modifyIC = NULL,..., diagnostic = FALSE){ mc <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)[-1] mc0 <- as.list(mc) mc0$IC <- NULL Modified: branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-16 08:07:00 UTC (rev 1148) +++ branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-16 11:16:09 UTC (rev 1149) @@ -26,12 +26,14 @@ risk = "asCov", neighbor = "missing", L2Fam = "L2ParamFamily"), - function(IC, risk, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){ + function(IC, risk, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE, ..., + diagnostic = FALSE){ if(dimension(Domain(IC at Curve[[1]])) != dimension(img(L2Fam at distribution))) stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") dotsI <- .filterEargsWEargList(list(...)) if(!is.null(dotsI$useApply)) dotsI$useApply <- FALSE + dotsI$diagnostic <- diagnostic if(missing(withCheck)) withCheck <- TRUE IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable") @@ -46,16 +48,23 @@ Cova <- matrix(0, ncol = nrvalues, nrow = nrvalues) + diagn <- if(diagnostic) vector("list",nrvalues*(nrvalues+1)/2) else NULL + k <- 0 for(i in 1:nrvalues){ for(j in i:nrvalues){ - Cova[i,j] <- do.call(E,c(list(object = Distr, + Cova[i,j] <- buf <- do.call(E,c(list(object = Distr, fun = function(x){ return((IC1 at Map[[i]](x)-cent[i])*(IC1 at Map[[j]](x)-cent[j]))}), dotsI)) + if(diagnostic){ + k <- k + 1 + diagn[[k]] <- attr(buf, "diagnostic") + } } } Cova[col(Cova) < row(Cova)] <- t(Cova)[col(Cova) < row(Cova)] # if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...) + if(diagnostic) attr(Cova,"diagnostic") <- diagn return(list(asCov = list(distribution = .getDistr(L2Fam), value = Cova))) }) Modified: branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-16 08:07:00 UTC (rev 1148) +++ branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-16 11:16:09 UTC (rev 1149) @@ -1,4 +1,4 @@ -getBoundedIC <- function(L2Fam, D=trafo(L2Fam at param),...){ +getBoundedIC <- function(L2Fam, D=trafo(L2Fam at param),..., diagnostic = FALSE){ dotsI <- .filterEargsWEargList(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE @@ -33,21 +33,35 @@ cent <- numeric(dims) stand.0 <- matrix(0,dims,dims) + diagn <- if(diagnostic) vector("list", dims*(dims+3)/2) else NULL + k <- 0 + if(diagnostic) dotsI$diagnostic <- TRUE + for(i in 1:dims){ fun <- function(x) {Lx <- L.fct(x); wx <- weight(w)(Lx); return(Lx[i,]*wx)} Eargs <- c(list(object=D1, fun=fun), dotsI) - cent[i] <- do.call(E,Eargs) + cent[i] <- buf <- do.call(E,Eargs) + if(diagnostic){ + k <- k + 1 + diagn[[k]] <- attr(buf,"diagnostic") + } } for(i in 1:dims) for(j in i:dims){ fun <- function(x) {Lx <- L.fct(x); wx <- weight(w)(Lx) return((Lx[i,]-cent[i])*(Lx[j,]-cent[j])*wx)} Eargs <- c(list(object=D1, fun=fun), dotsI) - stand.0[i,j] <- do.call(E,Eargs) + stand.0[i,j] <- buf <- do.call(E,Eargs) + if(diagnostic){ + k <- k + 1 + diagn[[k]] <- attr(buf,"diagnostic") + } } stand.0[row(stand.0)>col(stand.0)] <- t(stand.0)[row(stand.0)>col(stand.0)] stand <- as.matrix(D %*% distr::solve(stand.0, generalized = TRUE)) L2w0 <- L2w - cent - return(as(stand %*% L2w0, "EuclRandVariable")) + res <- as(stand %*% L2w0, "EuclRandVariable") + if(diagnostic) attr(res,"diagnostic") <- diagn + return(res) } Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-16 08:07:00 UTC (rev 1148) +++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-16 11:16:09 UTC (rev 1149) @@ -93,6 +93,9 @@ overwrites existing entries). + getboundedIC now uses coordinate-wise integration with useApply = FALSE and only computing the upper half of E LL'w ++ getboundedIC, getRiskIC for signature (IC, asCov, missing, L2ParamFamily), + checkIC and makeIC gain argument diagnostic to be able to show diagnostic + information on integrations ####################################### version 1.1 Modified: branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd 2018-08-16 08:07:00 UTC (rev 1148) +++ branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd 2018-08-16 11:16:09 UTC (rev 1149) @@ -10,14 +10,16 @@ } \usage{ checkIC(IC, L2Fam, ...) -\S4method{checkIC}{IC,missing}(IC, out = TRUE, ...) -\S4method{checkIC}{IC,L2ParamFamily}(IC, L2Fam, out = TRUE,...) +\S4method{checkIC}{IC,missing}(IC, out = TRUE, ..., diagnostic = FALSE) +\S4method{checkIC}{IC,L2ParamFamily}(IC, L2Fam, out = TRUE,..., diagnostic = FALSE) } \arguments{ \item{IC}{ object of class \code{"IC"} } \item{L2Fam}{ L2-differentiable family of probability measures. } \item{out}{ logical: Should the values of the checks be printed out?} \item{\dots}{ additional parameters } + \item{diagnostic}{ logical; if \code{TRUE} and \code{out==TRUE}, + diagnostic information on the integration is printed. } } \details{ The precisions of the centering and the Fisher consistency Modified: branches/robast-1.2/pkg/RobAStBase/man/getBoundedIC.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/getBoundedIC.Rd 2018-08-16 08:07:00 UTC (rev 1148) +++ branches/robast-1.2/pkg/RobAStBase/man/getBoundedIC.Rd 2018-08-16 11:16:09 UTC (rev 1149) @@ -6,12 +6,15 @@ Generates a bounded influence curve. } \usage{ -getBoundedIC(L2Fam, D=trafo(L2Fam at param), ...) +getBoundedIC(L2Fam, D=trafo(L2Fam at param), ..., diagnostic = FALSE) } \arguments{ \item{L2Fam}{object of class \code{"L2ParamFamily"}} \item{D}{matrix with as many columns as \code{length(L2Fam at param)}} \item{...}{further arguments to be passed to \code{E}} + \item{diagnostic}{ logical; if \code{TRUE}, the return value obtains + an attribute \code{"diagnostic"} with diagnostic information on the + integration. } } %\details{} \value{(a bounded) pIC (to matrix \code{D}) given as object of class Modified: branches/robast-1.2/pkg/RobAStBase/man/getRiskIC.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/getRiskIC.Rd 2018-08-16 08:07:00 UTC (rev 1148) +++ branches/robast-1.2/pkg/RobAStBase/man/getRiskIC.Rd 2018-08-16 11:16:09 UTC (rev 1149) @@ -24,7 +24,7 @@ tol = .Machine$double.eps^0.25, withCheck = TRUE, ...) \S4method{getRiskIC}{IC,asCov,missing,L2ParamFamily}(IC, risk, L2Fam, - tol = .Machine$double.eps^0.25, withCheck = TRUE, ...) + tol = .Machine$double.eps^0.25, withCheck = TRUE, ..., diagnostic = FALSE) \S4method{getRiskIC}{IC,trAsCov,missing,missing}(IC, risk, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...) @@ -62,6 +62,9 @@ \item{cont}{ "left" or "right". } \item{withCheck}{logical: should a call to \code{checkIC} be done to check accuracy (defaults to \code{TRUE}).} + \item{diagnostic}{ logical; if \code{TRUE}, the return value obtains + an attribute \code{"diagnostic"} with diagnostic information on the + integration. } } \details{To make sure that the results are valid, it is recommended to include an additional check of the IC properties of \code{IC} Modified: branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd 2018-08-16 08:07:00 UTC (rev 1148) +++ branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd 2018-08-16 11:16:09 UTC (rev 1149) @@ -14,11 +14,11 @@ \usage{ makeIC(IC, L2Fam, ...) %\S4method{makeIC}{IC,missing}(IC, ...) -\S4method{makeIC}{IC,L2ParamFamily}(IC, L2Fam, ...) +\S4method{makeIC}{IC,L2ParamFamily}(IC, L2Fam, ..., diagnostic = FALSE) \S4method{makeIC}{list,L2ParamFamily}(IC, L2Fam, forceIC = TRUE, name, Risks, - Infos, modifyIC = NULL, ...) + Infos, modifyIC = NULL, ..., diagnostic = FALSE) \S4method{makeIC}{function,L2ParamFamily}(IC, L2Fam, forceIC = TRUE, name, - Risks, Infos, modifyIC = NULL, ...) + Risks, Infos, modifyIC = NULL, ..., diagnostic = FALSE) } \arguments{ \item{IC}{ object of class \code{"IC"} for signature \code{IC="IC"}, respectively @@ -43,6 +43,8 @@ class \code{"IC"}. This function is mainly used for internal computations! } \item{\dots}{ additional parameters to be passed to expectation \code{E} } + \item{diagnostic}{ logical; if \code{TRUE}, + diagnostic information on the integration is printed. } } \value{An IC of class \code{"IC"} at the model.} \section{Methods}{\describe{ From noreply at r-forge.r-project.org Thu Aug 16 13:21:12 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 13:21:12 +0200 (CEST) Subject: [Robast-commits] r1150 - in branches/robast-1.2/pkg/ROptEst: R inst man Message-ID: <20180816112112.8E260187227@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 13:21:12 +0200 (Thu, 16 Aug 2018) New Revision: 1150 Modified: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R branches/robast-1.2/pkg/ROptEst/inst/NEWS branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd Log: [ROptEst] branch 1.2: + the particular checkIC and makeIC methods gain argument diagnostic to be able to show diagnostic information on integrations Modified: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R 2018-08-16 11:16:09 UTC (rev 1149) +++ branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R 2018-08-16 11:21:12 UTC (rev 1150) @@ -2,13 +2,13 @@ ## faster check for ContICs setMethod("checkIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"), - function(IC, L2Fam, out = TRUE, forceContICMethod = FALSE, ...){ + function(IC, L2Fam, out = TRUE, forceContICMethod = FALSE, ..., diagnostic = FALSE){ D1 <- L2Fam at distribution if( dimension(Domain(IC at Curve[[1]])) != dimension(img(D1))) stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'") - res <- .prepareCheckMakeIC(L2Fam, w = IC at weight, forceContICMethod, ...) + res <- .prepareCheckMakeIC(L2Fam, w = IC at weight, forceContICMethod, ..., diagnostic = diagnostic) ## if it pays off to use symmetry/ to compute integrals in L2deriv space ## we compute the following integrals: ## G1 = E w, G2 = E Lambda w, G3 = E Lambda Lambda' w @@ -20,7 +20,7 @@ if(is.null(res)) return(getMethod("checkIC", signature(IC = "IC", - L2Fam = "L2ParamFamily"))(IC,L2Fam, out = out, ...)) + L2Fam = "L2ParamFamily"))(IC,L2Fam, out = out, ..., diagnostic = diagnostic)) A <- stand(IC); a <- cent(IC) @@ -37,6 +37,12 @@ print(Delta2) cat("precision of Fisher consistency - relative error [%]:\n") print(100*Delta2/trafo) + + if(diagnostic){ + print(attr(res$G1, "diagnostic")) + print(attr(res$G2, "diagnostic")) + print(attr(res$G3, "diagnostic")) + } } prec <- max(abs(Delta1), abs(Delta2)) @@ -47,7 +53,7 @@ ## make some L2function a pIC at a model setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"), - function(IC, L2Fam, forceContICMethod = FALSE, ...){ + function(IC, L2Fam, forceContICMethod = FALSE, ..., diagnostic = FALSE){ D1 <- L2Fam at distribution if( dimension(Domain(IC at Curve[[1]])) != dimension(img(D1))) @@ -57,8 +63,14 @@ if(dimension(IC at Curve) != dims) stop("Dimension of IC and parameter must be equal") - res <- .prepareCheckMakeIC(L2Fam, w = IC at weight, forceContICMethod, ...) + res <- .prepareCheckMakeIC(L2Fam, w = IC at weight, forceContICMethod, ..., diagnostic = diagnostic) + if(diagnostic &&!is.null(res)){ + print(attr(res$G1, "diagnostic")) + print(attr(res$G2, "diagnostic")) + print(attr(res$G3, "diagnostic")) + } + ## if it pays off to use symmetry/ to compute integrals in L2deriv space ## we compute the following integrals: ## G1 = E w, G2 = E Lambda w, G3 = E Lambda Lambda' w @@ -70,7 +82,7 @@ if(is.null(res)) return(getMethod("makeIC", signature(IC = "IC", - L2Fam = "L2ParamFamily"))(IC,L2Fam,...)) + L2Fam = "L2ParamFamily"))(IC,L2Fam,..., diagnostic = diagnostic)) G1 <- res$G1; G2 <- res$G2; G3 <- res$G3 trafO <- trafo(L2Fam at param) @@ -116,7 +128,7 @@ return(cIC1) }) -.prepareCheckMakeIC <- function(L2Fam, w, forceContICMethod, ...){ +.prepareCheckMakeIC <- function(L2Fam, w, forceContICMethod, ..., diagnostic = FALSE){ dims <- length(L2Fam at param) trafo <- trafo(L2Fam at param) @@ -145,15 +157,16 @@ res <- .getG1G2G3Stand(L2deriv = L2deriv, Distr = L2Fam at distribution, - A.comp = A.comp, z.comp = z.comp, w = w, ...) + A.comp = A.comp, z.comp = z.comp, w = w, ..., + diagnostic = diagnostic) return(res) } -.getG1G2G3Stand <- function(L2deriv, Distr, A.comp, z.comp, w, ...){ +.getG1G2G3Stand <- function(L2deriv, Distr, A.comp, z.comp, w, ..., diagnostic = FALSE){ - dotsI <- .filterEargsWEargList(list(...)) + dotsI <- .filterEargs(list(...)) if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE w.fct <- function(x){ @@ -165,21 +178,25 @@ return(L2.i(x)*w.fct(x)) } + diagn <- if(diagnostic) vector("list", sum(z.comp)+sum(A.comp)) + if(diagnostic) dotsI$diagnostic <- TRUE Eargs <- c(list(object = Distr, fun = w.fct), dotsI) res1 <- do.call(E,Eargs) + k <- 0 nrvalues <- length(L2deriv) res2 <- numeric(nrvalues) for(i in 1:nrvalues){ if(z.comp[i]){ Eargs <- c(list(object = Distr, fun = integrand2, L2.i = L2deriv at Map[[i]]), dotsI) - res2[i] <- do.call(E,Eargs) + res2[i] <- buf <- do.call(E,Eargs) + if(diagnostic){k <- k + 1; diagn[[k]] <- attr(buf,"diagnostic")} }else{ res2[i] <- 0 } } - + if(diagnostic) {k1 <- k; attr(res2, "diagnostic") <- diagn[(1:k1)]} cent <- res2/res1 integrandA <- function(x, L2.i, L2.j, i, j){ @@ -195,11 +212,13 @@ Eargs <- c(list(object = Distr, fun = integrandA, L2.i = L2deriv at Map[[i]], L2.j = L2deriv at Map[[j]], i = i, j = j), dotsI) - erg[i, j] <- do.call(E,Eargs) + erg[i, j] <- buf <- do.call(E,Eargs) + if(diagnostic){k <- k + 1; diagn[[k]] <- attr(buf,"diagnostic")} } } } erg[col(erg) < row(erg)] <- t(erg)[col(erg) < row(erg)] + if(diagnostic) {k1 <- k; attr(erg, "diagnostic") <- diagn[-(1:k1)]} return(list(G1=res1,G2=res2, G3=erg)) } Modified: branches/robast-1.2/pkg/ROptEst/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-16 11:16:09 UTC (rev 1149) +++ branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-16 11:21:12 UTC (rev 1150) @@ -52,7 +52,7 @@ + clarified if clauses in roptest.new (and removed .with.checkEstClassForParamFamily from dots to be sure) + inserted code for time checking (which is inactive usually; only if in kStepEstimator.R in RobAStBase, the respective ##-t-## lines are de-commented the timings are visible as - attribute "kStepTimings" in the result of roptest ...) + attribute "kStepTimings" in the result of roptest ...) changed now: is always active.... + now specified that we want to use distr::solve + internal function .getComp, determining by symmetry slots which entries in LMs a and A have to be computed, now fills the lower triangle of A with FALSE (was not used so far, @@ -75,6 +75,8 @@ does checking / the affine transformation to give the proper pIC. These methods by default are only used if it pays off, i.e., if the number of computed integrals is smaller than in the default method. This can be overriden by argument forceContICMethod. ++ the particular checkIC and makeIC methods gain argument diagnostic to be able to + show diagnostic information on integrations ####################################### version 1.1 Modified: branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd 2018-08-16 11:16:09 UTC (rev 1149) +++ branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd 2018-08-16 11:21:12 UTC (rev 1150) @@ -12,9 +12,9 @@ } \usage{ \S4method{checkIC}{ContIC,L2ParamFamily}(IC, L2Fam, out = TRUE, - forceContICMethod = FALSE, ...) + forceContICMethod = FALSE, ..., diagnostic = FALSE) \S4method{makeIC}{ContIC,L2ParamFamily}(IC, L2Fam, - forceContICMethod = FALSE, ...) + forceContICMethod = FALSE, ..., diagnostic = FALSE) } \arguments{ \item{IC}{ object of class \code{"IC"} } @@ -39,6 +39,9 @@ slot \code{param} of \code{L2Fam}.} \item{\dots}{ additional parameters to be passed on to expectation \code{E}. } + \item{diagnostic}{ logical; if \code{TRUE} (and in case \code{checkIC} if + argument \code{out==TRUE}), diagnostic information on the integration + is printed. } } \details{ In \code{checkIC}, the precisions of the centering and the Fisher consistency From noreply at r-forge.r-project.org Thu Aug 16 13:31:20 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 13:31:20 +0200 (CEST) Subject: [Robast-commits] r1151 - in branches/robast-1.2/pkg/RobExtremes: . R inst man Message-ID: <20180816113120.7D4A418A390@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 13:31:20 +0200 (Thu, 16 Aug 2018) New Revision: 1151 Modified: branches/robast-1.2/pkg/RobExtremes/NAMESPACE branches/robast-1.2/pkg/RobExtremes/R/GEV.R branches/robast-1.2/pkg/RobExtremes/R/GPareto.R branches/robast-1.2/pkg/RobExtremes/R/Gumbel.R branches/robast-1.2/pkg/RobExtremes/R/Pareto.R branches/robast-1.2/pkg/RobExtremes/inst/NEWS branches/robast-1.2/pkg/RobExtremes/man/GEV-class.Rd branches/robast-1.2/pkg/RobExtremes/man/GPareto-class.Rd branches/robast-1.2/pkg/RobExtremes/man/Gumbel-class.Rd branches/robast-1.2/pkg/RobExtremes/man/Pareto-class.Rd Log: [RobExtremes] branch 1.2 + introduced particular liesInSupport methods for Gumbel, Pareto, GPareto, and GEV + updated NEWS Modified: branches/robast-1.2/pkg/RobExtremes/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/RobExtremes/NAMESPACE 2018-08-16 11:21:12 UTC (rev 1150) +++ branches/robast-1.2/pkg/RobExtremes/NAMESPACE 2018-08-16 11:31:20 UTC (rev 1151) @@ -51,7 +51,7 @@ exportMethods("modifyModel", "getStartIC", "coerce") exportMethods("moveL2Fam2RefParam", "moveICBackFromRefParam") -exportMethods("checkIC", "makeIC") +exportMethods("checkIC", "makeIC", "liesInSupport") export("EULERMASCHERONICONSTANT","APERYCONSTANT") export("getCVaR", "getVaR", "getEL") export("Gumbel", "Pareto", "GPareto", "GEV") Modified: branches/robast-1.2/pkg/RobExtremes/R/GEV.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/GEV.R 2018-08-16 11:21:12 UTC (rev 1150) +++ branches/robast-1.2/pkg/RobExtremes/R/GEV.R 2018-08-16 11:31:20 UTC (rev 1151) @@ -33,7 +33,6 @@ scale(x at param)) setMethod("shape", "GEV", function(object) shape(object at param)) - ## wrapped replace methods setMethod("loc<-", "GEV", function(object, value) new("GEV", loc = value, scale = scale(object), shape = shape(object))) @@ -58,6 +57,14 @@ else return(TRUE) }) +setMethod("liesInSupport", signature(object = "GEV", + x = "numeric"), + function(object, x, checkFin = TRUE){ + loc=loc(object); scale=scale(object); shape=shape(object) + if(shape>0) return(is.finite(x)&(x>= loc-scale/shape)) + if(shape<0) return(is.finite(x)&(x<= loc-scale/shape)) + if(abs(shape)<1e-8) return(is.finite(x))}) + ## generating function GEV <- function(loc = 0, scale = 1, shape = 0, location = loc){ if(!missing(loc)&&!missing(location)) Modified: branches/robast-1.2/pkg/RobExtremes/R/GPareto.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/GPareto.R 2018-08-16 11:21:12 UTC (rev 1150) +++ branches/robast-1.2/pkg/RobExtremes/R/GPareto.R 2018-08-16 11:31:20 UTC (rev 1151) @@ -58,6 +58,13 @@ else return(TRUE) }) +setMethod("liesInSupport", signature(object = "GPareto", + x = "numeric"), + function(object, x, checkFin = TRUE){ + loc=loc(object); scale=scale(object); shape=shape(object) + if(shape>=0) return(is.finite(x)&(x>= loc)) + if(shape<0) return(is.finite(x)&(x<= loc-scale/shape)&(x>=loc))}) + ## generating function GPareto <- function(loc = 0, scale = 1, shape = 0, location = loc){ if(!missing(loc)&&!missing(location)) Modified: branches/robast-1.2/pkg/RobExtremes/R/Gumbel.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/Gumbel.R 2018-08-16 11:21:12 UTC (rev 1150) +++ branches/robast-1.2/pkg/RobExtremes/R/Gumbel.R 2018-08-16 11:31:20 UTC (rev 1151) @@ -9,6 +9,9 @@ setReplaceMethod("scale", "GumbelParameter", function(object, value){ object at scale <- value; object}) +setMethod("liesInSupport", signature(object = "Gumbel", + x = "numeric"), + function(object, x, checkFin = TRUE){is.finite(x)}) ## generating function Gumbel <- function(loc = 0, scale = 1){ new("Gumbel", loc = loc, scale = scale) } Modified: branches/robast-1.2/pkg/RobExtremes/R/Pareto.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/Pareto.R 2018-08-16 11:21:12 UTC (rev 1150) +++ branches/robast-1.2/pkg/RobExtremes/R/Pareto.R 2018-08-16 11:31:20 UTC (rev 1151) @@ -36,6 +36,10 @@ else return(TRUE) }) +setMethod("liesInSupport", signature(object = "Pareto", + x = "numeric"), + function(object, x, checkFin = TRUE){is.finite(x)&(x>=0)}) + ################################ ## .Object at img <- new("Naturals") Modified: branches/robast-1.2/pkg/RobExtremes/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobExtremes/inst/NEWS 2018-08-16 11:21:12 UTC (rev 1150) +++ branches/robast-1.2/pkg/RobExtremes/inst/NEWS 2018-08-16 11:31:20 UTC (rev 1151) @@ -27,6 +27,14 @@ + the timings are now about ~ 2s per estimator for GEV and GPD and check/makeIC are much faster + script updated + the makeIC methods for GPD/GEV... also gain an "..." argument ++ fixed minor issues in scripts/RobFitsAtRealData.R ++ expectation E() of Pareto, GPD, and GEV gain argument diagnostic and use dot-filtering (like in distrEx) ++ minor bugfixes in .getBetaXiGEW ++ new S4 classes + "GPDML.ALEstimate", "GPDCvMMD.ALEstimate", and "GEVML.ALEstimate", "GEVCvMMD.ALEstimate" + deleted classes "GPDMCALEstimate", "GEVMCALEstimate" as not every MCE is an ALE -> this gave misleading error messages ++ warning/caveat in the help to GEVFamily/GEVFamilyMuUnknown as to the accuracy of PickandsEstimator for GEV ++ introduced particular liesInSupport methods for Gumbel, Pareto, GPareto, and GEV ####################################### version 1.1 Modified: branches/robast-1.2/pkg/RobExtremes/man/GEV-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/GEV-class.Rd 2018-08-16 11:21:12 UTC (rev 1150) +++ branches/robast-1.2/pkg/RobExtremes/man/GEV-class.Rd 2018-08-16 11:31:20 UTC (rev 1151) @@ -12,8 +12,8 @@ \alias{shape<-,GEV-method} \alias{+,GEV,numeric-method} \alias{*,GEV,numeric-method} +\alias{liesInSupport,GEV,numeric-method} - \title{Generalized EV distribution} \description{[borrowed from \pkg{evd}]: The GEV distribution function with parameters \code{loc}\eqn{= a}, @@ -95,6 +95,8 @@ \item{kurtosis}{\code{signature(signature(x = "GEV")}: exact evaluation using explicit expressions.} + \item{liesInSupport}{\code{signature(object = "GEV", x = "numeric")}: + checks if \code{x} lies in the support of the respective distribution. } } } Modified: branches/robast-1.2/pkg/RobExtremes/man/GPareto-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/GPareto-class.Rd 2018-08-16 11:21:12 UTC (rev 1150) +++ branches/robast-1.2/pkg/RobExtremes/man/GPareto-class.Rd 2018-08-16 11:31:20 UTC (rev 1151) @@ -12,6 +12,7 @@ \alias{shape<-,GPareto-method} \alias{+,GPareto,numeric-method} \alias{*,GPareto,numeric-method} +\alias{liesInSupport,GPareto,numeric-method} \title{Generalized Pareto distribution} @@ -92,6 +93,8 @@ \item{kurtosis}{\code{signature(signature(x = "GPareto")}: exact evaluation using explicit expressions.} + \item{liesInSupport}{\code{signature(object = "GPareto", x = "numeric")}: + checks if \code{x} lies in the support of the respective distribution. } } } Modified: branches/robast-1.2/pkg/RobExtremes/man/Gumbel-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/Gumbel-class.Rd 2018-08-16 11:21:12 UTC (rev 1150) +++ branches/robast-1.2/pkg/RobExtremes/man/Gumbel-class.Rd 2018-08-16 11:31:20 UTC (rev 1151) @@ -8,6 +8,7 @@ \alias{scale<-,Gumbel-method} \alias{+,Gumbel,numeric-method} \alias{*,Gumbel,numeric-method} +\alias{liesInSupport,Gumbel,numeric-method} \title{Gumbel distribution} \description{The Gumbel cumulative distribution function with @@ -91,6 +92,10 @@ \item{IQR}{\code{signature(x = "Gumbel")}: exact evaluation of expectation using explicit expressions.} + + \item{liesInSupport}{\code{signature(object = "Gumbel", x = "numeric")}: + checks if \code{x} lies in the support of the respective distribution. } + } } \references{Johnson et al. (1995) \emph{Continuous Univariate Distributions. Vol. 2. 2nd ed.} Modified: branches/robast-1.2/pkg/RobExtremes/man/Pareto-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/Pareto-class.Rd 2018-08-16 11:21:12 UTC (rev 1150) +++ branches/robast-1.2/pkg/RobExtremes/man/Pareto-class.Rd 2018-08-16 11:31:20 UTC (rev 1151) @@ -8,6 +8,7 @@ \alias{Min<-,Pareto-method} \alias{scale,Pareto-method} \alias{*,Pareto,numeric-method} +\alias{liesInSupport,Pareto,numeric-method} \title{Pareto distribution} \description{[borrowed from \pkg{actuar}]: @@ -85,6 +86,8 @@ \item{*}{\code{signature(e1 = "Pareto", e2 = "numeric")}: exact method for this transformation --- stays within this class if \code{e2>0}. } + \item{liesInSupport}{\code{signature(object = "Pareto", x = "numeric")}: + checks if \code{x} lies in the support of the respective distribution. } } } \references{Johnson et al. (1995) \emph{Continuous Univariate Distributions. Vol. 2. 2nd ed.} From noreply at r-forge.r-project.org Thu Aug 16 14:07:23 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 14:07:23 +0200 (CEST) Subject: [Robast-commits] r1152 - branches/robast-1.2/pkg/RobExtremes/inst/scripts Message-ID: <20180816120723.63F7E187EB8@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 14:07:23 +0200 (Thu, 16 Aug 2018) New Revision: 1152 Modified: branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R Log: [RobExtremes] branch 2.8 a minor add in RobFitsAtRealData.R Modified: branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-16 11:31:20 UTC (rev 1151) +++ branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-16 12:07:23 UTC (rev 1152) @@ -61,6 +61,8 @@ system.time(RMXiw2 <- RMXEstimator(portpiriei, GEVFam,withMakeIC=TRUE)) checkIC(pIC(RMXiw2)) setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"),oldM) +getMethod("checkIC", signature(IC = "IC", L2Fam = "missing"))(pIC(RMXiw2), + out=TRUE, diagnostic=TRUE) estimate(RMXi) estimate(RMXiw) @@ -174,13 +176,9 @@ gev.profxi(mlEc, -0.3, 0.3) ## diagnostics from pkg 'distrMod'/'RobAStBase' -devNew() qqplot(portpiriec,MBRc) -devNew() qqplot(portpiriec,MBRc,ylim=c(3.5,5)) -devNew() returnlevelplot(portpiriec,MBRc) -devNew() returnlevelplot(portpiriec,MBRc,ylim=c(3.5,5)) ## here the MBR-IC looks as follows @@ -247,48 +245,33 @@ devNew() plot(pIC(MBR2c)) -devNew() qqplot(rainc,MBR2c) -devNew() qqplot(rainc,MBR2c,ylim=c(5,100)) -devNew() qqplot(rainc,MBR2c,xlim=c(5,100),ylim=c(5,100),log="xy") -devNew() qqplot(rainc,MBR2c,xlim=c(5,100),ylim=c(5,100),log="xy", cex.pts=2,col.pts="blue",with.lab=TRUE,cex.lbs=.9,which.Order=1:3) -devNew() returnlevelplot(raini,MBR2i,MaxOrPot="POT",threshold=0) -devNew() returnlevelplot(raini,MBR2i,MaxOrPot="POT",threshold=0, withLab=TRUE, cex.lbl=0.8) -devNew() returnlevelplot(rainc,MBR2c,MaxOrPot="POT",threshold=0) -devNew() returnlevelplot(rainc,MBR2c,ylim=c(10,100),MaxOrPot="POT",threshold=0) # L2F <- eval(MBR2c at pIC@CallL2Fam) dI2c <- L2F at distribution -devNew() qqplot(rainc,dI2c) rainc.10 <- rainc-10 -devNew() qqplot(rainc.10,dI2c-10) -devNew() returnlevelplot(rainc.10,dI2c-10,MaxOrPot="POT",threshold=0) ## wrong data set dI2i <- distribution(eval(MBR2i at pIC@CallL2Fam)) loc(dI2i) <- 0 -devNew() qqplot(portpiriei-10,dI2i) -devNew() qqplot(portpiriec,MBR2c) ### all points are red ## right data set -devNew() qqplot(raini-10,dI2i) -devNew() qqplot(rainc,MBR2c) @@ -301,11 +284,8 @@ PM <- ParetoFamily(Min=2) mlE3i <- MLEstimator(x,PM) mlE3c <- MLEstimator(xc,PM) -devNew() qqplot(x, mlE3i, log="xy") -devNew() qqplot(xc, mlE3c, log="xy") -devNew() returnlevelplot(x, mlE3i, MaxOrPOT="POT",ylim=c(1,1e5),log="y") system.time(MBR3i <- MBREstimator(x, PM)) @@ -349,9 +329,7 @@ plot(pIC(MBR4i)) devNew() plot(pIC(RMX4i)) -devNew() qqplot(grbsi, RMX4i) -devNew() qqplot(grbsc, RMX4c, log="xy") ####################################################### @@ -381,7 +359,5 @@ plot(pIC(RMX5i)) devNew() plot(pIC(MBR5i)) -devNew() qqplot(grbsi, RMX5i) -devNew() qqplot(grbsc, RMX5c, log="xy") From noreply at r-forge.r-project.org Thu Aug 16 15:20:25 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 15:20:25 +0200 (CEST) Subject: [Robast-commits] r1153 - branches/robast-1.2/pkg/RobExtremes/R Message-ID: <20180816132025.C2DB1183A29@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 15:20:25 +0200 (Thu, 16 Aug 2018) New Revision: 1153 Modified: branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R Log: [RobExtremes] branch 1.2 + Bernhard discovered a bug in ".checkEstClassForParamFamily" for GEV (was GPD instead of GEV) + there were no classes [GPD/GEV]MDEstimate -> fixed now Modified: branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-08-16 12:07:23 UTC (rev 1152) +++ branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-08-16 13:20:25 UTC (rev 1153) @@ -6,13 +6,6 @@ return(to) } -setClass("GPDEstimate", contains="Estimate") -setClass("GPDLDEstimate", contains=c("LDEstimate", "GPDEstimate")) -setClass("GPDkStepEstimate", contains=c("kStepEstimate", "GPDEstimate")) -setClass("GPDORobEstimate", contains=c("ORobEstimate", "GPDkStepEstimate")) -setClass("GPDMCEstimate", contains=c("MCEstimate", "GPDEstimate")) -setClass("GPDML.ALEstimate", contains=c("ML.ALEstimate", "GPDEstimate")) -setClass("GPDCvMMD.ALEstimate", contains=c("CvMMD.ALEstimate", "GPDEstimate")) setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GParetoFamily",estimator="Estimate"), @@ -57,7 +50,7 @@ function(PFam,estimator) .castToALE(PFam, estimator, "GEVML.ALEstimate")) setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamily",estimator="CvMMDEstimate"), - function(PFam,estimator) .castToALE(PFam, estimator, "GPDCvMMD.ALEstimate")) + function(PFam,estimator) .castToALE(PFam, estimator, "GEVCvMMD.ALEstimate")) setMethod(".checkEstClassForParamFamily", @@ -80,4 +73,4 @@ function(PFam,estimator) .castToALE(PFam, estimator, "GEVML.ALEstimate")) setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamilyMuUnknown",estimator="CvMMDEstimate"), - function(PFam,estimator) .castToALE(PFam, estimator, "GPDCvMMD.ALEstimate") ) + function(PFam,estimator) .castToALE(PFam, estimator, "GEVCvMMD.ALEstimate") ) From noreply at r-forge.r-project.org Thu Aug 16 17:27:55 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 17:27:55 +0200 (CEST) Subject: [Robast-commits] r1154 - in branches/robast-1.2/pkg/RobExtremes: R inst man Message-ID: <20180816152755.1C28D18A572@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 17:27:54 +0200 (Thu, 16 Aug 2018) New Revision: 1154 Modified: branches/robast-1.2/pkg/RobExtremes/R/AllClass.R branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R branches/robast-1.2/pkg/RobExtremes/inst/NEWS branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd Log: [RobExtremes] branch 1.2 some things seem to have been missed at the last commit Modified: branches/robast-1.2/pkg/RobExtremes/R/AllClass.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/AllClass.R 2018-08-16 13:20:25 UTC (rev 1153) +++ branches/robast-1.2/pkg/RobExtremes/R/AllClass.R 2018-08-16 15:27:54 UTC (rev 1154) @@ -292,6 +292,7 @@ setClass("GPDLDEstimate", contains=c("LDEstimate", "GPDEstimate")) setClass("GPDkStepEstimate", contains=c("kStepEstimate", "GPDEstimate")) setClass("GPDORobEstimate", contains=c("ORobEstimate", "GPDkStepEstimate")) +setClass("GPDMDEstimate", contains=c("MDEstimate", "GPDEstimate")) setClass("GEVEstimate", contains="Estimate") setClass("GEVLDEstimate", contains=c("LDEstimate", "GEVEstimate")) @@ -300,4 +301,5 @@ setClass("GEVMCEstimate", contains=c("MCEstimate", "GEVEstimate")) setClass("GEVML.ALEstimate", contains=c("ML.ALEstimate", "GEVEstimate")) setClass("GEVCvMMD.ALEstimate", contains=c("CvMMD.ALEstimate", "GEVEstimate")) +setClass("GEVMDEstimate", contains=c("MDEstimate", "GEVEstimate")) Modified: branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-08-16 13:20:25 UTC (rev 1153) +++ branches/robast-1.2/pkg/RobExtremes/R/checkEstClassForParamFamiliyMethods.R 2018-08-16 15:27:54 UTC (rev 1154) @@ -23,6 +23,9 @@ signature=signature(PFam="GParetoFamily",estimator="MCEstimate"), function(PFam, estimator) as(estimator,"GPDMCEstimate")) setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GParetoFamily",estimator="MDEstimate"), + function(PFam, estimator) as(estimator,"GPDMDEstimate")) +setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GParetoFamily",estimator="MLEstimate"), function(PFam,estimator) .castToALE(PFam, estimator, "GPDML.ALEstimate")) setMethod(".checkEstClassForParamFamily", @@ -46,6 +49,9 @@ signature=signature(PFam="GEVFamily",estimator="MCEstimate"), function(PFam, estimator) as(estimator,"GEVMCEstimate")) setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamily",estimator="MDEstimate"), + function(PFam, estimator) as(estimator,"GEVMDEstimate")) +setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamily",estimator="MLEstimate"), function(PFam,estimator) .castToALE(PFam, estimator, "GEVML.ALEstimate")) setMethod(".checkEstClassForParamFamily", @@ -69,6 +75,9 @@ signature=signature(PFam="GEVFamilyMuUnknown",estimator="MCEstimate"), function(PFam, estimator) as(estimator,"GEVMCEstimate")) setMethod(".checkEstClassForParamFamily", + signature=signature(PFam="GEVFamilyMuUnknown",estimator="MDEstimate"), + function(PFam, estimator) as(estimator,"GEVMDEstimate")) +setMethod(".checkEstClassForParamFamily", signature=signature(PFam="GEVFamilyMuUnknown",estimator="MLEstimate"), function(PFam,estimator) .castToALE(PFam, estimator, "GEVML.ALEstimate")) setMethod(".checkEstClassForParamFamily", Modified: branches/robast-1.2/pkg/RobExtremes/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobExtremes/inst/NEWS 2018-08-16 13:20:25 UTC (rev 1153) +++ branches/robast-1.2/pkg/RobExtremes/inst/NEWS 2018-08-16 15:27:54 UTC (rev 1154) @@ -11,6 +11,10 @@ version 1.2 ####################################### +bugfixes: ++ Bernhard discovered a bug in ".checkEstClassForParamFamily" for GEV (was GPD instead of GEV) ++ there were no classes [GPD/GEV]MDEstimate -> fixed now + under the hood + moved quantile integration methods for expectation for Weibull and Gamma distribution to pkg distrEx (>= 2.8.0) @@ -35,6 +39,7 @@ deleted classes "GPDMCALEstimate", "GEVMCALEstimate" as not every MCE is an ALE -> this gave misleading error messages + warning/caveat in the help to GEVFamily/GEVFamilyMuUnknown as to the accuracy of PickandsEstimator for GEV + introduced particular liesInSupport methods for Gumbel, Pareto, GPareto, and GEV + ####################################### version 1.1 Modified: branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd 2018-08-16 13:20:25 UTC (rev 1153) +++ branches/robast-1.2/pkg/RobExtremes/man/internal-methods.Rd 2018-08-16 15:27:54 UTC (rev 1154) @@ -8,6 +8,7 @@ \alias{.checkEstClassForParamFamily,GParetoFamily,kStepEstimate-method} \alias{.checkEstClassForParamFamily,GParetoFamily,ORobEstimate-method} \alias{.checkEstClassForParamFamily,GParetoFamily,MLEstimate-method} +\alias{.checkEstClassForParamFamily,GParetoFamily,MDEstimate-method} \alias{.checkEstClassForParamFamily,GParetoFamily,CvMMDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,Estimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,MCEstimate-method} @@ -16,6 +17,7 @@ \alias{.checkEstClassForParamFamily,GEVFamily,ORobEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,MLEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamily,CvMMDEstimate-method} +\alias{.checkEstClassForParamFamily,GEVFamily,MDEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,Estimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,MCEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,LDEstimate-method} @@ -23,6 +25,7 @@ \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,ORobEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,MLEstimate-method} \alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,CvMMDEstimate-method} +\alias{.checkEstClassForParamFamily,GEVFamilyMuUnknown,MDEstimate-method} \title{ Methods for Function .checkEstClassForParamFamily in Package `RobExtremes' } \description{.checkEstClassForParamFamily-methods} %\usage{.checkEstClassForParamFamily(PFam, estimator) @@ -59,6 +62,8 @@ S4 class \code{GPDkStepEstimate},\cr the \code{GParetoFamily,ORobEstimate}-method cast to S4 class \code{GPDORobEstimate},\cr +the \code{GParetoFamily,MDEstimate}-method cast to +S4 class \code{GPDMDEstimate},\cr the \code{GParetoFamily,MLEstimate}-method cast to S4 class \code{GPDML.ALEstimate},\cr the \code{GParetoFamily,CvMMDEstimate}-method cast to @@ -74,6 +79,8 @@ S4 class \code{GEVkStepEstimate},\cr the \code{GEVFamily,ORobEstimate}-method cast to S4 class \code{GEVORobEstimate},\cr +the \code{GEVFamily,MDEstimate}-method cast to +S4 class \code{GEVMDEstimate},\cr the \code{GEVFamily,MLEstimate}-method cast to S4 class \code{GEVML.ALEstimate},\cr the \code{GEVFamily,CvMMDEstimate}-method cast to @@ -89,6 +96,8 @@ S4 class \code{GEVkStepstimate}.\cr the \code{GEVFamilyMuUnknown,ORobEstimate}-method cast to S4 class \code{GEVORobEstimate},\cr +the \code{GEVFamilyMuUnknown,MDEstimate}-method cast to +S4 class \code{GEVMDEstimate},\cr the \code{GEVFamilyMuUnknown,MLEstimate}-method cast to S4 class \code{GEVML.ALEstimate},\cr the \code{GEVFamilyMuUnknown,CvMMDEstimate}-method cast to Modified: branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd 2018-08-16 13:20:25 UTC (rev 1153) +++ branches/robast-1.2/pkg/RobExtremes/man/internalEstimatorReturnClasses-class.Rd 2018-08-16 15:27:54 UTC (rev 1154) @@ -5,6 +5,8 @@ \alias{GEVEstimate-class} \alias{GPDMCEstimate-class} \alias{GEVMCEstimate-class} +\alias{GPDMDEstimate-class} +\alias{GEVMDEstimate-class} \alias{GPDLDEstimate-class} \alias{GEVLDEstimate-class} \alias{GPDkStepEstimate-class} @@ -23,6 +25,7 @@ \section{Described classes}{ The S4 classes described here are \code{GPDEstimate}, \code{GEVEstimate}, \code{GPDMCEstimate}, \code{GEVMCEstimate}, + \code{GPDMDEstimate}, \code{GEVMDEstimate}, \code{GPDLDEstimate}, \code{GEVLDEstimate}, \code{GPDkStepEstimate}, \code{GEVkStepEstimate}, \code{GPDORobEstimate}, \code{GEVORobEstimate}, @@ -42,6 +45,10 @@ \code{MCEstimate}, directly.\cr Class \code{GEVMCEstimate} extends classes \code{GEVEstimate}, \code{MCEstimate}, directly.\cr +Class \code{GPDMDEstimate} extends classes \code{GPDEstimate}, +\code{MDEstimate}, directly.\cr +Class \code{GEVMDEstimate} extends classes \code{GEVEstimate}, +\code{MDEstimate}, directly.\cr Class \code{GPDMCALEstimate} extends classes \code{GPDEstimate}, \code{MCALEstimate}, directly.\cr Class \code{GEVMCALEstimate} extends classes \code{GEVEstimate}, From noreply at r-forge.r-project.org Thu Aug 16 20:20:34 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 20:20:34 +0200 (CEST) Subject: [Robast-commits] r1155 - in branches/robast-1.2/pkg/RobAStBase: R inst man Message-ID: <20180816182034.E3A71189750@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 20:20:34 +0200 (Thu, 16 Aug 2018) New Revision: 1155 Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd Log: [RobAStBase] branch 1.2 + kStepEstimator, getboundedIC, getRiskIC for signature (IC, asCov, missing, L2ParamFamily), checkIC and makeIC gain argument diagnostic to be able to show diagnostic information on integrations; this information (if argument "diagnostic" is TRUE) is stored in attribute "diagnostic" of the return value Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-16 15:27:54 UTC (rev 1154) +++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-16 18:20:34 UTC (rev 1155) @@ -83,6 +83,9 @@ print(attr(res$E.IC.L,"diagnostic")) } + if(diagnostic) + attr(prec,"diagnostic") <- c(attr(res$E.IC,"diagnostic"), + attr(res$E.IC.L,"diagnostic")) return(prec) }) @@ -124,14 +127,19 @@ CallL2Fam <- L2Fam at fam.call - return(IC(name = name(IC), + IC.0 <- IC(name = name(IC), Curve = EuclRandVarList(Y), Risks = list(), Infos=matrix(c("IC<-", "generated by affine linear trafo to enforce consistency"), ncol=2, dimnames=list(character(0), c("method", "message"))), CallL2Fam = CallL2Fam, - modifyIC = modifyIC)) + modifyIC = modifyIC) + + if(diagnostic) + attr(IC.0,"diagnostic") <- c(attr(res$E.IC,"diagnostic"), + attr(res$E.IC.L,"diagnostic")) + return(IC.0) }) ## make some L2function a pIC at a model Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-16 15:27:54 UTC (rev 1154) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-16 18:20:34 UTC (rev 1155) @@ -55,7 +55,8 @@ withPICList = getRobAStBaseOption("withPICList"), na.rm = TRUE, startArgList = NULL, ..., withLogScale = TRUE, withEvalAsVar = TRUE, - withMakeIC = FALSE, E.argList = NULL){ + withMakeIC = FALSE, E.argList = NULL, + diagnostic = FALSE){ time <- proc.time() on.exit(message("Timing stopped at: ", ppt(proc.time() - time))) @@ -65,6 +66,11 @@ if(is.null(E.argList)) E.argList <- list() if(is.null(E.argList$useApply)) E.argList$useApply <- FALSE + diagn <- NULL + if(diagnostic){ + E.argList$diagnostic <- TRUE + diagn <- list() + } if(missing(IC.UpdateInKer)) IC.UpdateInKer <- NULL ## get some dimensions @@ -185,15 +191,22 @@ # print(L2Fam) L2Fam <- modifyModel(L2Fam, Param, .withL2derivDistr = L2Fam at .withEvalL2derivDistr) - sytm <<- .addTime(sytm,paste("modifyModel-PreModif-",updStp)) -# print(L2Fam) + mmPreNm <- paste("modifyModel-PreModif-",updStp) + sytm <<- .addTime(sytm,mmPreNm) + if(diagnostic) diagn[[mmPreNm]] <<- attr(L2Fam,"diagnostic") +# print(L2Fam) + modifyICargs <- c(list(L2Fam, IC, withMakeIC = FALSE), E.argList) IC <- do.call(modifyIC(IC),modifyICargs) - sytm <<- .addTime(sytm,paste("modifyIC-PreModif-",updStp)) + mmPreICNm <- paste("modifyIC-PreModif-",updStp) + sytm <<- .addTime(sytm,mmPreICNm) + if(diagnostic) diagn[[mmPreICNm]] <<- attr(IC,"diagnostic") if(steps==1L && withMakeIC){ makeICargs <- c(list(IC, L2Fam),E.argList) IC <- do.call(makeIC, makeICargs) - sytm <<- .addTime(sytm,paste("modifyIC-makeIC-",updStp)) + mmPreMkICNm <- paste("modifyIC-makeIC-",updStp) + sytm <<- .addTime(sytm,mmPreMkICNm) + if(diagnostic) diagn[[mmPreMkICNm]] <<- attr(IC,"diagnostic") } } @@ -220,10 +233,14 @@ if(is.null(IC.UpdateInKer)){ getBoundedICargs <- c(list(L2Fam, D = projker),E.argList) IC.tot2 <- do.call(getBoundedIC, getBoundedICargs) - sytm <<- .addTime(sytm,paste("getBoundedIC-",updStp)) + mmgtBDICNm <- paste("getBoundedIC-",updStp) + sytm <<- .addTime(sytm,mmgtBDICNm) + if(diagnostic) diagn[[mmgtBDICNm]] <<- attr(IC.tot2,"diagnostic") }else{ IC.tot2 <- as(projker %*% IC.UpdateInKer at Curve, "EuclRandVariable") - sytm <<- .addTime(sytm,paste("IC.tot2<-as(projker...-",updStp)) + mmgtAsPrICNm <- paste("IC.tot2<-as(projker...-",updStp) + sytm <<- .addTime(sytm,mmgtAsPrICNm) + if(diagnostic) diagn[[mmgtAsPrICNm]] <<- attr(IC.tot2,"diagnostic") } IC.tot2.isnull <- FALSE IC.tot.0 <- IC.tot1 + IC.tot2 @@ -281,16 +298,24 @@ L2F0 = L2Fam, IC0 = IC.tot.0, dim0 = k, dimn0 = list(cnms,cnms))) sytm <<- .addTime(sytm,paste("u.var-",updStp)) - if(withEvalAsVar.0) u.var <- eval(u.var) - sytm <<- .addTime(sytm,paste("u.var-eval-",updStp)) + if(withEvalAsVar.0){ + u.var <- eval(u.var) + uvEvnm <- paste("u.var-eval-",updStp) + sytm <<- .addTime(sytm,uvEvnm) + if(diagnostic) diagn[[uvEvnm]] <<- attr(u.var,"diagnostic") + } } if(!var.to.be.c){ var0 <- substitute(do.call(cfct, args = list(L2F0, IC0, dim0, dimn0)), list(cfct = cvar.fct, L2F0 = L2Fam, IC0 = IC.c, dim0 = p)) sytm <<- .addTime(sytm,paste("var0-",updStp)) - if(withEvalAsVar.0) var0 <- eval(var0) - sytm <<- .addTime(sytm,paste("var0-eval-",updStp)) + if(withEvalAsVar.0) { + var0 <- eval(var0) + vEvnm <- paste("var0-eval-",updStp) + sytm <<- .addTime(sytm,paste("var0-eval-",updStp)) + if(diagnostic) diagn[[vEvnm]] <<- attr(var0,"diagnostic") + } } } if(withPostModif){ @@ -298,10 +323,15 @@ if (lnx) nuisance(Param)[] <- .deleteDim(u.theta[nuis.idx]) L2Fam <- modifyModel(L2Fam, Param, .withL2derivDistr = L2Fam at .withEvalL2derivDistr) - sytm <<- .addTime(sytm,paste("modifyModel-PostModif-",updStp)) + mmPostNm <- paste("modifyModel-PostModif-",updStp) + sytm <<- .addTime(sytm,mmPostNm) + if(diagnostic) diagn[[mmPostNm]] <<- attr(L2Fam,"diagnostic") + modifyICargs <- c(list(L2Fam, IC, withMakeIC = withMakeIC), E.argList) IC <- do.call(modifyIC(IC),modifyICargs) - sytm <<- .addTime(sytm,paste("modifyIC-PostModif-",updStp)) + mmPostICNm <- paste("modifyIC-PostModif-",updStp) + sytm <<- .addTime(sytm,mmPostICNm) + if(diagnostic) diagn[[mmPostICNm]] <<- attr(IC,"diagnostic") } li <- list(IC = IC, Param = Param, L2Fam = L2Fam, @@ -331,7 +361,9 @@ if((i==steps)&&withMakeIC){ makeICargs <- c(list(IC, L2Fam),E.argList) IC <- do.call(makeIC, makeICargs) - sytm <- .addTime(sytm,paste("makeIC-",i)) + mkICnm <- paste("makeIC-",i) + sytm <- .addTime(sytm,mkICnm) + if(diagnostic) diagn[[mkICnm]] <- attr(IC,"diagnostic") } Param <- upd$Param @@ -372,7 +404,9 @@ if(withMakeIC){ makeICargs <- c(list(IC, L2Fam),E.argList) IC <- do.call(makeIC, makeICargs) - sytm <- .addTime(sytm,"makeIC-useLast") + mkICULnm <- paste("makeIC-useLast") + sytm <- .addTime(sytm,mkICULnm) + if(diagnostic) diagn[[mkICULnm]] <- attr(IC,"diagnostic") } }else{ Infos <- rbind(Infos, c("kStepEstimator", @@ -420,6 +454,7 @@ riskAsVar <- do.call(getRiskIC, getRiskICasVarArgs) asVar <- riskAsVar$asCov$value sytm <- .addTime(sytm,"getRiskIC-Var") + if(diagnostic) diagn[["getRiskICVar"]] <- attr(asVar,"diagnostic") } }else asVar <- var0 @@ -473,6 +508,7 @@ estres <- .checkEstClassForParamFamily(L2Fam,estres) attr(estres,"timings") <- apply(sytm,2,diff) + if(diagnostic) attr(estres,"diagnostic") <- diagn on.exit() return(estres) Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-16 15:27:54 UTC (rev 1154) +++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-16 18:20:34 UTC (rev 1155) @@ -26,6 +26,10 @@ + particular checkIC methods are now documented in documentation object checkIC (and no longer with class IC); there argument out is documented ++ kStepEstimator, getboundedIC, getRiskIC for signature (IC, asCov, missing, L2ParamFamily), + checkIC and makeIC gain argument diagnostic to be able to show diagnostic + information on integrations; this information (if argument "diagnostic" is TRUE) + is stored in attribute "diagnostic" of the return value bugfixes + and a forgotten no longer used instance of oldmodif in kStepEstimator @@ -93,9 +97,6 @@ overwrites existing entries). + getboundedIC now uses coordinate-wise integration with useApply = FALSE and only computing the upper half of E LL'w -+ getboundedIC, getRiskIC for signature (IC, asCov, missing, L2ParamFamily), - checkIC and makeIC gain argument diagnostic to be able to show diagnostic - information on integrations ####################################### version 1.1 @@ -128,7 +129,8 @@ + getRiskIC and getBiasIC gain argument withCheck to speed up things if one does not want to call checkIC + in kStepEstimator, withCheck is set to FALSE when getRiskIC is called, and makeIC is only called just before the last update, and, if useLast == TRUE for the last update (of course, only if withMakeIC ==TRUE) - ++ kStepEstimator, + Return value of "roptest" + the return value of "roptest", an object of class "kStepEstimate" has a slot "estimate.call" which contains the (matched) call to "roptest"; internally "roptest" calls "robest"; the call to "robest" Modified: branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd 2018-08-16 15:27:54 UTC (rev 1154) +++ branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd 2018-08-16 18:20:34 UTC (rev 1155) @@ -14,7 +14,7 @@ withPICList = getRobAStBaseOption("withPICList"), na.rm = TRUE, startArgList = NULL, ..., withLogScale = TRUE, withEvalAsVar = TRUE, - withMakeIC = FALSE, E.argList = NULL) + withMakeIC = FALSE, E.argList = NULL, diagnostic = FALSE) } \arguments{ \item{x}{ sample } @@ -56,6 +56,10 @@ the items of argument list \code{E.argList} as named items to the argument lists, so in case of collisions the item of \code{E.argList} overwrites the existing one from \code{\dots}.} + \item{diagnostic}{ logical; if \code{TRUE}, + diagnostic information on the performed integrations is gathered and + shipped out as an attribute \code{diagnostic} of the return value + of \code{kStepEstimator}. } } \details{ Given an initial estimation \code{start}, a sample \code{x} From noreply at r-forge.r-project.org Thu Aug 16 20:39:46 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 20:39:46 +0200 (CEST) Subject: [Robast-commits] r1156 - in branches/robast-1.2/pkg/ROptEst: R inst man Message-ID: <20180816183946.4EF7F187DB9@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 20:39:45 +0200 (Thu, 16 Aug 2018) New Revision: 1156 Modified: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R branches/robast-1.2/pkg/ROptEst/R/getStartIC.R branches/robast-1.2/pkg/ROptEst/R/roptest.new.R branches/robast-1.2/pkg/ROptEst/inst/NEWS branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd branches/robast-1.2/pkg/ROptEst/man/getStartIC-methods.Rd branches/robast-1.2/pkg/ROptEst/man/robest.Rd branches/robast-1.2/pkg/ROptEst/man/roptest.Rd Log: [ROptEst] branch 1.2 + roptest _and the wrappers RMX|OBR|MBR|OMSEstimator_ gain an argument E.argList .... + roptest and its wrappers RMX|OBR|MBR|OMSEstimator, getStartIC for asGRisk, asBias, RMX, and asAnscombe, as well as the particular checkIC/makeIC methods for ContIC gain argument diagnostic to be able to show diagnostic information on integrations; this information (if argument "diagnostic" is TRUE) is stored in attribute "diagnostic" of the return value Modified: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R 2018-08-16 18:20:34 UTC (rev 1155) +++ branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R 2018-08-16 18:39:45 UTC (rev 1156) @@ -48,6 +48,8 @@ prec <- max(abs(Delta1), abs(Delta2)) names(prec) <- "maximum deviation" + if(diagnostic) attr(prec, "diagnostic") <- c(attr(res$G1, "diagnostic"), + attr(res$G2, "diagnostic"), attr(res$G3, "diagnostic")) return(prec) }) @@ -125,6 +127,10 @@ cIC1 at modifyIC <- IC at modifyIC addInfo(cIC1) <- c("IC<-", "generated by affine linear trafo to enforce consistency") + + if(diagnostic) attr(cIC1, "diagnostic") <- c(attr(res$G1, "diagnostic"), + attr(res$G2, "diagnostic"), attr(res$G3, "diagnostic")) + return(cIC1) }) Modified: branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R 2018-08-16 18:20:34 UTC (rev 1155) +++ branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R 2018-08-16 18:39:45 UTC (rev 1156) @@ -10,7 +10,8 @@ na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, withEvalAsVar = NULL, withMakeIC = FALSE, - modifyICwarn = NULL){ + modifyICwarn = NULL, E.argList = NULL, + diagnostic = FALSE){ mc <- match.call(expand.dots=FALSE) dots <- mc$"..." @@ -30,7 +31,9 @@ withLogScale = withLogScale, ..withCheck = ..withCheck, withTimings = withTimings, withMDE = withMDE, withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC, - modifyICwarn = modifyICwarn) + modifyICwarn = modifyICwarn, E.argList = NULL, + diagnostic = FALSE, E.argList = E.argList, + diagnostic = diagnostic) if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots) if(!missing(initial.est)) roptestArgList$initial.est <- initial.est @@ -54,7 +57,8 @@ na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, withEvalAsVar = NULL, withMakeIC = FALSE, - modifyICwarn = NULL){ + modifyICwarn = NULL, E.argList = NULL, + diagnostic = FALSE){ if(!is.numeric(eps)||length(eps)>1||any(eps<0)) stop("Radius 'eps' must be given, of length 1 and non-negative.") @@ -76,7 +80,8 @@ withLogScale = withLogScale, ..withCheck = ..withCheck, withTimings = withTimings, withMDE = withMDE, withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC, - modifyICwarn = modifyICwarn) + modifyICwarn = modifyICwarn, E.argList = E.argList, + diagnostic = diagnostic) if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots) if(!missing(initial.est)) roptestArgList$initial.est <- initial.est @@ -100,7 +105,8 @@ na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, withEvalAsVar = NULL, withMakeIC = FALSE, - modifyICwarn = NULL){ + modifyICwarn = NULL, E.argList = NULL, + diagnostic = FALSE){ if(!is.numeric(eff)||length(eff)>1||any(eff<0|eff>1)) stop("Efficiency loss (in the ideal model) 'eff' must be given, of length 1 and in [0,1].") @@ -118,7 +124,8 @@ withLogScale = withLogScale, ..withCheck = ..withCheck, withTimings = withTimings, withMDE = withMDE, withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC, - modifyICwarn = modifyICwarn) + modifyICwarn = modifyICwarn, E.argList = E.argList, + diagnostic = diagnostic) if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots) if(!missing(initial.est)) roptestArgList$initial.est <- initial.est @@ -142,7 +149,8 @@ na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, withEvalAsVar = NULL, withMakeIC = FALSE, - modifyICwarn = NULL){ + modifyICwarn = NULL, E.argList = NULL, + diagnostic = FALSE){ mc <- match.call(expand.dots=FALSE) dots <- mc$"..." @@ -162,7 +170,8 @@ withLogScale = withLogScale, ..withCheck = ..withCheck, withTimings = withTimings, withMDE = withMDE, withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC, - modifyICwarn = modifyICwarn) + modifyICwarn = modifyICwarn, E.argList = E.argList, + diagnostic = diagnostic) if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots) if(!missing(initial.est)) roptestArgList$initial.est <- initial.est Modified: branches/robast-1.2/pkg/ROptEst/R/getStartIC.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/getStartIC.R 2018-08-16 18:20:34 UTC (rev 1155) +++ branches/robast-1.2/pkg/ROptEst/R/getStartIC.R 2018-08-16 18:39:45 UTC (rev 1156) @@ -3,9 +3,10 @@ setMethod("getStartIC",signature(model = "L2ParamFamily", risk = "asGRisk"), function(model, risk, ..., withEvalAsVar = TRUE, withMakeIC = FALSE, - ..debug=FALSE, modifyICwarn = NULL){ + ..debug=FALSE, modifyICwarn = NULL, diagnostic = FALSE){ mc <- match.call(expand.dots=FALSE, call = sys.call(sys.parent(1))) dots <- as.list(mc$"...") + diagn <- if(diagnostic) list() else NULL if(missing(..debug)||!is.logical(..debug)) ..debug <- FALSE if("fsCor" %in% names(dots)){ fsCor <- eval(dots[["fsCor"]]) @@ -32,6 +33,7 @@ dots.rmx$risk <- NULL dots.rmx$modifyICwarn <- modifyICwarn dots.rmx[["warn"]] <- FALSE + if(diagnostic) dots.rmx[["diagnostic"]] <- TRUE if(!is.null(dots[["warn"]]))if(eval(dots[["warn"]])) dots.rmx[["warn"]] <- TRUE infMod <- InfRobModel(center = model, neighbor = neighbor) @@ -60,6 +62,7 @@ dots.optic$withMakeIC <- withMakeIC dots.optic$modifyICwarn <- modifyICwarn dots.optic[["warn"]] <- FALSE + if(diagnostic) dots.optic[["diagnostic"]] <- TRUE if(!is.null(dots[["warn"]]))if(eval(dots[["warn"]])) dots.optic[["warn"]] <- TRUE arg.optic <- c(list(model = infMod, risk = risk), @@ -80,7 +83,7 @@ setMethod("getStartIC",signature(model = "L2ParamFamily", risk = "asBias"), function(model, risk, ..., withMakeIC = FALSE, ..debug=FALSE, - modifyICwarn = NULL){ + modifyICwarn = NULL, diagnostic = FALSE){ mc <- match.call(expand.dots=FALSE, call = sys.call(sys.parent(1))) dots <- as.list(mc$"...") @@ -98,14 +101,15 @@ #print(list(c(list(infMod, risk), dots, list(warn = FALSE, # withMakeIC = withMakeIC, modifyICwarn = modifyICwarn)))) return(do.call(optIC, c(list(infMod, risk), dots, list(warn = FALSE, - withMakeIC = withMakeIC, modifyICwarn = modifyICwarn)), + withMakeIC = withMakeIC, modifyICwarn = modifyICwarn, + diagnostic = diagnostic)), envir=parent.frame(2))) }) setMethod("getStartIC",signature(model = "L2ParamFamily", risk = "asAnscombe"), function(model, risk, ..., withEvalAsVar = TRUE, withMakeIC = FALSE, - ..debug=FALSE, modifyICwarn = NULL){ + ..debug=FALSE, modifyICwarn = NULL, diagnostic = FALSE){ mc <- match.call(expand.dots=FALSE, call = sys.call(sys.parent(1))) dots <- as.list(mc$"...") if(missing(..debug)||!is.logical(..debug)) ..debug <- FALSE @@ -124,6 +128,7 @@ dots.optic$withMakeIC <- withMakeIC dots.optic$modifyICwarn <- modifyICwarn dots.optic[["warn"]] <- FALSE + if(diagnostic) dots.optic[["diagnostic"]] <- TRUE if(!is.null(dots[["warn"]]))if(eval(dots[["warn"]])) dots.optic[["warn"]] <- TRUE arg.optic <- c(list(model = infMod, risk = risk), dots.optic) Modified: branches/robast-1.2/pkg/ROptEst/R/roptest.new.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-16 18:20:34 UTC (rev 1155) +++ branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-16 18:39:45 UTC (rev 1156) @@ -92,7 +92,7 @@ withLogScale = TRUE,..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, withEvalAsVar = NULL, withMakeIC = FALSE, - modifyICwarn = NULL, E.argList = NULL){ + modifyICwarn = NULL, E.argList = NULL, diagnostic = FALSE){ mc <- match.call(expand.dots=FALSE) dots <- mc[["..."]] scalename <- dots[["scalename"]] @@ -102,13 +102,14 @@ if(!missing(eps.lower)) nbCtrl[["eps.lower"]] <- eps.lower if(!missing(eps.upper)) nbCtrl[["eps.upper"]] <- eps.upper + if(diagnostic) if(!missing(E.argList)&&!is.null(E.argList)) E.argList[["diagnostic"]] <- TRUE + startICCtrl <- list() startICCtrl[["withMakeIC"]] <- if(!missing(withMakeIC)) withMakeIC else FALSE startICCtrl[["withEvalAsVar"]] <- if(!missing(withEvalAsVar)) withEvalAsVar else NULL startICCtrl[["modifyICwarn"]] <- if(!missing(modifyICwarn)) modifyICwarn else FALSE startICCtrl[["E.argList"]] <- if(!missing(E.argList)) E.argList else NULL - startCtrl <- list() if(!missing(initial.est)) startCtrl[["initial.est"]] <- initial.est if(!missing(initial.est.ArgList)) @@ -136,16 +137,20 @@ startCtrl = startCtrl, startICCtrl = startICCtrl, kStepCtrl = kStepCtrl, na.rm = na.rm, ..., debug = ..withCheck, - withTimings = withTimings) + withTimings = withTimings, diagnostic = diagnostic) retV at robestCall <- quote(retV at estimate.call) retV at estimate.call <- mc tim <- attr(retV,"timings") timK <- attr(retV,"kStepTimings") + diagn <- attr(retV,"diagnostic") + kStpDiagn <- attr(retV,"kStepDiagnostic") retV <- as(as(retV,"kStepEstimate"), "ORobEstimate") retV <- .checkEstClassForParamFamily(L2Fam,retV) attr(retV,"timings") <- tim attr(retV,"kStepTimings") <- timK + attr(retV,"diagnostic") <- diagn + attr(retV,"kStepDiagnostic") <- kStpDiagn retV at roptestCall <- mc return(retV) } @@ -162,7 +167,7 @@ startICCtrl = genstartICCtrl(), kStepCtrl = genkStepCtrl(), na.rm = TRUE, ..., debug = FALSE, - withTimings = FALSE){ + withTimings = FALSE, diagnostic = FALSE){ #### TOBEDONE: set default for risk depending on L2Fam, @@ -205,6 +210,7 @@ withMakeICkStep <- kStepCtrl$withMakeIC if(is.null(withMakeICkStep)) withMakeICkStep <- FALSE + diagn <- if(diagnostic) list() else NULL es.list <- as.list(es.call0[-1]) es.list <- c(es.list,nbCtrl) @@ -253,7 +259,8 @@ nms <- names(startCtrl$E.arglist) for(nmi in nms) argListMDE[[nmi]] <- startCtrl$E.arglist[[nmi]] } - startCtrl$initial.est <- do.call(MDEstimator, argListMDE) + startCtrl$initial.est <- buf <- do.call(MDEstimator, argListMDE) + if(diagnostic) diagn[["startEst"]] <- attr(buf,"diagnostic") } } } @@ -301,6 +308,7 @@ if(!debug){ main(newParam)[] <- as.numeric(initial.est) L2FamStart <- modifyModel(L2Fam, newParam) + if(diagnostic) diagn[["modifyModel"]] <- attr(L2FamStart,"diagnostic") } if(debug) print(risk) @@ -343,6 +351,7 @@ for(nmi in nms) getStartICArgList[[nmi]] <- startICCtrl$E.arglist[[nmi]] } ICstart <- do.call(getStartIC, args=getStartICArgList) + if(diagnostic) diagn[["ICstart"]] <- attr(ICstart,"diagnostic") }) if (withTimings) print(sy.getStartIC) } @@ -380,6 +389,7 @@ res <- do.call(kStepEstimator, kStepArgList) }) sy.OnlykStep <- attr(res,"timings") + kStpDiagn <- attr(res,"diagnostic") if (withTimings) print(sy.kStep) if (withTimings && !is.null(sy.OnlykStep)) print(sy.OnlykStep) if(!debug){ @@ -413,5 +423,7 @@ res at start <- initial.est attr(res, "timings") <- sy attr(res, "kStepTimings") <- sy.OnlykStep + if(diagnostic) attr(res,"kStepDiagnostic") <- kStpDiagn + if(diagnostic) attr(res,"diagnostic") <- diagn return(res) } Modified: branches/robast-1.2/pkg/ROptEst/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-16 18:20:34 UTC (rev 1155) +++ branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-16 18:39:45 UTC (rev 1156) @@ -24,12 +24,16 @@ and start.Par and the different steps done in roptest + the input generators genkStepCtrl, genstartCtrl, genstartICCtrl gain argument E.argList to pass on arguments to E() -+ roptest gains an argument E.argList for arguments to be passed to E() from (a) - \code{MDEstimator} (here this additional argument is only used if \code{initial.est} - is missing), (b) \code{getStartIC}, and (c) \code{kStepEstimator}. Potential clashes with - arguments of the same name in \code{\dots} are resolved by inserting the items of argument - list \code{E.argList} as named items, so in case of collisions the item of \code{E.argList} - overwrites the existing one from \code{\dots}. ++ roptest and the wrappers RMX|OBR|MBR|OMSEstimator gain an argument E.argList for arguments + to be passed to E() from (a) \code{MDEstimator} (here this additional argument is only + used if \code{initial.est} is missing), (b) \code{getStartIC}, and (c) \code{kStepEstimator}. + Potential clashes with arguments of the same name in \code{\dots} are resolved by inserting + the items of argument list \code{E.argList} as named items, so in case of collisions the + item of \code{E.argList} overwrites the existing one from \code{\dots}. ++ roptest and its wrappers RMX|OBR|MBR|OMSEstimator, getStartIC for asGRisk, asBias, RMX, and + asAnscombe, as well as the particular checkIC/makeIC methods for ContIC gain argument + diagnostic to be able to show diagnostic information on integrations; this information + (if argument "diagnostic" is TRUE) is stored in attribute "diagnostic" of the return value bug fixes @@ -65,8 +69,8 @@ geInfGamma, getInfRad, getInfClip, getInfCent, getInfStand, getInfV, getAsRisk, getReq, (at least as far as multivariate ICs are concerned), .LowerCaseMultivariate, getMaxIneff, getInfRad, getLagrangeMultByIter and getLagrangeMultByOptim -+ new internal helper function .filterEarg by means of constant ..IntegrateArgs (exported - from package RobAStBase) is used to filter out arguments from dots which are meant for E() ++ new internal helper function .filterEargWEargList is used to filter out arguments + from dots which are meant for E() + the local .modifyIC0 functions only used to produce the new IC but not for filling slot modifyIC loose argument withMakeIC (and dots) -- this is now done in the outer modifyIC function @@ -77,6 +81,7 @@ than in the default method. This can be overriden by argument forceContICMethod. + the particular checkIC and makeIC methods gain argument diagnostic to be able to show diagnostic information on integrations + ####################################### version 1.1 Modified: branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd 2018-08-16 18:20:34 UTC (rev 1155) +++ branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd 2018-08-16 18:39:45 UTC (rev 1156) @@ -19,7 +19,8 @@ withPICList = getRobAStBaseOption("withPICList"), na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, withEvalAsVar = NULL, - withMakeIC = FALSE, modifyICwarn = NULL) + withMakeIC = FALSE, modifyICwarn = NULL, E.argList = NULL, + diagnostic = FALSE) OMSEstimator(x, L2Fam, eps=0.5, fsCor = 1, initial.est, neighbor = ContNeighborhood(), steps = 1L, distance = CvMDist, startPar = NULL, verbose = NULL, OptOrIter = "iterate", useLast = getRobAStBaseOption("kStepUseLast"), @@ -29,7 +30,8 @@ withPICList = getRobAStBaseOption("withPICList"), na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, withEvalAsVar = NULL, - withMakeIC = FALSE, modifyICwarn = NULL) + withMakeIC = FALSE, modifyICwarn = NULL, E.argList = NULL, + diagnostic = FALSE) OBREstimator(x, L2Fam, eff=0.95, fsCor = 1, initial.est, neighbor = ContNeighborhood(), steps = 1L, distance = CvMDist, startPar = NULL, verbose = NULL, OptOrIter = "iterate", useLast = getRobAStBaseOption("kStepUseLast"), @@ -39,7 +41,8 @@ withPICList = getRobAStBaseOption("withPICList"), na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, withEvalAsVar = NULL, - withMakeIC = FALSE, modifyICwarn = NULL) + withMakeIC = FALSE, modifyICwarn = NULL, E.argList = NULL, + diagnostic = FALSE) MBREstimator(x, L2Fam, fsCor = 1, initial.est, neighbor = ContNeighborhood(), steps = 1L, distance = CvMDist, startPar = NULL, verbose = NULL, OptOrIter = "iterate", useLast = getRobAStBaseOption("kStepUseLast"), @@ -49,7 +52,8 @@ withPICList = getRobAStBaseOption("withPICList"), na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL, withEvalAsVar = NULL, - withMakeIC = FALSE, modifyICwarn = NULL) + withMakeIC = FALSE, modifyICwarn = NULL, E.argList = NULL, + diagnostic = FALSE) } \arguments{ \item{x}{ sample } @@ -123,6 +127,19 @@ \code{modifyIC} is applied and hence some optimality information could no longer be valid? Defaults to \code{NULL} in which case this value is taken from \code{RobAStBaseOptions}.} + \item{E.argList}{\code{NULL} (default) or a list of arguments to be passed + to calls to \code{E} from (a) \code{MDEstimator} + (here this additional argument is only used if + \code{initial.est} is missing), (b) \code{getStartIC}, + and (c) \code{kStepEstimator}. Potential clashes with + arguments of the same name in \code{\dots} are resolved by inserting + the items of argument list \code{E.argList} as named items, so + in case of collisions the item of \code{E.argList} overwrites the + existing one from \code{\dots}.} + \item{diagnostic}{ logical; if \code{TRUE}, + diagnostic information on the performed integrations is gathered and + shipped out as an attribute \code{diagnostic} of the return value + of the estimators. } } \details{ The functions compute optimally robust estimator for a given L2 differentiable Modified: branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd 2018-08-16 18:20:34 UTC (rev 1155) +++ branches/robast-1.2/pkg/ROptEst/man/checkmakeIC.Rd 2018-08-16 18:39:45 UTC (rev 1156) @@ -41,7 +41,8 @@ \code{E}. } \item{diagnostic}{ logical; if \code{TRUE} (and in case \code{checkIC} if argument \code{out==TRUE}), diagnostic information on the integration - is printed. } + is printed and returned as attribute \code{diagnostic} of the return value. } + } \details{ In \code{checkIC}, the precisions of the centering and the Fisher consistency Modified: branches/robast-1.2/pkg/ROptEst/man/getStartIC-methods.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/getStartIC-methods.Rd 2018-08-16 18:20:34 UTC (rev 1155) +++ branches/robast-1.2/pkg/ROptEst/man/getStartIC-methods.Rd 2018-08-16 18:39:45 UTC (rev 1156) @@ -21,16 +21,16 @@ \S4method{getStartIC}{ANY,ANY}(model, risk, ...) \S4method{getStartIC}{L2ParamFamily,asGRisk}(model, risk, ..., withEvalAsVar = TRUE, withMakeIC = FALSE, ..debug=FALSE, - modifyICwarn = NULL) + modifyICwarn = NULL, diagnostic = FALSE) \S4method{getStartIC}{L2ParamFamily,asBias}(model, risk, ..., withMakeIC = FALSE, - ..debug=FALSE, modifyICwarn = NULL) + ..debug=FALSE, modifyICwarn = NULL, diagnostic = FALSE) \S4method{getStartIC}{L2ParamFamily,asCov}(model, risk, ..., withMakeIC = FALSE, ..debug=FALSE) \S4method{getStartIC}{L2ParamFamily,trAsCov}(model, risk, ..., withMakeIC = FALSE, ..debug=FALSE) \S4method{getStartIC}{L2ParamFamily,asAnscombe}(model, risk, ..., withEvalAsVar = TRUE, withMakeIC = FALSE, ..debug=FALSE, - modifyICwarn = NULL) + modifyICwarn = NULL, diagnostic = FALSE) \S4method{getStartIC}{L2LocationFamily,interpolRisk}(model, risk, ...) \S4method{getStartIC}{L2ScaleFamily,interpolRisk}(model, risk, ...) \S4method{getStartIC}{L2LocationScaleFamily,interpolRisk}(model, risk, ...) @@ -50,6 +50,10 @@ \code{modifyIC} is applied and hence some optimality information could no longer be valid? Defaults to \code{NULL} in which case this value is taken from \code{RobAStBaseOptions}.} + \item{diagnostic}{ logical; if \code{TRUE}, + diagnostic information on the performed integrations is gathered and + shipped out as an attribute \code{diagnostic} of the return value + of the estimators. } } \section{Methods}{\describe{ \item{getStartIC}{\code{signature(model = "ANY", risk = "ANY")}: Modified: branches/robast-1.2/pkg/ROptEst/man/robest.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/robest.Rd 2018-08-16 18:20:34 UTC (rev 1155) +++ branches/robast-1.2/pkg/ROptEst/man/robest.Rd 2018-08-16 18:39:45 UTC (rev 1156) @@ -10,7 +10,7 @@ verbose = NULL, OptOrIter = "iterate", nbCtrl = gennbCtrl(), startCtrl = genstartCtrl(), startICCtrl = genstartICCtrl(), kStepCtrl = genkStepCtrl(), na.rm = TRUE, ..., debug = FALSE, - withTimings = FALSE) + withTimings = FALSE, diagnostic = FALSE) } \arguments{ \item{x}{ sample } @@ -47,6 +47,11 @@ timings for the three steps evaluating the starting value, finding the starting influence curve, and evaluating the k-step estimator is issued.} + \item{diagnostic}{ logical; if \code{TRUE}, + diagnostic information on the performed integrations is gathered and + shipped out as attributes \code{kStepDiagnostic} (for the kStepEstimator-step) + and \code{diagnostic} for the remaining steps of the return value + of \code{robest}. } } \details{ A new, more structured interface to the former function \code{\link{roptest}}. Modified: branches/robast-1.2/pkg/ROptEst/man/roptest.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/roptest.Rd 2018-08-16 18:20:34 UTC (rev 1155) +++ branches/robast-1.2/pkg/ROptEst/man/roptest.Rd 2018-08-16 18:39:45 UTC (rev 1156) @@ -19,7 +19,7 @@ na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE, ..withCheck = FALSE, withTimings = FALSE, withMDE = NULL, withEvalAsVar = NULL, withMakeIC = FALSE, - modifyICwarn = NULL, E.argList = NULL) + modifyICwarn = NULL, E.argList = NULL, diagnostic = FALSE) roptest.old(x, L2Fam, eps, eps.lower, eps.upper, fsCor = 1, initial.est, neighbor = ContNeighborhood(), risk = asMSE(), steps = 1L, distance = CvMDist, startPar = NULL, verbose = NULL, @@ -116,6 +116,11 @@ the items of argument list \code{E.argList} as named items, so in case of collisions the item of \code{E.argList} overwrites the existing one from \code{\dots}.} + \item{diagnostic}{ logical; if \code{TRUE}, + diagnostic information on the performed integrations is gathered and + shipped out as attributes \code{kStepDiagnostic} (for the kStepEstimator-step) + and \code{diagnostic} for the remaining steps of the return value + of \code{roptest}. } } \details{ Computes the optimally robust estimator for a given L2 differentiable @@ -198,6 +203,7 @@ Timings for the steps run through in \code{roptest} are available in attributes \code{timings}, and for the step of the \code{kStepEstimator} in \code{kStepTimings}. + } \value{Object of class \code{"kStepEstimate"}. In addition, it has an attribute \code{"timings"} where computation time is stored.} From noreply at r-forge.r-project.org Thu Aug 16 20:40:22 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 20:40:22 +0200 (CEST) Subject: [Robast-commits] r1157 - branches/robast-1.2/pkg/RobAStBase/man Message-ID: <20180816184022.0FE24187DB9@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 20:40:21 +0200 (Thu, 16 Aug 2018) New Revision: 1157 Modified: branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd Log: [RobAStBase] remainders of the last commit Modified: branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd 2018-08-16 18:39:45 UTC (rev 1156) +++ branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd 2018-08-16 18:40:21 UTC (rev 1157) @@ -19,7 +19,9 @@ \item{out}{ logical: Should the values of the checks be printed out?} \item{\dots}{ additional parameters } \item{diagnostic}{ logical; if \code{TRUE} and \code{out==TRUE}, - diagnostic information on the integration is printed. } + diagnostic information on the integration is printed; independent + of \code{out}, if \code{diagnostic==TRUE}, this information is + returned as attribute \code{diagnostic} of the return value. . } } \details{ The precisions of the centering and the Fisher consistency Modified: branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd 2018-08-16 18:39:45 UTC (rev 1156) +++ branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd 2018-08-16 18:40:21 UTC (rev 1157) @@ -44,7 +44,8 @@ computations! } \item{\dots}{ additional parameters to be passed to expectation \code{E} } \item{diagnostic}{ logical; if \code{TRUE}, - diagnostic information on the integration is printed. } + diagnostic information on the integration is printed and returned + as attribute \code{diagnostic} of the return value. } } \value{An IC of class \code{"IC"} at the model.} \section{Methods}{\describe{ From noreply at r-forge.r-project.org Thu Aug 16 22:04:10 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 22:04:10 +0200 (CEST) Subject: [Robast-commits] r1158 - branches/robast-1.2/pkg/ROptEst/R Message-ID: <20180816200410.8CA5A18A7E1@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 22:04:10 +0200 (Thu, 16 Aug 2018) New Revision: 1158 Modified: branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R Log: [RobExtremes] argh a typo Modified: branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R 2018-08-16 18:40:21 UTC (rev 1157) +++ branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R 2018-08-16 20:04:10 UTC (rev 1158) @@ -31,8 +31,7 @@ withLogScale = withLogScale, ..withCheck = ..withCheck, withTimings = withTimings, withMDE = withMDE, withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC, - modifyICwarn = modifyICwarn, E.argList = NULL, - diagnostic = FALSE, E.argList = E.argList, + modifyICwarn = modifyICwarn, E.argList = E.argList, diagnostic = diagnostic) if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots) From noreply at r-forge.r-project.org Sat Aug 18 22:28:44 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 18 Aug 2018 22:28:44 +0200 (CEST) Subject: [Robast-commits] r1159 - in branches/robast-1.2/pkg/RandVar: R inst tests/Examples Message-ID: <20180818202844.D9CD618ACC6@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-18 22:28:44 +0200 (Sat, 18 Aug 2018) New Revision: 1159 Modified: branches/robast-1.2/pkg/RandVar/R/Expectation.R branches/robast-1.2/pkg/RandVar/inst/NEWS branches/robast-1.2/pkg/RandVar/tests/Examples/RandVar-Ex.Rout.save Log: [RandVar] branch 1.2 + E methods for RandVariables if (diagnostic==TRUE) return diagnostic attributes of S3 class "DiagnosticClass" Modified: branches/robast-1.2/pkg/RandVar/R/Expectation.R =================================================================== --- branches/robast-1.2/pkg/RandVar/R/Expectation.R 2018-08-16 20:04:10 UTC (rev 1158) +++ branches/robast-1.2/pkg/RandVar/R/Expectation.R 2018-08-18 20:28:44 UTC (rev 1159) @@ -11,7 +11,10 @@ if(diagnostic) diagn[[i]] <- attr(buf, "diagnostic") if(nrdim>1) res[i,] <- buf else res[i] <- buf } - if(!is.null(diagn)) attr(res,"diagnostic") <- diagn + if(!is.null(diagn)){ + attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" + } return(res) } @@ -34,7 +37,10 @@ res[i] <- buf <- do.call(E, Eargs) if(diagnostic) diagn[[i]] <- attr(buf, "diagnostic") } - if(!is.null(diagn)) attr(res,"diagnostic") <- diagn + if(!is.null(diagn)){ + attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" + } return(res) } @@ -53,7 +59,10 @@ res <- E(object, as(fun, "EuclRandVariable"), useApply = useApply, ..., diagnostic = diagnostic) if(diagnostic) diagn <- attr(res, "diagnostic") res <- matrix(res, nrow = nrow(fun)) - if(!is.null(diagn)) attr(res,"diagnostic") <- diagn + if(!is.null(diagn)){ + attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" + } return(res) } .locElistfun <- function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ @@ -66,7 +75,10 @@ res[[i]] <- buf <- E(object, fun = fun[[i]], useApply = useApply, ..., diagnostic = diagnostic) if(diagnostic) diagn[[i]] <- attr(buf, "diagnostic") } - if(!is.null(diagn)) attr(res,"diagnostic") <- diagn + if(!is.null(diagn)){ + attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" + } return(res) } @@ -107,7 +119,10 @@ withCond = withCond, useApply = useApply, ..., diagnostic = diagnostic) if(diagnostic) diagn <- attr(res, "diagnostic") res <- matrix(res, nrow = nrow(fun)) - if(!is.null(diagn)) attr(res,"diagnostic") <- diagn + if(!is.null(diagn)){ + attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" + } return(res) } @@ -119,7 +134,10 @@ res[[i]] <- buf <- E(object, fun=fun[[i]], cond = cond, withCond = withCond, useApply = useApply, ..., diagnostic = diagnostic) if(diagnostic) diagn[[i]] <- attr(buf, "diagnostic") } - if(!is.null(diagn)) attr(res,"diagnostic") <- diagn + if(!is.null(diagn)){ + attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" + } return(res) } @@ -137,6 +155,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- mc attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -151,6 +170,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -173,6 +193,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -188,6 +209,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -211,6 +233,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -226,6 +249,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -249,6 +273,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -275,6 +300,7 @@ diagn[["call"]] <- match.call() res <- array(res, c(nrow(fun), ncol(fun), fun at Range@dimension)) attr(res, "diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" return(res) } }) @@ -296,6 +322,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -320,6 +347,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -336,6 +364,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -361,6 +390,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -377,6 +407,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -402,6 +433,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) @@ -418,6 +450,7 @@ diagn <- attr(res,"diagnostic") diagn[["call"]] <- match.call() attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) }) Modified: branches/robast-1.2/pkg/RandVar/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RandVar/inst/NEWS 2018-08-16 20:04:10 UTC (rev 1158) +++ branches/robast-1.2/pkg/RandVar/inst/NEWS 2018-08-18 20:28:44 UTC (rev 1159) @@ -22,6 +22,8 @@ which is not yet used. + E methods for RandVariables use filtering of dots arguments (like E()-methods in distrEx v 2.8.0) ++ E methods for RandVariables if (diagnostic==TRUE) return diagnostic attributes + of S3 class "DiagnosticClass" ####################################### version 1.1 Modified: branches/robast-1.2/pkg/RandVar/tests/Examples/RandVar-Ex.Rout.save =================================================================== --- branches/robast-1.2/pkg/RandVar/tests/Examples/RandVar-Ex.Rout.save 2018-08-16 20:04:10 UTC (rev 1158) +++ branches/robast-1.2/pkg/RandVar/tests/Examples/RandVar-Ex.Rout.save 2018-08-18 20:28:44 UTC (rev 1159) @@ -1,6 +1,6 @@ -R Under development (unstable) (2016-04-22 r70532) -- "Unsuffered Consequences" -Copyright (C) 2016 The R Foundation for Statistical Computing +R version 3.5.1 RC (2018-06-24 r74935) -- "Feather Spray" +Copyright (C) 2018 The R Foundation for Statistical Computing Platform: i386-w64-mingw32/i386 (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. @@ -21,52 +21,29 @@ > source(file.path(R.home("share"), "R", "examples-header.R")) > options(warn = 1) > options(pager = "console") +> base::assign(".ExTimings", "RandVar-Ex.timings", pos = 'CheckExEnv') +> base::cat("name\tuser\tsystem\telapsed\n", file=base::get(".ExTimings", pos = 'CheckExEnv')) +> base::assign(".format_ptime", ++ function(x) { ++ if(!is.na(x[4L])) x[1L] <- x[1L] + x[4L] ++ if(!is.na(x[5L])) x[2L] <- x[2L] + x[5L] ++ options(OutDec = '.') ++ format(x[1L:3L], digits = 7L) ++ }, ++ pos = 'CheckExEnv') +> +> ### * > library('RandVar') Loading required package: distr Loading required package: startupmsg -:startupmsg> Utilities for Start-Up Messages (version 0.9.3) +:startupmsg> Utilities for Start-Up Messages (version 0.9.6) :startupmsg> :startupmsg> For more information see ?"startupmsg", :startupmsg> NEWS("startupmsg") Loading required package: sfsmisc -Loading required package: SweaveListingUtils -:SweaveListingUtils> Utilities for Sweave Together with -:SweaveListingUtils> TeX 'listings' Package (version -:SweaveListingUtils> 0.7.3) -:SweaveListingUtils> -:SweaveListingUtils> NOTE: Support for this package -:SweaveListingUtils> will stop soon. -:SweaveListingUtils> -:SweaveListingUtils> Package 'knitr' is providing the -:SweaveListingUtils> same functionality in a better -:SweaveListingUtils> way. -:SweaveListingUtils> -:SweaveListingUtils> Some functions from package 'base' -:SweaveListingUtils> are intentionally masked ---see -:SweaveListingUtils> SweaveListingMASK(). -:SweaveListingUtils> -:SweaveListingUtils> Note that global options are -:SweaveListingUtils> controlled by -:SweaveListingUtils> SweaveListingoptions() ---c.f. -:SweaveListingUtils> ?"SweaveListingoptions". -:SweaveListingUtils> -:SweaveListingUtils> For more information see -:SweaveListingUtils> ?"SweaveListingUtils", -:SweaveListingUtils> NEWS("SweaveListingUtils") -:SweaveListingUtils> There is a vignette to this -:SweaveListingUtils> package; try -:SweaveListingUtils> vignette("ExampleSweaveListingUtils"). - - -Attaching package: 'SweaveListingUtils' - -The following objects are masked from 'package:base': - - library, require - :distr> Object Oriented Implementation of Distributions (version -:distr> 2.6) +:distr> 2.8.0) :distr> :distr> Attention: Arithmetics on distribution objects are :distr> understood as operations on corresponding random variables @@ -92,7 +69,7 @@ df, qqplot, sd Loading required package: distrEx -:distrEx> Extensions of Package 'distr' (version 2.6) +:distrEx> Extensions of Package 'distr' (version 2.8.0) :distrEx> :distrEx> Note: Packages "e1071", "moments", "fBasics" should be :distrEx> attached /before/ package "distrEx". See @@ -115,7 +92,7 @@ IQR, mad, median, var -:RandVar> Implementation of Random Variables (version 1.0) +:RandVar> Implementation of Random Variables (version 1.2.0) :RandVar> :RandVar> For more information see ?"RandVar", NEWS("RandVar"), as :RandVar> well as @@ -125,12 +102,14 @@ > > base::assign(".oldSearch", base::search(), pos = 'CheckExEnv') +> base::assign(".old_wd", base::getwd(), pos = 'CheckExEnv') > cleanEx() > nameEx("0RandVar-package") > ### * 0RandVar-package > > flush(stderr()); flush(stdout()) > +> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: RandVar-package > ### Title: Implementation of Random Variables > ### Aliases: RandVar-package RandVar @@ -143,12 +122,15 @@ > > > +> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") +> base::cat("0RandVar-package", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("EuclRandMatrix-class") > ### * EuclRandMatrix-class > > flush(stderr()); flush(stdout()) > +> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: EuclRandMatrix-class > ### Title: Euclidean random matrix > ### Aliases: EuclRandMatrix-class @@ -215,7 +197,7 @@ } t(f(x)) } - + > > R2 <- EuclRandMatrix(Map = L2, ncol = 2, Domain = Reals(), dimension = 1) @@ -227,10 +209,10 @@ [[2]] Distribution Object of Class: AbscontDistribution [[3]] Distribution Object of Class: AbscontDistribution [[4]] Distribution Object of Class: AbscontDistribution -Warning in function (object) : +Warning in new("standardGeneric", .Data = function (object) : arithmetics on distributions are understood as operations on r.v.'s see 'distrARITH()'; for switching off this warning see '?distroptions' -Warning in function (object) : +Warning in new("standardGeneric", .Data = function (object) : slots d,p,q have been filled using simulations; for switching off this warning see '?distroptions' > plot(DL) > @@ -244,7 +226,7 @@ } gamma(f1(x)) } - + [[2]] function (x) @@ -255,7 +237,7 @@ } gamma(f1(x)) } - + [[3]] function (x) @@ -266,7 +248,7 @@ } gamma(f1(x)) } - + [[4]] function (x) @@ -277,7 +259,7 @@ } gamma(f1(x)) } - + > > ## "Arith" group @@ -291,7 +273,7 @@ } 2/f2(x) } - + [[2]] function (x) @@ -302,7 +284,7 @@ } 2/f2(x) } - + [[3]] function (x) @@ -313,7 +295,7 @@ } 2/f2(x) } - + [[4]] function (x) @@ -324,7 +306,7 @@ } 2/f2(x) } - + [[5]] function (x) @@ -335,7 +317,7 @@ } 2/f2(x) } - + [[6]] function (x) @@ -346,7 +328,7 @@ } 2/f2(x) } - + > Map(R2 * R2) [[1]] @@ -362,7 +344,7 @@ } f1(x) * f2(x) } - + [[2]] function (x) @@ -377,7 +359,7 @@ } f1(x) * f2(x) } - + [[3]] function (x) @@ -392,7 +374,7 @@ } f1(x) * f2(x) } - + [[4]] function (x) @@ -407,17 +389,20 @@ } f1(x) * f2(x) } - + > > > +> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") +> base::cat("EuclRandMatrix-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("EuclRandMatrix") > ### * EuclRandMatrix > > flush(stderr()); flush(stdout()) > +> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: EuclRandMatrix > ### Title: Generating function for EuclRandMatrix-class > ### Aliases: EuclRandMatrix @@ -458,7 +443,7 @@ } t(f(x)) } - + > > R2 <- EuclRandMatrix(Map = L2, ncol = 2, Domain = Reals(), dimension = 1) @@ -468,10 +453,10 @@ [[2]] Distribution Object of Class: AbscontDistribution [[3]] Distribution Object of Class: AbscontDistribution [[4]] Distribution Object of Class: AbscontDistribution -Warning in function (object) : +Warning in new("standardGeneric", .Data = function (object) : arithmetics on distributions are understood as operations on r.v.'s see 'distrARITH()'; for switching off this warning see '?distroptions' -Warning in function (object) : +Warning in new("standardGeneric", .Data = function (object) : slots d,p,q have been filled using simulations; for switching off this warning see '?distroptions' > plot(DL) > @@ -485,7 +470,7 @@ } gamma(f1(x)) } - + [[2]] function (x) @@ -496,7 +481,7 @@ } gamma(f1(x)) } - + [[3]] function (x) @@ -507,7 +492,7 @@ } gamma(f1(x)) } - + [[4]] function (x) @@ -518,7 +503,7 @@ } gamma(f1(x)) } - + > > ## "Arith" group @@ -532,7 +517,7 @@ } 2/f2(x) } - + [[2]] function (x) @@ -543,7 +528,7 @@ } 2/f2(x) } - + [[3]] function (x) @@ -554,7 +539,7 @@ } 2/f2(x) } - + [[4]] function (x) @@ -565,7 +550,7 @@ } 2/f2(x) } - + [[5]] function (x) @@ -576,7 +561,7 @@ } 2/f2(x) } - + [[6]] function (x) @@ -587,7 +572,7 @@ } 2/f2(x) } - + > Map(R2 * R2) [[1]] @@ -603,7 +588,7 @@ } f1(x) * f2(x) } - + [[2]] function (x) @@ -618,7 +603,7 @@ } f1(x) * f2(x) } - + [[3]] function (x) @@ -633,7 +618,7 @@ } f1(x) * f2(x) } - + [[4]] function (x) @@ -648,7 +633,7 @@ } f1(x) * f2(x) } - + > > @@ -686,12 +671,15 @@ > > > +> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") +> base::cat("EuclRandMatrix", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("EuclRandVarList-class") > ### * EuclRandVarList-class > > flush(stderr()); flush(stdout()) > +> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: EuclRandVarList-class > ### Title: List of Euclidean random variables > ### Aliases: EuclRandVarList-class numberOfMaps @@ -766,7 +754,7 @@ } exp(f1(x)) } - + [[2]] function (x) @@ -777,7 +765,7 @@ } exp(f1(x)) } - + [[3]] function (x) @@ -788,7 +776,7 @@ } exp(f1(x)) } - + [[4]] function (x) @@ -799,7 +787,7 @@ } exp(f1(x)) } - + > > ## "Arith" group @@ -813,7 +801,7 @@ } 1 + f2(x) } - + [[2]] function (x) @@ -824,7 +812,7 @@ } 1 + f2(x) } - + [[3]] function (x) @@ -835,7 +823,7 @@ } 1 + f2(x) } - + [[4]] function (x) @@ -846,7 +834,7 @@ } 1 + f2(x) } - + > Map((RL1 * 2)[[2]]) [[1]] @@ -858,7 +846,7 @@ } f1(x) * 2 } - + [[2]] function (x) @@ -869,7 +857,7 @@ } f1(x) * 2 } - + [[3]] function (x) @@ -880,7 +868,7 @@ } f1(x) * 2 } - + [[4]] function (x) @@ -891,7 +879,7 @@ } f1(x) * 2 } - + [[5]] function (x) @@ -902,7 +890,7 @@ } f1(x) * 2 } - + [[6]] function (x) @@ -913,7 +901,7 @@ } f1(x) * 2 } - + > Map((RL1 / RL1)[[3]]) [[1]] @@ -929,7 +917,7 @@ } f1(x)/f2(x) } - + [[2]] function (x) @@ -944,7 +932,7 @@ } f1(x)/f2(x) } - + [[3]] function (x) @@ -959,7 +947,7 @@ } f1(x)/f2(x) } - + [[4]] function (x) @@ -974,17 +962,20 @@ } f1(x)/f2(x) } - + > > > +> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") +> base::cat("EuclRandVarList-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("EuclRandVarList") > ### * EuclRandVarList > > flush(stderr()); flush(stdout()) > +> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: EuclRandVarList > ### Title: Generating function for EuclRandVarList-class > ### Aliases: EuclRandVarList @@ -1040,7 +1031,7 @@ } exp(f1(x)) } - + [[2]] function (x) @@ -1051,7 +1042,7 @@ } exp(f1(x)) } - + [[3]] function (x) @@ -1062,7 +1053,7 @@ } exp(f1(x)) } - + [[4]] function (x) @@ -1073,7 +1064,7 @@ } exp(f1(x)) } - + > > ## "Arith" group @@ -1087,7 +1078,7 @@ } 1 + f2(x) } - + [[2]] function (x) @@ -1098,7 +1089,7 @@ } 1 + f2(x) } - + [[3]] function (x) @@ -1109,7 +1100,7 @@ } 1 + f2(x) } - + [[4]] function (x) @@ -1120,7 +1111,7 @@ } 1 + f2(x) } - + > Map((RL1 * 2)[[2]]) [[1]] @@ -1132,7 +1123,7 @@ } f1(x) * 2 } - + [[2]] function (x) @@ -1143,7 +1134,7 @@ } f1(x) * 2 } - + [[3]] function (x) @@ -1154,7 +1145,7 @@ } f1(x) * 2 } - + [[4]] function (x) @@ -1165,7 +1156,7 @@ } f1(x) * 2 } - + [[5]] function (x) @@ -1176,7 +1167,7 @@ } f1(x) * 2 } - + [[6]] function (x) @@ -1187,7 +1178,7 @@ } f1(x) * 2 } - + > Map((RL1 / RL1)[[3]]) [[1]] @@ -1203,7 +1194,7 @@ } f1(x)/f2(x) } - + [[2]] function (x) @@ -1218,7 +1209,7 @@ } f1(x)/f2(x) } - + [[3]] function (x) @@ -1233,7 +1224,7 @@ } f1(x)/f2(x) } - + [[4]] function (x) @@ -1248,7 +1239,7 @@ } f1(x)/f2(x) } - + > > ## The function is currently defined as @@ -1262,12 +1253,15 @@ > > > +> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") +> base::cat("EuclRandVarList", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("EuclRandVariable-class") > ### * EuclRandVariable-class > > flush(stderr()); flush(stdout()) > +> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: EuclRandVariable-class > ### Title: Euclidean random variable > ### Aliases: EuclRandVariable-class @@ -1449,7 +1443,7 @@ } log(f1(x)) } - + [[2]] function (x) @@ -1464,7 +1458,7 @@ } log(f1(x)) } - + [[3]] function (x) @@ -1479,7 +1473,7 @@ } log(f1(x)) } - + [[4]] function (x) @@ -1494,7 +1488,7 @@ } log(f1(x)) } - + > > # "Arith" group generic @@ -1508,7 +1502,7 @@ } 3 + f2(x) } - + [[2]] function (x) @@ -1519,7 +1513,7 @@ } 3 + f2(x) } - + [[3]] function (x) @@ -1530,7 +1524,7 @@ } 3 + f2(x) } - + [[4]] function (x) @@ -1541,7 +1535,7 @@ } 3 + f2(x) } - + > Map(c(1,3,5) * R1) Warning in c(1, 3, 5) * R1 : @@ -1555,7 +1549,7 @@ } 1 * f2(x) } - + [[2]] function (x) @@ -1566,7 +1560,7 @@ } 3 * f2(x) } - + [[3]] function (x) @@ -1577,7 +1571,7 @@ } 5 * f2(x) } - + [[4]] function (x) @@ -1588,7 +1582,7 @@ } 1 * f2(x) } - + > try(1:5 * R1) # error Error in 1:5 * R1 : @@ -1603,7 +1597,7 @@ } 1:2 * f2(x) } - + [[2]] function (x) @@ -1614,7 +1608,7 @@ } 1:2 * f2(x) } - + [[3]] function (x) @@ -1625,7 +1619,7 @@ } 1:2 * f2(x) } - + [[4]] function (x) @@ -1636,7 +1630,7 @@ } 1:2 * f2(x) } - + > Map(R2 - 5) [[1]] @@ -1648,7 +1642,7 @@ } f1(x) - c(5, 5) } - + [[2]] function (x) @@ -1659,7 +1653,7 @@ } f1(x) - c(5, 5) } - + [[3]] function (x) @@ -1670,7 +1664,7 @@ } f1(x) - c(5, 5) } - + [[4]] function (x) @@ -1681,7 +1675,7 @@ } f1(x) - c(5, 5) } - + > Map(R1 ^ R1) [[1]] @@ -1697,7 +1691,7 @@ } f1(x)^f2(x) } - + [[2]] function (x) @@ -1712,7 +1706,7 @@ } f1(x)^f2(x) } - + [[3]] function (x) @@ -1727,7 +1721,7 @@ } f1(x)^f2(x) } - + [[4]] function (x) @@ -1742,18 +1736,21 @@ } f1(x)^f2(x) } - + > > > > +> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") +> base::cat("EuclRandVariable-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("EuclRandVariable") > ### * EuclRandVariable > > flush(stderr()); flush(stdout()) > +> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: EuclRandVariable > ### Title: Generating function for EuclRandVariable-class > ### Aliases: EuclRandVariable @@ -1902,7 +1899,7 @@ } log(f1(x)) } - + [[2]] function (x) @@ -1917,7 +1914,7 @@ } log(f1(x)) } - + [[3]] function (x) @@ -1932,7 +1929,7 @@ } log(f1(x)) } - + [[4]] function (x) @@ -1947,7 +1944,7 @@ } log(f1(x)) } - + > > # "Arith" group generic @@ -1961,7 +1958,7 @@ } 3 + f2(x) } - + [[2]] function (x) @@ -1972,7 +1969,7 @@ } 3 + f2(x) } - + [[3]] function (x) @@ -1983,7 +1980,7 @@ } 3 + f2(x) } - + [[4]] function (x) @@ -1994,7 +1991,7 @@ } 3 + f2(x) } - + > Map(c(1,3,5) * R1) Warning in c(1, 3, 5) * R1 : @@ -2008,7 +2005,7 @@ } 1 * f2(x) } - + [[2]] function (x) @@ -2019,7 +2016,7 @@ } 3 * f2(x) } - + [[3]] function (x) @@ -2030,7 +2027,7 @@ } 5 * f2(x) } - + [[4]] function (x) @@ -2041,7 +2038,7 @@ } 1 * f2(x) } - + > try(1:5 * R1) # error Error in 1:5 * R1 : @@ -2056,7 +2053,7 @@ } 1:2 * f2(x) } - + [[2]] function (x) @@ -2067,7 +2064,7 @@ } 1:2 * f2(x) } - + [[3]] function (x) @@ -2078,7 +2075,7 @@ } 1:2 * f2(x) } - + [[4]] function (x) @@ -2089,7 +2086,7 @@ } 1:2 * f2(x) } - + > Map(R2 - 5) [[1]] @@ -2101,7 +2098,7 @@ } f1(x) - c(5, 5) } - + [[2]] function (x) @@ -2112,7 +2109,7 @@ } f1(x) - c(5, 5) } - + [[3]] function (x) @@ -2123,7 +2120,7 @@ } f1(x) - c(5, 5) } - + [[4]] function (x) @@ -2134,7 +2131,7 @@ } f1(x) - c(5, 5) } - + > Map(R1 ^ R1) [[1]] @@ -2150,7 +2147,7 @@ } f1(x)^f2(x) } - + [[2]] function (x) @@ -2165,7 +2162,7 @@ } f1(x)^f2(x) } - + [[3]] function (x) @@ -2180,7 +2177,7 @@ } f1(x)^f2(x) } - + [[4]] function (x) @@ -2195,7 +2192,7 @@ } f1(x)^f2(x) } - + > > @@ -2221,12 +2218,15 @@ > > > +> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") +> base::cat("EuclRandVariable", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("RandVariable-class") > ### * RandVariable-class > > flush(stderr()); flush(stdout()) > +> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: RandVariable-class > ### Title: Random variable > ### Aliases: RandVariable-class Map Domain Range compatibleDomains @@ -2250,7 +2250,7 @@ function (x) { } - + > Domain(R1) @@ -2297,12 +2297,15 @@ > > > +> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") +> base::cat("RandVariable-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("RandVariable") > ### * RandVariable > > flush(stderr()); flush(stdout()) > +> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: RandVariable > ### Title: Generating function for RandVariable-class > ### Aliases: RandVariable @@ -2320,7 +2323,7 @@ function (x) { } - + > Domain(R1) NULL @@ -2376,12 +2379,15 @@ > > > +> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") +> base::cat("RandVariable", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("RealRandVariable-class") > ### * RealRandVariable-class > > flush(stderr()); flush(stdout()) > +> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: RealRandVariable-class > ### Title: Real random variable > ### Aliases: RealRandVariable-class Range<-,RealRandVariable-method @@ -2397,12 +2403,15 @@ > > > +> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") +> base::cat("RealRandVariable-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("RealRandVariable") [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/robast -r 1159 From noreply at r-forge.r-project.org Sat Aug 18 22:55:25 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 18 Aug 2018 22:55:25 +0200 (CEST) Subject: [Robast-commits] r1160 - in branches/robast-1.2/pkg/RobAStBase: . R inst man Message-ID: <20180818205525.82BD218ACF9@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-18 22:55:25 +0200 (Sat, 18 Aug 2018) New Revision: 1160 Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimate.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R branches/robast-1.2/pkg/RobAStBase/inst/NEWS branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd branches/robast-1.2/pkg/RobAStBase/man/kStepEstimate-class.Rd branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd Log: [RobAStBase] branch 1.2: + new accessor "timings" to attribute "timings" of an object of class "kStepEstimate" + kStepEstimator, checkIC/makeIC, getRiskIC (for signature (IC, asCov, missing, L2ParamFamily)) and getboundedIC now if (diagnostic==TRUE) return diagnostic attributes of S3 class "DiagnosticClass" Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-18 20:28:44 UTC (rev 1159) +++ branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-18 20:55:25 UTC (rev 1160) @@ -75,7 +75,7 @@ exportMethods("ddPlot", "qqplot", "returnlevelplot") exportMethods("cutoff.quantile", "cutoff.quantile<-") exportMethods("samplesize<-", "samplesize") -exportMethods("getRiskFctBV", "getFiRisk", "getPIC") +exportMethods("getRiskFctBV", "getFiRisk", "getPIC", "timings") export("oneStepEstimator", "kStepEstimator") export("ContNeighborhood", "TotalVarNeighborhood") export("FixRobModel", "InfRobModel") Modified: branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R 2018-08-18 20:28:44 UTC (rev 1159) +++ branches/robast-1.2/pkg/RobAStBase/R/AllGeneric.R 2018-08-18 20:55:25 UTC (rev 1160) @@ -251,3 +251,6 @@ if(!isGeneric("getPIC")){ setGeneric("getPIC", function(estimator) standardGeneric("getPIC")) } +if(!isGeneric("timings")){ + setGeneric("timings", function(object, ...) standardGeneric("timings")) +} Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-18 20:28:44 UTC (rev 1159) +++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-18 20:55:25 UTC (rev 1160) @@ -24,8 +24,10 @@ res[i] <- buf <- do.call(E, Eargs) if(diagnostic){ k <- k + 1; diagn[[k]] <- attr(buf,"diagnostic") } } - if(diagnostic) attr(res, "diagnostic") <- diagn[1:nrvalues] - + if(diagnostic){ + attr(res, "diagnostic") <- diagn[1:nrvalues] + class(attr(res,"diagnostic")) <- "DiagnosticClass" + } erg <- matrix(0, ncol = dims, nrow = nrvalues) for(i in 1:nrvalues) @@ -35,8 +37,10 @@ erg[i, j] <- buf <- do.call(E, Eargs) if(diagnostic){ k <- k + 1; diagn[[k]] <- attr(buf,"diagnostic") } } - if(diagnostic) attr(erg, "diagnostic") <- diagn[-(1:nrvalues)] - + if(diagnostic){ + attr(erg, "diagnostic") <- diagn[-(1:nrvalues)] + class(attr(erg,"diagnostic")) <- "DiagnosticClass" + } return(list(E.IC=res,E.IC.L=erg)) } @@ -83,9 +87,11 @@ print(attr(res$E.IC.L,"diagnostic")) } - if(diagnostic) + if(diagnostic){ attr(prec,"diagnostic") <- c(attr(res$E.IC,"diagnostic"), attr(res$E.IC.L,"diagnostic")) + class(attr(prec,"diagnostic")) <- "DiagnosticClass" + } return(prec) }) @@ -136,9 +142,11 @@ CallL2Fam = CallL2Fam, modifyIC = modifyIC) - if(diagnostic) + if(diagnostic){ attr(IC.0,"diagnostic") <- c(attr(res$E.IC,"diagnostic"), attr(res$E.IC.L,"diagnostic")) + class(attr(IC.0,"diagnostic")) <- "DiagnosticClass" + } return(IC.0) }) Modified: branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-18 20:28:44 UTC (rev 1159) +++ branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-18 20:55:25 UTC (rev 1160) @@ -64,7 +64,10 @@ } Cova[col(Cova) < row(Cova)] <- t(Cova)[col(Cova) < row(Cova)] # if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...) - if(diagnostic) attr(Cova,"diagnostic") <- diagn + if(diagnostic){ + attr(Cova,"diagnostic") <- diagn + class(attr(Cova,"diagnostic")) <- "DiagnosticClass" + } return(list(asCov = list(distribution = .getDistr(L2Fam), value = Cova))) }) Modified: branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-18 20:28:44 UTC (rev 1159) +++ branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-18 20:55:25 UTC (rev 1160) @@ -62,6 +62,9 @@ stand <- as.matrix(D %*% distr::solve(stand.0, generalized = TRUE)) L2w0 <- L2w - cent res <- as(stand %*% L2w0, "EuclRandVariable") - if(diagnostic) attr(res,"diagnostic") <- diagn + if(diagnostic){ + attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" + } return(res) } Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimate.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimate.R 2018-08-18 20:28:44 UTC (rev 1159) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimate.R 2018-08-18 20:55:25 UTC (rev 1160) @@ -26,3 +26,5 @@ colnames(mm) <- paste((1:ncol(mm))-1) return(mm) }) +setMethod("timings", "kStepEstimate", function(object, ...) + attr(object, "timings")) Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-18 20:28:44 UTC (rev 1159) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-18 20:55:25 UTC (rev 1160) @@ -508,7 +508,10 @@ estres <- .checkEstClassForParamFamily(L2Fam,estres) attr(estres,"timings") <- apply(sytm,2,diff) - if(diagnostic) attr(estres,"diagnostic") <- diagn + if(diagnostic){ + attr(estres,"diagnostic") <- diagn + class(attr(estres,"diagnostic")) <- "DiagnosticClass" + } on.exit() return(estres) Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-18 20:28:44 UTC (rev 1159) +++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-18 20:55:25 UTC (rev 1160) @@ -30,6 +30,7 @@ checkIC and makeIC gain argument diagnostic to be able to show diagnostic information on integrations; this information (if argument "diagnostic" is TRUE) is stored in attribute "diagnostic" of the return value ++ accessor "timings" to attribute "timings" of an object of class "kStepEstimate" bugfixes + and a forgotten no longer used instance of oldmodif in kStepEstimator @@ -97,6 +98,9 @@ overwrites existing entries). + getboundedIC now uses coordinate-wise integration with useApply = FALSE and only computing the upper half of E LL'w ++ kStepEstimator, checkIC/makeIC, getRiskIC (for signature (IC, asCov, missing, L2ParamFamily)) + and getboundedIC now if (diagnostic==TRUE) return diagnostic attributes of S3 class + "DiagnosticClass" ####################################### version 1.1 @@ -129,7 +133,6 @@ + getRiskIC and getBiasIC gain argument withCheck to speed up things if one does not want to call checkIC + in kStepEstimator, withCheck is set to FALSE when getRiskIC is called, and makeIC is only called just before the last update, and, if useLast == TRUE for the last update (of course, only if withMakeIC ==TRUE) -+ kStepEstimator, Return value of "roptest" + the return value of "roptest", an object of class "kStepEstimate" has a slot "estimate.call" which Modified: branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd 2018-08-18 20:28:44 UTC (rev 1159) +++ branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd 2018-08-18 20:55:25 UTC (rev 1160) @@ -26,6 +26,12 @@ \details{ The precisions of the centering and the Fisher consistency are computed. + + Diagnostics on the involved integrations are available if argument + \code{diagnostic} is \code{TRUE}. Then there is attribute \code{diagnostic} + attached to the return value, which may be inspected + and accessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{getDiagnostic}}. } \value{The maximum deviation from the IC properties is returned.} \references{ Modified: branches/robast-1.2/pkg/RobAStBase/man/kStepEstimate-class.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/kStepEstimate-class.Rd 2018-08-18 20:28:44 UTC (rev 1159) +++ branches/robast-1.2/pkg/RobAStBase/man/kStepEstimate-class.Rd 2018-08-18 20:55:25 UTC (rev 1160) @@ -20,6 +20,8 @@ \alias{ustartval} \alias{ustartval,kStepEstimate-method} \alias{show,kStepEstimate-method} +\alias{timings} +\alias{timings,kStepEstimate-method} \title{kStepEstimate-class.} \description{Class of asymptotically linear estimates.} @@ -128,11 +130,15 @@ \item{robestCall}{\code{signature(object = "kStepEstimate")}: accessor function for slot \code{robestCall}. } + \item{timings}{\code{signature(object = "kStepEstimate")}: + accessor function for attribute \code{"timings"}. } + \item{show}{\code{signature(object = "kStepEstimate")}: a show method; } } } %\references{} -\author{Matthias Kohl \email{Matthias.Kohl at stamats.de}} +\author{Matthias Kohl \email{Matthias.Kohl at stamats.de} and +Peter Ruckdeschel \email{peter.ruckdeschel at uni-oldenurg.de}} %\note{} \seealso{\code{\link{ALEstimate-class}}} %\examples{} Modified: branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd 2018-08-18 20:28:44 UTC (rev 1159) +++ branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd 2018-08-18 20:55:25 UTC (rev 1160) @@ -86,6 +86,13 @@ Timings for the several substeps are available as attribute \code{timings} of the return value. + + Diagnostics on the involved integrations are available if argument + \code{diagnostic} is \code{TRUE}. Then there is attribute \code{diagnostic} + attached to the return value, which may be inspected + and accessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{getDiagnostic}}. + } \value{Object of class \code{"kStepEstimate"}.} Modified: branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd =================================================================== --- branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd 2018-08-18 20:28:44 UTC (rev 1159) +++ branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd 2018-08-18 20:55:25 UTC (rev 1160) @@ -48,6 +48,24 @@ as attribute \code{diagnostic} of the return value. } } \value{An IC of class \code{"IC"} at the model.} +\details{ + Argument \code{IC} is transformed affinely such that the transformed IC + satisfies the defining side conditions of an IC, i.e., centeredness and + Fisher consistency: + + \deqn{\mathop{\mbox{\boldmath$E$}}[{\rm IC}]=0}{E[IC]=0} + \deqn{\mathop{\mbox{\boldmath$E$}}[{\rm IC}\,\Lambda^\tau]= D}{E[IC Lambda'] = D} + + where \eqn{\Lambda}{Lambda} is the L2 derivative of the model and D is + the Jacobian of transformation \code{trafo}. + + Diagnostics on the involved integrations are available if argument + \code{diagnostic} is \code{TRUE}. Then there is attribute \code{diagnostic} + attached to the return value, which may be inspected + and accessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{getDiagnostic}}. +} + \section{Methods}{\describe{ \item{makeIC}{\code{signature(IC = "IC", L2Fam = "missing"}: creates an object of class \code{"IC"} at the parametric model of its own From noreply at r-forge.r-project.org Sat Aug 18 23:07:33 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 18 Aug 2018 23:07:33 +0200 (CEST) Subject: [Robast-commits] r1161 - in branches/robast-1.2/pkg/ROptEst: . R inst man Message-ID: <20180818210733.6E6CA18ACF8@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-18 23:07:33 +0200 (Sat, 18 Aug 2018) New Revision: 1161 Modified: branches/robast-1.2/pkg/ROptEst/NAMESPACE branches/robast-1.2/pkg/ROptEst/R/AllGeneric.R branches/robast-1.2/pkg/ROptEst/R/roptest.new.R branches/robast-1.2/pkg/ROptEst/inst/NEWS branches/robast-1.2/pkg/ROptEst/man/ORobEstimate-class.Rd branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd branches/robast-1.2/pkg/ROptEst/man/robest.Rd branches/robast-1.2/pkg/ROptEst/man/roptest.Rd Log: [ROptEst] branch 1.2: + new accessors "timings" and "kStepTimings" to attributes "timings" and and "kStepTimings" of an object of class "ORobEstimate" + roptest, robest, and particular checkIC/makeIC methods for ContIC now if (diagnostic==TRUE) return diagnostic attributes of S3 class "DiagnosticClass" + roptest and its wrappers RMX|OBR|MBR|OMSEstimator can now also digest robest-arguments arguments \code{startCtrl}, \code{startICCtrl}, and \code{kStepCtrl}, in which case information in these arguments in case of collision overrides information given through the "usual" arguments; this allows for individual settings of \code{E.argList}, \code{withEvalAsVar}, and \code{withMakeIC} for the different steps. Modified: branches/robast-1.2/pkg/ROptEst/NAMESPACE =================================================================== --- branches/robast-1.2/pkg/ROptEst/NAMESPACE 2018-08-18 20:55:25 UTC (rev 1160) +++ branches/robast-1.2/pkg/ROptEst/NAMESPACE 2018-08-18 21:07:33 UTC (rev 1161) @@ -40,7 +40,7 @@ exportMethods("updateNorm", "scaleUpdateIC", "eff", "get.asGRisk.fct", "getStartIC", "plot", "comparePlot", "getRiskFctBV", "roptestCall", - "checkIC", "makeIC") + "checkIC", "makeIC", "kStepTimings") export("getL2normL2deriv", "asAnscombe", "asL1", "asL4", "getReq", "getMaxIneff", "getRadius") Modified: branches/robast-1.2/pkg/ROptEst/R/AllGeneric.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/AllGeneric.R 2018-08-18 20:55:25 UTC (rev 1160) +++ branches/robast-1.2/pkg/ROptEst/R/AllGeneric.R 2018-08-18 21:07:33 UTC (rev 1161) @@ -93,3 +93,6 @@ if(!isGeneric("roptestCall")){ setGeneric("roptestCall", function(object) standardGeneric("roptestCall")) } +if(!isGeneric("kStepTimings")){ + setGeneric("kStepTimings", function(object, ...) standardGeneric("kStepTimings")) +} Modified: branches/robast-1.2/pkg/ROptEst/R/roptest.new.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-18 20:55:25 UTC (rev 1160) +++ branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-18 21:07:33 UTC (rev 1161) @@ -77,8 +77,16 @@ ##################################################################### setMethod("roptestCall", "ORobEstimate", function(object) object at roptestCall) +setMethod("timings", "ORobEstimate", function(object, withKStep = FALSE ,...){ + if(!withKStep) return(attr(object,"timings")) else{ + return(list(timings = attr(object,"timings"), + kStepTimings = attr(object,"kStepTimings"))) + } +}) +setMethod("timings", "ORobEstimate", function(object,...) attr(object,"kStepTimings")) + roptest <- function(x, L2Fam, eps, eps.lower, eps.upper, fsCor = 1, initial.est, neighbor = ContNeighborhood(), risk = asMSE(), steps = 1L, distance = CvMDist, startPar = NULL, verbose = NULL, @@ -104,12 +112,15 @@ if(diagnostic) if(!missing(E.argList)&&!is.null(E.argList)) E.argList[["diagnostic"]] <- TRUE + if(is.null(dots$startICCtrl)){ startICCtrl <- list() startICCtrl[["withMakeIC"]] <- if(!missing(withMakeIC)) withMakeIC else FALSE startICCtrl[["withEvalAsVar"]] <- if(!missing(withEvalAsVar)) withEvalAsVar else NULL startICCtrl[["modifyICwarn"]] <- if(!missing(modifyICwarn)) modifyICwarn else FALSE startICCtrl[["E.argList"]] <- if(!missing(E.argList)) E.argList else NULL + }else startICCtrl <- dots$startICCtrl + if(is.null(dots$startCtrl)){ startCtrl <- list() if(!missing(initial.est)) startCtrl[["initial.est"]] <- initial.est if(!missing(initial.est.ArgList)) @@ -118,7 +129,9 @@ startCtrl[["distance"]] <- if(!missing(distance)) distance else NULL startCtrl[["withMDE"]] <- if(!missing(withMDE)) withMDE else NULL startCtrl[["E.argList"]] <- if(!missing(E.argList)) E.argList else NULL + }else startCtrl <- dots$startCtrl + if(is.null(dots$kStepCtrl)){ kStepCtrl <- list() kStepCtrl[["useLast"]] <- if(!missing(useLast)) useLast else getRobAStBaseOption("kStepUseLast") kStepCtrl[["withUpdateInKer"]] <- if(!missing(withUpdateInKer)) withUpdateInKer else getRobAStBaseOption("withUpdateInKer") @@ -130,6 +143,7 @@ kStepCtrl[["withEvalAsVar"]] <- if(!missing(withEvalAsVar)) withEvalAsVar else NULL kStepCtrl[["withMakeIC"]] <- if(!missing(withMakeIC)) withMakeIC else FALSE kStepCtrl[["E.argList"]] <- if(!missing(E.argList)) E.argList else NULL + }else kStepCtrl <- dots$kStepCtrl retV <- robest(x=x, L2Fam=L2Fam, fsCor = fsCor, risk = risk, steps = steps, verbose = verbose, @@ -149,8 +163,12 @@ retV <- .checkEstClassForParamFamily(L2Fam,retV) attr(retV,"timings") <- tim attr(retV,"kStepTimings") <- timK - attr(retV,"diagnostic") <- diagn - attr(retV,"kStepDiagnostic") <- kStpDiagn + if(diagnostic){ + attr(retV,"diagnostic") <- diagn + class(attr(retV,"diagnostic")) <- "DiagnosticClass" + attr(retV,"kStepDiagnostic") <- kStpDiagn + class(attr(retV,"kStepDiagnostic")) <- "DiagnosticClass" + } retV at roptestCall <- mc return(retV) } @@ -423,7 +441,11 @@ res at start <- initial.est attr(res, "timings") <- sy attr(res, "kStepTimings") <- sy.OnlykStep - if(diagnostic) attr(res,"kStepDiagnostic") <- kStpDiagn - if(diagnostic) attr(res,"diagnostic") <- diagn + if(diagnostic){ + attr(res,"kStepDiagnostic") <- kStpDiagn + class(attr(res,"kStepDiagnostic")) <- "DiagnosticClass" + attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic")) <- "DiagnosticClass" + } return(res) } Modified: branches/robast-1.2/pkg/ROptEst/inst/NEWS =================================================================== --- branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-18 20:55:25 UTC (rev 1160) +++ branches/robast-1.2/pkg/ROptEst/inst/NEWS 2018-08-18 21:07:33 UTC (rev 1161) @@ -30,10 +30,17 @@ Potential clashes with arguments of the same name in \code{\dots} are resolved by inserting the items of argument list \code{E.argList} as named items, so in case of collisions the item of \code{E.argList} overwrites the existing one from \code{\dots}. ++ roptest and its wrappers RMX|OBR|MBR|OMSEstimator can now also digest robest-arguments + arguments \code{startCtrl}, \code{startICCtrl}, and \code{kStepCtrl}, in which case + information in these arguments in case of collision overrides information given through + the "usual" arguments; this allows for individual settings of \code{E.argList}, + \code{withEvalAsVar}, and \code{withMakeIC} for the different steps. + roptest and its wrappers RMX|OBR|MBR|OMSEstimator, getStartIC for asGRisk, asBias, RMX, and asAnscombe, as well as the particular checkIC/makeIC methods for ContIC gain argument diagnostic to be able to show diagnostic information on integrations; this information (if argument "diagnostic" is TRUE) is stored in attribute "diagnostic" of the return value ++ accessors "timings" and "kStepTimings" to attributes "timings" and and "kStepTimings" + of an object of class "ORobEstimate" bug fixes @@ -81,6 +88,8 @@ than in the default method. This can be overriden by argument forceContICMethod. + the particular checkIC and makeIC methods gain argument diagnostic to be able to show diagnostic information on integrations ++ roptest, robest, and particular checkIC/makeIC methods for ContIC now if (diagnostic==TRUE) + return diagnostic attributes of S3 class "DiagnosticClass" ####################################### Modified: branches/robast-1.2/pkg/ROptEst/man/ORobEstimate-class.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/ORobEstimate-class.Rd 2018-08-18 20:55:25 UTC (rev 1160) +++ branches/robast-1.2/pkg/ROptEst/man/ORobEstimate-class.Rd 2018-08-18 21:07:33 UTC (rev 1161) @@ -21,6 +21,9 @@ \alias{ustartval} \alias{ustartval,ORobEstimate-method} \alias{show,ORobEstimate-method} +\alias{timings,ORobEstimate-method} +\alias{kStepTimings} +\alias{kStepTimings,ORobEstimate-method} \title{ORobEstimate-class.} \description{Class of optimally robust asymptotically linear estimates.} @@ -137,6 +140,17 @@ \item{roptestCall}{\code{signature(object = "ORobEstimate")}: accessor function for slot \code{roptestCall}. } + \item{timings}{\code{signature(object = "ORobEstimate")}: + accessor function for attribute \code{"timings"}. + with additional argument \code{withKStep} defaulting to \code{FALSE}; + in case argument \code{withKStep==TRUE}, the return value is a list + with items \code{timings} and \code{kStepTimings} combining the + two timing informaion attributes. + } + + \item{kSteptimings}{\code{signature(object = "ORobEstimate")}: + accessor function for attribute \code{"timings"}. } + \item{show}{\code{signature(object = "ORobEstimate")}: a show method; [*]} } } Modified: branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd 2018-08-18 20:55:25 UTC (rev 1160) +++ branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd 2018-08-18 21:07:33 UTC (rev 1161) @@ -199,6 +199,21 @@ in attributes \code{timings}, and for the step of the \code{kStepEstimator} in \code{kStepTimings}. + One may also use the arguments \code{startCtrl}, \code{startICCtrl}, and + \code{kStepCtrl} of function \code{\link{robest}}. This allows for individual + settings of \code{E.argList}, \code{withEvalAsVar}, and + \code{withMakeIC} for the different steps. If any of the three arguments + \code{startCtrl}, \code{startICCtrl}, and \code{kStepCtrl} is used, the + respective attributes set in the correspondig argument are used and, if + colliding with arguments directly passed to the estimator function, the directly + passed ones are ignored. + + Diagnostics on the involved integrations are available if argument + \code{diagnostic} is \code{TRUE}. Then there are attributes \code{diagnostic} + and \code{kStepDiagnostic} attached to the return value, which may be inspected + and assessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{getDiagnostic}}. + } \value{Object of class \code{"kStepEstimate"}. In addition, it has an attribute \code{"timings"} where computation time is stored.} Modified: branches/robast-1.2/pkg/ROptEst/man/robest.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/robest.Rd 2018-08-18 20:55:25 UTC (rev 1160) +++ branches/robast-1.2/pkg/ROptEst/man/robest.Rd 2018-08-18 21:07:33 UTC (rev 1161) @@ -68,6 +68,12 @@ \code{\link[=inputGenerators]{genstartCtrl}}, \code{\link[=inputGenerators]{genstartICCtrl}}, and \code{\link[=inputGenerators]{kStepCtrl}} + + Diagnostics on the involved integrations are available if argument + \code{diagnostic} is \code{TRUE}. Then there are attributes \code{diagnostic} + and \code{kStepDiagnostic} attached to the return value, which may be inspected + and assessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{getDiagnostic}}. } \value{Object of class \code{"kStepEstimate"}. In addition, it has an attribute \code{"timings"} where computation time is stored.} Modified: branches/robast-1.2/pkg/ROptEst/man/roptest.Rd =================================================================== --- branches/robast-1.2/pkg/ROptEst/man/roptest.Rd 2018-08-18 20:55:25 UTC (rev 1160) +++ branches/robast-1.2/pkg/ROptEst/man/roptest.Rd 2018-08-18 21:07:33 UTC (rev 1161) @@ -204,6 +204,20 @@ in attributes \code{timings}, and for the step of the \code{kStepEstimator} in \code{kStepTimings}. + One may also use the arguments \code{startCtrl}, \code{startICCtrl}, and + \code{kStepCtrl} of function \code{\link{robest}}. This allows for individual + settings of \code{E.argList}, \code{withEvalAsVar}, and + \code{withMakeIC} for the different steps. If any of the three arguments + \code{startCtrl}, \code{startICCtrl}, and \code{kStepCtrl} is used, the + respective attributes set in the correspondig argument are used and, if + colliding with arguments directly passed to \code{roptest}, the directly + passed ones are ignored. + + Diagnostics on the involved integrations are available if argument + \code{diagnostic} is \code{TRUE}. Then there are attributes \code{diagnostic} + and \code{kStepDiagnostic} attached to the return value, which may be inspected + and assessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{getDiagnostic}}. } \value{Object of class \code{"kStepEstimate"}. In addition, it has an attribute \code{"timings"} where computation time is stored.} From noreply at r-forge.r-project.org Sat Aug 18 23:27:19 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 18 Aug 2018 23:27:19 +0200 (CEST) Subject: [Robast-commits] r1162 - branches/robast-1.2/pkg/RobAStBase/R Message-ID: <20180818212720.09FCB18ACB9@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-18 23:27:19 +0200 (Sat, 18 Aug 2018) New Revision: 1162 Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R Log: [RobAStBase] branch 1.2 + some additional safety layer: check if diagnostic slot is not NULL before assigning a class to it Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-18 21:07:33 UTC (rev 1161) +++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-18 21:27:19 UTC (rev 1162) @@ -26,7 +26,7 @@ } if(diagnostic){ attr(res, "diagnostic") <- diagn[1:nrvalues] - class(attr(res,"diagnostic")) <- "DiagnosticClass" + if(!is.null(diagn)) class(attr(res,"diagnostic")) <- "DiagnosticClass" } erg <- matrix(0, ncol = dims, nrow = nrvalues) @@ -39,7 +39,7 @@ } if(diagnostic){ attr(erg, "diagnostic") <- diagn[-(1:nrvalues)] - class(attr(erg,"diagnostic")) <- "DiagnosticClass" + if(!is.null(diagn)) class(attr(erg,"diagnostic")) <- "DiagnosticClass" } return(list(E.IC=res,E.IC.L=erg)) } @@ -90,7 +90,8 @@ if(diagnostic){ attr(prec,"diagnostic") <- c(attr(res$E.IC,"diagnostic"), attr(res$E.IC.L,"diagnostic")) - class(attr(prec,"diagnostic")) <- "DiagnosticClass" + if(!is.null(attr(prec,"diagnostic"))) + class(attr(prec,"diagnostic")) <- "DiagnosticClass" } return(prec) }) @@ -145,7 +146,8 @@ if(diagnostic){ attr(IC.0,"diagnostic") <- c(attr(res$E.IC,"diagnostic"), attr(res$E.IC.L,"diagnostic")) - class(attr(IC.0,"diagnostic")) <- "DiagnosticClass" + if(!is.null(attr(IC.0,"diagnostic"))) + class(attr(IC.0,"diagnostic")) <- "DiagnosticClass" } return(IC.0) }) Modified: branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-18 21:07:33 UTC (rev 1161) +++ branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-18 21:27:19 UTC (rev 1162) @@ -66,7 +66,8 @@ # if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...) if(diagnostic){ attr(Cova,"diagnostic") <- diagn - class(attr(Cova,"diagnostic")) <- "DiagnosticClass" + if(!is.null(attr(Cova,"diagnostic"))) + class(attr(Cova,"diagnostic")) <- "DiagnosticClass" } return(list(asCov = list(distribution = .getDistr(L2Fam), value = Cova))) }) Modified: branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-18 21:07:33 UTC (rev 1161) +++ branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-18 21:27:19 UTC (rev 1162) @@ -64,7 +64,8 @@ res <- as(stand %*% L2w0, "EuclRandVariable") if(diagnostic){ attr(res,"diagnostic") <- diagn - class(attr(res,"diagnostic")) <- "DiagnosticClass" + if(!is.null(attr(res,"diagnostic"))) + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) } Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-18 21:07:33 UTC (rev 1161) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-18 21:27:19 UTC (rev 1162) @@ -510,7 +510,8 @@ attr(estres,"timings") <- apply(sytm,2,diff) if(diagnostic){ attr(estres,"diagnostic") <- diagn - class(attr(estres,"diagnostic")) <- "DiagnosticClass" + if(!is.null(diagn)) + class(attr(estres,"diagnostic")) <- "DiagnosticClass" } on.exit() return(estres) From noreply at r-forge.r-project.org Sat Aug 18 23:32:10 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 18 Aug 2018 23:32:10 +0200 (CEST) Subject: [Robast-commits] r1163 - branches/robast-1.2/pkg/ROptEst/R Message-ID: <20180818213210.BFA3E18ACFA@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-18 23:32:10 +0200 (Sat, 18 Aug 2018) New Revision: 1163 Modified: branches/robast-1.2/pkg/ROptEst/R/roptest.new.R Log: [ROptEst] branch 1.2 + some additional safety layer: check if diagnostic slot is not NULL before assigning a class to it Modified: branches/robast-1.2/pkg/ROptEst/R/roptest.new.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-18 21:27:19 UTC (rev 1162) +++ branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-18 21:32:10 UTC (rev 1163) @@ -157,7 +157,7 @@ tim <- attr(retV,"timings") timK <- attr(retV,"kStepTimings") diagn <- attr(retV,"diagnostic") - kStpDiagn <- attr(retV,"kStepDiagnostic") + kStepDiagn <- attr(retV,"kStepDiagnostic") retV <- as(as(retV,"kStepEstimate"), "ORobEstimate") retV <- .checkEstClassForParamFamily(L2Fam,retV) @@ -165,9 +165,11 @@ attr(retV,"kStepTimings") <- timK if(diagnostic){ attr(retV,"diagnostic") <- diagn - class(attr(retV,"diagnostic")) <- "DiagnosticClass" - attr(retV,"kStepDiagnostic") <- kStpDiagn - class(attr(retV,"kStepDiagnostic")) <- "DiagnosticClass" + if(!is.null(attr(retV,"diagnostic"))) + class(attr(retV,"diagnostic")) <- "DiagnosticClass" + attr(retV,"kStepDiagnostic") <- kStepDiagn + if(!is.null(attr(retV,"kStepDiagnostic"))) + class(attr(retV,"kStepDiagnostic")) <- "DiagnosticClass" } retV at roptestCall <- mc return(retV) @@ -407,7 +409,7 @@ res <- do.call(kStepEstimator, kStepArgList) }) sy.OnlykStep <- attr(res,"timings") - kStpDiagn <- attr(res,"diagnostic") + kStepDiagn <- attr(res,"diagnostic") if (withTimings) print(sy.kStep) if (withTimings && !is.null(sy.OnlykStep)) print(sy.OnlykStep) if(!debug){ @@ -442,10 +444,12 @@ attr(res, "timings") <- sy attr(res, "kStepTimings") <- sy.OnlykStep if(diagnostic){ - attr(res,"kStepDiagnostic") <- kStpDiagn - class(attr(res,"kStepDiagnostic")) <- "DiagnosticClass" + attr(res,"kStepDiagnostic") <- kStepDiagn + if(!is.null(attr(res,"kStepDiagnostic"))) + class(attr(res,"kStepDiagnostic")) <- "DiagnosticClass" attr(res,"diagnostic") <- diagn - class(attr(res,"diagnostic")) <- "DiagnosticClass" + if(!is.null(attr(res,"diagnostic"))) + class(attr(res,"diagnostic")) <- "DiagnosticClass" } return(res) } From noreply at r-forge.r-project.org Sun Aug 19 01:35:04 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 19 Aug 2018 01:35:04 +0200 (CEST) Subject: [Robast-commits] r1164 - branches/robast-1.2/pkg/RobAStBase/R Message-ID: <20180818233504.3E7D618AD16@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-19 01:35:03 +0200 (Sun, 19 Aug 2018) New Revision: 1164 Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R Log: [RobAStBase] branch 1.2 + some unwanted attributes deleted in checkIC + some cleaning in prints there + in kStepEstimator.R we now call getRiskIC makeIC and getboundedIC with explicit argument diagnostics Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-18 21:32:10 UTC (rev 1163) +++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-18 23:35:03 UTC (rev 1164) @@ -66,11 +66,13 @@ res <- .preparedirectCheckMakeIC(L2Fam, IC, ..., diagnostic = diagnostic) cent <- res$E.IC + attr(cent,"diagnostic") <- NULL if(out) cat("precision of centering:\t", cent, "\n") consist <- res$E.IC.L - trafo + attr(consist,"diagnostic") <- NULL if(out){ cat("precision of Fisher consistency:\n") @@ -83,8 +85,8 @@ names(prec) <- "maximum deviation" if(diagnostic && out){ - print(attr(res$E.IC,"diagnostic")) - print(attr(res$E.IC.L,"diagnostic")) + print(attr(res$E.IC,"diagnostic"),xname="E.IC") + print(attr(res$E.IC.L,"diagnostic"),xname="E.IC.L") } if(diagnostic){ @@ -114,8 +116,8 @@ res <- .preparedirectCheckMakeIC(L2Fam, IC, ..., diagnostic = diagnostic) if(diagnostic){ - print(attr(res$E.IC,"diagnostic")) - print(attr(res$E.IC.L,"diagnostic")) + print(attr(res$E.IC,"diagnostic"), xname="E.IC") + print(attr(res$E.IC.L,"diagnostic"), xname="E.IC.L") } IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable") @@ -195,10 +197,10 @@ mc0$Curve <- EuclRandVarList(RealRandVariable(Map = list(IC.1), Domain = Reals())) mc0$CallL2Fam <- substitute(L2Fam at fam.call) - print(mc0) +# print(mc0) IC.0 <- do.call(.IC,mc0) - print(IC.0) +# print(IC.0) if(forceIC) IC.0 <- makeIC(IC.0, L2Fam,...) return(IC.0) }) Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R =================================================================== --- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-18 21:32:10 UTC (rev 1163) +++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-18 23:35:03 UTC (rev 1164) @@ -202,7 +202,7 @@ sytm <<- .addTime(sytm,mmPreICNm) if(diagnostic) diagn[[mmPreICNm]] <<- attr(IC,"diagnostic") if(steps==1L && withMakeIC){ - makeICargs <- c(list(IC, L2Fam),E.argList) + makeICargs <- list(IC, L2Fam, diagnostic=diagnostic, E.argList=E.argList) IC <- do.call(makeIC, makeICargs) mmPreMkICNm <- paste("modifyIC-makeIC-",updStp) sytm <<- .addTime(sytm,mmPreMkICNm) @@ -231,7 +231,7 @@ if(!is.null(IC.UpdateInKer)&&!is(IC.UpdateInKer,"IC")) warning("'IC.UpdateInKer' is not of class 'IC'; we use default instead.") if(is.null(IC.UpdateInKer)){ - getBoundedICargs <- c(list(L2Fam, D = projker),E.argList) + getBoundedICargs <- list(L2Fam, D = projker, diagnostic=diagnostic,E.argList=E.argList) IC.tot2 <- do.call(getBoundedIC, getBoundedICargs) mmgtBDICNm <- paste("getBoundedIC-",updStp) sytm <<- .addTime(sytm,mmgtBDICNm) @@ -359,7 +359,7 @@ IC <- upd$IC L2Fam <- upd$L2Fam if((i==steps)&&withMakeIC){ - makeICargs <- c(list(IC, L2Fam),E.argList) + makeICargs <- list(IC, L2Fam, diagnostic=diagnostic, E.argList=E.argList) IC <- do.call(makeIC, makeICargs) mkICnm <- paste("makeIC-",i) sytm <- .addTime(sytm,mkICnm) @@ -402,7 +402,7 @@ Infos <- rbind(Infos, c("kStepEstimator", "computation of IC, trafo, asvar and asbias via useLast = TRUE")) if(withMakeIC){ - makeICargs <- c(list(IC, L2Fam),E.argList) + makeICargs <- list(IC, L2Fam, diagnostic=diagnostic, E.argList=E.argList) IC <- do.call(makeIC, makeICargs) mkICULnm <- paste("makeIC-useLast") sytm <- .addTime(sytm,mkICULnm) @@ -450,7 +450,8 @@ asVar <- if(is.matrix(Risks(IC)$asCov) || length(Risks(IC)$asCov) == 1) Risks(IC)$asCov else Risks(IC)$asCov$value }else{ - getRiskICasVarArgs <- c(list(IC, risk = asCov(), withCheck = FALSE),E.argList) + getRiskICasVarArgs <- list(IC, risk = asCov(), withCheck = FALSE, + diagnostic=diagnostic, E.argList = E.argList) riskAsVar <- do.call(getRiskIC, getRiskICasVarArgs) asVar <- riskAsVar$asCov$value sytm <- .addTime(sytm,"getRiskIC-Var") From noreply at r-forge.r-project.org Sun Aug 19 01:37:17 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 19 Aug 2018 01:37:17 +0200 (CEST) Subject: [Robast-commits] r1165 - branches/robast-1.2/pkg/ROptEst/R Message-ID: <20180818233717.8282218AD16@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-19 01:37:17 +0200 (Sun, 19 Aug 2018) New Revision: 1165 Modified: branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R branches/robast-1.2/pkg/ROptEst/R/roptest.new.R Log: [ROptEst] branch 1.2. +removed capsulating quote(.) from res at esimtate.call +typo as to method kStepTimings Modified: branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R 2018-08-18 23:35:03 UTC (rev 1164) +++ branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R 2018-08-18 23:37:17 UTC (rev 1165) @@ -39,7 +39,7 @@ if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est res <- do.call(roptest, roptestArgList) - res at roptestCall <- quote(res at estimate.call) + res at roptestCall <- res at estimate.call res at estimate.call <- mc return(res) } @@ -87,7 +87,7 @@ if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est res <- do.call(roptest, roptestArgList) - res at roptestCall <- quote(res at estimate.call) + res at roptestCall <- res at estimate.call res at estimate.call <- mc return(res) } @@ -131,7 +131,7 @@ if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est res <- do.call(roptest, roptestArgList) - res at roptestCall <- quote(res at estimate.call) + res at roptestCall <- res at estimate.call res at estimate.call <- mc return(res) } @@ -177,7 +177,7 @@ if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est res <- do.call(roptest, roptestArgList) - res at roptestCall <- quote(res at estimate.call) + res at roptestCall <- res at estimate.call res at estimate.call <- mc return(res) Modified: branches/robast-1.2/pkg/ROptEst/R/roptest.new.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-18 23:35:03 UTC (rev 1164) +++ branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-18 23:37:17 UTC (rev 1165) @@ -83,7 +83,7 @@ kStepTimings = attr(object,"kStepTimings"))) } }) -setMethod("timings", "ORobEstimate", function(object,...) attr(object,"kStepTimings")) +setMethod("kStepTimings", "ORobEstimate", function(object,...) attr(object,"kStepTimings")) From noreply at r-forge.r-project.org Sun Aug 19 01:49:28 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 19 Aug 2018 01:49:28 +0200 (CEST) Subject: [Robast-commits] r1166 - in branches/robast-1.2/pkg: ROptEst/R RobExtremes/inst/scripts RobExtremes/man Message-ID: <20180818234928.2D57618AD0A@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-19 01:49:27 +0200 (Sun, 19 Aug 2018) New Revision: 1166 Modified: branches/robast-1.2/pkg/ROptEst/R/roptest.new.R branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R branches/robast-1.2/pkg/RobExtremes/man/E.Rd Log: [RobExtremes] + adopted the script to the new diagnostic functionality + documented that E methods if (diagnostic==TRUE) return diagnostic attributes of S3 class "DiagnosticClass" [ROptEst] + forgot to call kStepEstimator from roptest with argument diagnostic Modified: branches/robast-1.2/pkg/ROptEst/R/roptest.new.R =================================================================== --- branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-18 23:37:17 UTC (rev 1165) +++ branches/robast-1.2/pkg/ROptEst/R/roptest.new.R 2018-08-18 23:49:27 UTC (rev 1166) @@ -401,7 +401,7 @@ na.rm = na.rm, scalename = kStepCtrl$scalename, withLogScale = kStepCtrl$withLogScale, withEvalAsVar = withEvalAsVarkStep, - withMakeIC = withMakeICkStep) + withMakeIC = withMakeICkStep, diagnostic = diagnostic) if(!is.null(kStepCtrl$E.arglist)){ nms <- names(kStepCtrl$E.arglist) for(nmi in nms) kStepArgList[[nmi]] <- kStepCtrl$E.arglist[[nmi]] Modified: branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R =================================================================== --- branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-18 23:37:17 UTC (rev 1165) +++ branches/robast-1.2/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R 2018-08-18 23:49:27 UTC (rev 1166) @@ -7,8 +7,8 @@ require(fitdistrplus) ## for dataset groundbeef -help(package="RobExtremes") -help("RobExtremes-package") +#help(package="RobExtremes") +#help("RobExtremes-package") #---------------------------------------- ## data sets @@ -46,6 +46,17 @@ system.time(MBRi <- MBREstimator(portpiriei, GEVFam)) ## synonymous to ## system.time(MBRi0 <- roptest(portpiriei, GEVFam,risk=MBRRisk())) + +## some diagnostics as to timings and integrations: +system.time(MBRiD <- MBREstimator(portpiriei, GEVFam, diagnostic = TRUE)) +showDiagnostic(MBRiD) +timings(MBRiD) +kStepTimings(MBRiD) +(int.times <- getDiagnostic(MBRiD, what="time")) + +IC <- pIC(MBRiD) +es <- checkIC(IC,diagnostic = TRUE) + system.time(RMXi <- RMXEstimator(portpiriei, GEVFam)) ## synonymous to ## system.time(RMXi <- roptest(portpiriei, GEVFam,risk=RMXRRisk())) @@ -61,7 +72,7 @@ system.time(RMXiw2 <- RMXEstimator(portpiriei, GEVFam,withMakeIC=TRUE)) checkIC(pIC(RMXiw2)) setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"),oldM) -getMethod("checkIC", signature(IC = "IC", L2Fam = "missing"))(pIC(RMXiw2), +erg <- getMethod("checkIC", signature(IC = "IC", L2Fam = "missing"))(pIC(RMXiw2), out=TRUE, diagnostic=TRUE) estimate(RMXi) @@ -80,9 +91,6 @@ estimate(MBRi) estimate(RMXi) estimate(RMXiw) -### where do the robust estimators spend their time? -attr(MBRi, "timings") -attr(MBRi, "kStepTimings") ## our return values can be plugged into ismev-diagnostics: devNew() Modified: branches/robast-1.2/pkg/RobExtremes/man/E.Rd =================================================================== --- branches/robast-1.2/pkg/RobExtremes/man/E.Rd 2018-08-18 23:37:17 UTC (rev 1165) +++ branches/robast-1.2/pkg/RobExtremes/man/E.Rd 2018-08-18 23:49:27 UTC (rev 1166) @@ -70,6 +70,13 @@ classes \code{"GPareto"}, \code{"Pareto"}, \code{"Weibull"}, \code{"GEV"}. In addition, the specific method for \code{"GPareto", "function", "missing"} uses integration on [0,1] via the substitution method (y := log(x)). + + Diagnostics on the involved integrations are available + if argument \code{diagnostic} is \code{TRUE}. Then there is attribute + \code{diagnostic} attached to the return value, which may be inspected + and accessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{getDiagnostic}}. + } \value{