# R/00internal.R In RobAStBase: Robust Asymptotic Statistics

#### Defines functions panel.minglegetRefIdxDistrCollapseformat.perc

```#------------------------------------------------------------------------------
# .format.perc : for formatting percentages
#------------------------------------------------------------------------------
### code borrowed from non-exported code from confint.default from package stats
.format.perc <- function (probs, digits)
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
#------------------------------------------------------------------------------

if(packageVersion("distr")<"2.5"){

.inArgs <- function(arg, fct)
{as.character(arg) %in% names(formals(fct))}

.fillList <- function(list0, len = length(list0)){
if(is.null(list0)) return(vector("list",len))
if(!is.list(list0)) list0 <- list(list0)
if(len == length(list0))
return(list0)
i <- 0
ll0 <- length(list0)
li0 <- vector("list",len)
if(ll0)
while(i < len){
j <- 1 + ( i %% ll0)
i <- i + 1
li0[[i]] <- list0[[j]]
}
return(li0)
}

.ULC.cast <- function(x){
if( is(x,"AbscontDistribution"))
x <- as(as(x,"AbscontDistribution"), "UnivarLebDecDistribution")
if(is(x,"DiscreteDistribution"))
x <- as(as(x,"DiscreteDistribution"), "UnivarLebDecDistribution")
if(!is(x,"UnivarLebDecDistribution"))
x <- as(x,"UnivarLebDecDistribution")
return(x)
}

.isEqual <- function(p0, p1, tol = min( getdistrOption("TruncQuantile")/2,
.Machine\$double.eps^.7
))
abs(p0-p1)< tol

.isIn <- function(p0, pmat, tol = min( getdistrOption("TruncQuantile")/2,
.Machine\$double.eps^.7
))
{list1 <- lapply(1:nrow(pmat), function(x){
(p0+tol > pmat[x,1]) & (p0-tol < pmat[x,2]) })
apply(matrix(unlist(list1), ncol = nrow(pmat)), 1, any)}

.isEqual01<- function(x) .isEqual(x,0)|.isEqual(x,1)

.presubs <- function(inp, frompat, topat){
### replaces in an expression or a string all frompat patterns to topat patterns

logic <- FALSE
inCx <- sapply(inp,
function(inpx){
inC <- deparse(inpx)
l <- length(frompat)
for(i in 1:l)
{ if (is.language(topat[[i]])){
totxt <- deparse(topat[[i]])
totxt <- gsub("expression\\(", "\", ", gsub("\\)\$",", \"",totxt))
if (length(grep(frompat[i],inC))) logic <<- TRUE
inC <- gsub(frompat[i],totxt,inC)
}else inC <- gsub(frompat[i], topat[[i]], inC)
}
return(inC)
})
if(length(grep("expression",inCx))>0)
inCx <- gsub("expression\\(", "", gsub("\\)\$","",inCx))
if (length(inCx) > 1) {
inCx <- paste(inCx, c(rep(",", length(inCx)-1), ""),
sep = "", collapse = "\"\\n\",")
if ( any(as.logical(c(lapply(inp,is.language)))) | logic )
inCx <- paste("expression(paste(", gsub("\\\\n"," ", inCx), "))", sep ="")
else
inCx <- paste("paste(",inCx,")", sep ="")
}else inCx <- paste("expression(paste(",inCx,"))",sep="")
outC <- eval(parse(text = eval(inCx)))
return(outC)
}

.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))
supp <- as.vector(tapply(supp, groups, quantile, probs = 0.5, type = 1))
### in order to get a "support member" take the leftmost median
return(list(supp = supp, prob = prob))
#    newDistribution <- DiscreteDistribution(supp=supp,prob=prob)
#    return(newDistribution)
}

.makeLenAndOrder <- function(x,ord){
n <- length(ord)
x <- rep(x, length.out=n)
x[ord]
}

}

if(packageVersion("distrMod")<"2.5"){
.isUnitMatrix <- function(m){
### checks whether m is unit matrix
m.row <- nrow(m)
isTRUE(all.equal(m, diag(m.row), check.attributes = FALSE))
}

.deleteDim <- function(x){
attribs <- attributes(x)
attribs\$dim <- NULL
attribs\$dimnames <- NULL
attributes(x) <- attribs
x
}

}

.panel.mingle <- function(dots, element){
pF <- dots[[element]]
if(is.list(pF)) return(pF)
pFr <- if(typeof(pF)=="symbol") eval(pF) else{
pFc <- as.call(pF)
if(as.list(pFc)[[1]] == "list"){
lis <- vector("list",length(as.list(pFc))-1)
for(i in 1:length(lis)){
lis[[i]] <- pFc[[i+1]]
}
lis
}else pF
}
return(pFr)
}
```

## Try the RobAStBase package in your browser

Any scripts or data that you put into this service are public.

RobAStBase documentation built on April 6, 2019, 3 a.m.