[Robast-commits] r881 - branches/robast-1.0/pkg/RobAStBase/R

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

Author: ruckdeschel
Date: 2016-09-01 15:30:41 +0200 (Thu, 01 Sep 2016)
New Revision: 881

Modified:
   branches/robast-1.0/pkg/RobAStBase/R/00internal.R
Log:
code borrowed inserted

Modified: branches/robast-1.0/pkg/RobAStBase/R/00internal.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/00internal.R	2016-09-01 13:19:20 UTC (rev 880)
+++ branches/robast-1.0/pkg/RobAStBase/R/00internal.R	2016-09-01 13:30:41 UTC (rev 881)
@@ -6,6 +6,52 @@
     paste(format(100 * probs, trim = TRUE, scientific = FALSE, digits = digits),
     "%")
 
+.DistrCollapse <- function(support, prob,
+                              eps = getdistrOption("DistrResolution")){
+    supp <- support
+    prob <- as.vector(prob)
+    suppIncr <- diff(c(supp[1]-2*eps,supp)) < eps
+    groups <- cumsum(!suppIncr)
+    prob <- as.vector(tapply(prob, groups, sum))
+    supp0 <- as.vector(tapply(supp, groups, quantile, probs = 0.5, type = 1))
+    reps <- .getRefIdx(supp,supp0,eps)   
+#     cat("III\n")
+#     print(length(reps))
+#     print(length(supp0)) 
+#     cat("III\n")
+           ### in order to get a "support member" take the leftmost median
+    return(list(supp = supp0, prob = prob, groups=groups, reps = reps))
+#    newDistribution <- DiscreteDistribution(supp=supp,prob=prob)
+#    return(newDistribution)
+}
+
+.getRefIdx <- function(x,y, eps = getdistrOption("DistrResolution")){
+    ## x and y are sorted; y=unique(x) (modulo rounding)
+    ## wI gives the first index in x such that x is representing the group 
+    wI <- y*0
+    j <- 1
+    rmin <- Inf
+    for(i in 1:length(wI)){
+        again <- TRUE
+        while(again&&j<=length(x)){
+          rmina <- abs(x[j]-y[i])
+          if(rmina< rmin-eps){
+             rmin <- rmina
+             wI[i] <- j
+          }else{
+             if(rmina>rmin+eps){
+                rmin <-  Inf
+                again <- FALSE
+                j <- j-1
+             }   
+          }
+        j <- j + 1
+        }     
+    }
+    if(wI[i] == 0) wI[i] <- length(x)    
+    return(wI)
+}
+
 #------------------------------------------------------------------------------
 ### for distrXXX pre 2.5
 #------------------------------------------------------------------------------