Essential Wavelets for Statistical
Applications and Data Analysis

R.T. Ogden, University of South Carolina
0-8176-3864-4 * 1996 * $40.00 * Hardcover * 285 pages * 40 Illustrations

threshhyb<-function(ywd, lowlev = 2, verbose = F, seed = 0)
{
  ans <- ywd
  n <- length(ywd$D)
  nlev <- log(n + 1, base = 2) - 1
  i <- nlev
  iloc <- 1
  while(i > lowlev) {
#       Extract current level coefficients from all wavelet coefficients
    raw <- ywd$D[iloc:(iloc + 2^i - 1)]
    d <- length(raw)    
#       Test:  if the variance is small enough, just use threshold sqrt(2logd)
    if((sum(raw^2) - d)/d <= sqrt(i^3/2^i)) {
      if(verbose)
        cat(paste("At level ", i, " the threshhold is sqrt(2log(d)): ", 
                  sqrt(2 * log(d)), "\n", sep = ""))
      ans$D[iloc:(iloc + 2^i - 1)] <- shrinkit(ywd$D[iloc:(iloc + 2^i - 1)], 
                                               sqrt(2 * log(d)))
    }
      else {
#       Generate random subset
        if(length(seed) != 1) .Random.seed <- seed
        Iset <- sort(sample(d, d/2))
        rawI <- raw[Iset]
        rawIp <- raw[ - Iset]
        ggI <- sort(abs(rawI))
        ggIp <- sort(abs(rawIp))        
#       Calculate SURE for all possible thresholds
        surevecI <- sapply(c(ggI[ggI < sqrt(2 * log(d))], 0,
                             sqrt(2 * log(d))), sure, ggI)
        surevecIp <- sapply(c(ggIp[ggI < sqrt(2 * log(d))], 0, 
                              sqrt(2 * log(d))), sure, ggIp)    
#       Threshold that minimizes risk
        llI <- length(surevecI)
        llIp <- length(surevecIp)       
#       The minimum occurs either at sqrt(2logd), 
        if(min(surevecI) == surevecI[llI])
          threshI <- sqrt(2 * log(d))
        else if(min(surevecI) == surevecI[llI - 1])
          threshI <- 0
        else threshI <- ggI[match(min(surevecI), surevecI)]     
        #       or at 0, 
        if(min(surevecIp) == surevecIp[llIp])
          threshIp <- sqrt(2 * log(d))
        else if(min(surevecIp) == surevecI[llIp - 1])
          threshIp <- 0
        else
          threshIp <- ggIp[match(min(surevecIp), surevecIp)]
                #       or at 0, 
        if(verbose) {
          cat(paste("At level ", i, ", threshold1 is ", threshI, "\n",
                    sep = ""))
          cat(paste("At level ", i, ", threshold2 is ", threshIp,
                    "\n", sep = ""))
        }
#       Perform shrinking
        newI <- shrinkit(rawI, threshIp)
        newIp <- shrinkit(rawIp, threshI)
        new <- rep(0, d)
        new[Iset] <- newI
        new[ - Iset] <- newIp
        ans$D[iloc:(iloc + 2^i - 1)] <- new
      }
#       Otherwise, go through all this stuff
    iloc <- iloc + 2^i
    i <- i - 1
  }
  ans
}

shrinkit <- function(coeffs, thresh)
{
  sign(coeffs) * pmax(abs(coeffs) - thresh, 0)
}

sure <- function(t, x)
{
  ax <- sort(abs(x))    
                                        #  num gives the number of elements
                                        # in x that are <= t
  num <- match(F, ax <= t, nomatch = length(ax) + 1) - 1
  length(ax) - 2 * num + sum(pmin(ax, t)^2)
}