[Robast-commits] r1282 - pkg/ROptEst/R

[noreply at r-forge.r-project.org]

Author: ruckdeschel
Date: 2024-02-06 21:29:39 +0100 (Tue, 06 Feb 2024)
New Revision: 1282

Modified:
   pkg/ROptEst/R/LowerCaseMultivariate.R
   pkg/ROptEst/R/leastFavorableRadius.R
Log:
[ROptEst] trunk: in zero searches through uniroot, which may or may not converge (the code has always handled the case if not), we replaced local settings of options$warn to -1 by wrappings to suppressWarnings()

Modified: pkg/ROptEst/R/LowerCaseMultivariate.R
===================================================================
--- pkg/ROptEst/R/LowerCaseMultivariate.R	2024-02-06 20:27:32 UTC (rev 1281)
+++ pkg/ROptEst/R/LowerCaseMultivariate.R	2024-02-06 20:29:39 UTC (rev 1282)
@@ -20,7 +20,14 @@
 
         force(normtype)
         lA.comp <- sum(A.comp)
-        
+        A.symm <- (nrow(trafo)==ncol(trafo)) && isTRUE(all.equal(trafo,t(trafo)))
+		
+		if(A.symm){
+		   A.comp.s <- t(A.comp)|A.comp
+		   A.comp <- A.com.s[col(A.com.s)>=row(A.com.s)]
+		   lA.comp <- sum(A.comp.so)
+		}
+			        
         abs.fct <- function(x, L2, stand, cent, normtype.0){
             X <- evalRandVar(L2, as.matrix(x))[,,1] - cent
             Y <- stand %*% X
@@ -28,13 +35,14 @@
         }
 
         itermin <- 0
-        bmin.fct <- function(param, L2deriv, Distr, trafo){
+        bmin.fct <- function(param, L2deriv, Distr, trafo, A.symm = TRUE){
             itermin <<- itermin + 1
             p <- nrow(trafo)
             k <- ncol(trafo)
             A <- matrix(0, ncol = k, nrow = p)
             
-            A[A.comp] <- param[1:lA.comp]
+  	        A[A.comp] <- param[1:1A.comp]
+            if(A.symm) A[col(A)>row(A)] <- t(A)[col(A)>row(A)]
             A.max <- max(abs(A.comp))
             A <- A/A.max
             z <- numeric(k)

Modified: pkg/ROptEst/R/leastFavorableRadius.R
===================================================================
--- pkg/ROptEst/R/leastFavorableRadius.R	2024-02-06 20:27:32 UTC (rev 1281)
+++ pkg/ROptEst/R/leastFavorableRadius.R	2024-02-06 20:29:39 UTC (rev 1282)
@@ -38,9 +38,6 @@
                 upRad <- r/rho
                 lower <- ifelse(identical(all.equal(loRad, 0), TRUE), 1e-4, loRad)
                 upper <- ifelse(upRad == Inf, 10, upRad)
-                ow <- options("warn")
-                on.exit(options(ow))
-                options(warn = -1)
                 .getRisk <- function(rad, fac = 1){
                     neighbor at radius <- rad
                     res <- getInfRobIC(L2deriv = L2Fam at L2derivDistr[[1]],
@@ -101,10 +98,12 @@
                      if(loRad>0){
                         args.Ie$loRad <- lower; args.Ie$loRisk <- .getRisk(lower)
                      }
-                     leastFavR <- try(
+                     suppressWarnings(
+					 leastFavR <- try(
                          uniroot(fct.Ie, lower = lower, upper = upper,
                          tol = .Machine$double.eps^0.25)$root, silent = TRUE)
-                     isE <- is(leastFavR, "try-error")
+                     )
+					 isE <- is(leastFavR, "try-error")
                      if(isE) print(conditionMessage(attr(leastFavR,"condition")))
                    }
                    if(isE)
@@ -113,7 +112,6 @@
                         upper, "] after", warnRund, "iterations."))
                 }
 
-                options(ow)
                 cat("current radius:\t", r, "\tinefficiency:\t", ineff, "\n")
                 return(ineff)
             }
@@ -159,10 +157,7 @@
                     upRad <- r/rho
                     lower <- ifelse(identical(all.equal(loRad, 0), TRUE), 1e-4, loRad)
                     upper <- ifelse(upRad == Inf, 10, upRad)
-                    ow <- options("warn")
-                    on.exit(options(ow))
-                    options(warn = -1)
-
+                    
                     .getRisk <- function(rad, fac = 1){
                         neighbor at radius <- rad
                         getInfRobICArgs <- c(list(L2deriv = L2deriv, neighbor = neighbor,
@@ -253,9 +248,10 @@
                             args.Ie$upRad <- upper; rL <- .getRisk(upper)
                             args.Ie$upRisk <- rL$Risk; args.Ie$upNorm <- rL$Norm
                          }
-                         leastFavR <- try(
+                         suppressWarnings(
+						 leastFavR <- try(
                              uniroot(fct.Ie, lower = lower, upper = upper,
-                             tol = .Machine$double.eps^0.25)$root, silent = TRUE)
+                             tol = .Machine$double.eps^0.25)$root, silent = TRUE))
                          isE <- is(leastFavR, "try-error")
                          if(isE) print(conditionMessage(attr(leastFavR,"condition")))
                        }
@@ -264,8 +260,7 @@
                        else warning(paste("Had to modify radius bounds to [", lower,
                             upper, "] after", warnRund, "iterations."))
                     }
-                    options(ow)
-
+                    
                     if(verbose)
                        cat(paste(rep("-",75), sep = "", collapse = ""),"\n")
                     cat("current radius:   ", round(r,4),