library(EbayesThresh) library(adlift) library(wavelets) library(MASS) ab.vec<-function(f = NA) { ##ab.vec in book1fig that returns intervals where the function f is positive ###!!!!!!! the first two elements of calculated vec are 00. This ####!!!!!!! indicates that all entries of f are nonpositive. n <- length(f) + 1 f <- c(f, 0) vec <- c(0, 0) if(all(f > 0)) { vec <- c(vec, 1, n) } else { seq.pos <- (1:n)[f > 0] seq.neg <- (1:n)[f <= 0] seq.neg <- seq.neg[seq.neg > 1] a <- 1 while(length(seq.pos) * length(seq.neg) > 0) { if(f[a + 1] > 0) { b <- min(seq.neg) - 1 } else { a <- min(seq.pos) seq.neg <- seq.neg[seq.neg > a] b <- min(seq.neg) - 1 } vec <- c(vec, a, b) seq.pos <- seq.pos[seq.pos > b] seq.neg <- seq.neg[seq.neg > b] a <- b } } if(vec[length(vec)] == n) { vec[length(vec)] <- n - 1 } vec } ################################################################################################################################################ ################################################################################################################################################ abvec<-function(f = NA) { ##ab.vec (abvec) ##in book1fPC that returns intervals where the function f is positive ###!!!!!!! the first two elements of calculated vec are 00. This ####!!!!!!! indicates that all entries of f are nonpositive. n <- length(f) + 1 f <- c(f, 0) vec <- c(0, 0) if(all(f > 0)) { vec <- c(vec, 1, n) } else { seq.pos <- (1:n)[f > 0] seq.neg <- (1:n)[f <= 0] seq.neg <- seq.neg[seq.neg > 1] a <- 1 while(length(seq.pos) * length(seq.neg) > 0) { if(f[a + 1] > 0) { b <- min(seq.neg) - 1 } else { a <- min(seq.pos) seq.neg <- seq.neg[seq.neg > a] b <- min(seq.neg) - 1 } vec <- c(vec, a, b) seq.pos <- seq.pos[seq.pos > b] seq.neg <- seq.neg[seq.neg > b] a <- b } } if(vec[length(vec)] == n) { vec[length(vec)] <- n - 1 } vec } ################################################################################################################################################ ################################################################################################################################################ blockw<-function(J = 6, signal = NA, wavelet = "s8", clenB = 1, cT = 1, cV = 1, FLAGS = 1, t1 = NA, t2 = NA) { if (wavelet=="s4"){wavelet="la8"} if (wavelet=="s5"){wavelet="la10"} if (wavelet=="s6"){wavelet="la12"} if (wavelet=="s7"){wavelet="la14"} if (wavelet=="s8"){wavelet="la16"} if (wavelet=="s9"){wavelet="la18"} if (wavelet=="s10"){wavelet="la20"} #this is blockw in book1fig that computes f.dwt by block thresholding n <- length(signal) j <- log(log(n, base = 2), base = 2) j <- floor(j) lenBl <- min(c(clenB * 2^j), n/64) # print(lenBl) fB <- dwt(signal, filter = wavelet, n.levels = J) fS <- fB #I created dwt of signal ##### varianc <- (mad(fB[["d1"]], center = 0))^2 varianc <- (mad(fB@W[["W1"]]))^2 ##### named <- c("d1", "d2", "d3", "d4", "d5", "d6", "d7", "d8", "d9") ##### names <- c("s1", "s2", "s3", "s4", "s5", "s6", "s7", "s8", "s9") # loop in j named <- c("W1", "W2", "W3", "W4", "W5", "W6", "W7", "W8", "W9") names <- c("V1", "V2", "V3", "V4", "V5", "V6", "V7", "V8", "V9") # loop in j if(FLAGS == 0) { for(j in 1:J) { name <- named[j] ###### vect <- as.vector(fB[[name]]) vect <- as.vector(fB@W[[name]]) for(l in (1:((n/2^j)/lenBl))) { theta <- vect[(1 + (l - 1) * lenBl):(l * lenBl)] if(mean(theta^2) < varianc * cT * 4.5) { ###### fB[[name]][(1 + (l - 1) * lenBl):(l * lenBl)] <- 0 fB@W[[name]][(1 + (l - 1) * lenBl):(l * lenBl)] <- 0 } thetasq <- theta^2 - varianc ww <- mean(thetasq) if(ww < cV * varianc) { ww <- 0 } weight <- ww/mean(theta^2) ###### fS[[name]][(1 + (l - 1) * lenBl):(l * lenBl)] <- theta * weight fS@W[[name]][(1 + (l - 1) * lenBl):(l * lenBl)] <- theta * weight } } } else { lenBll <- lenBl for(j in 1:J) { lenBl <- lenBll * 2^(2 - floor(j/3)) # print(c(j, lenBl)) name <- named[j] ##### vect <- as.vector(fB[[name]]) vect <- as.vector(fB@W[[name]]) for(l in (1:((n/2^j)/lenBl))) { theta <- vect[(1 + (l - 1) * lenBl):(l * lenBl)] ########### # thetar <- theta # ttt <- (theta^2 > 10 * varianc) # theta[ttt] <- varianc^(1/2) ################ if(mean(theta^2) < varianc * t1) { ##### fB[[name]][(1 + (l - 1) * lenBl):(l * lenBl)] <- 0 fB@W[[name]][(1 + (l - 1) * lenBl):(l * lenBl)] <- 0 } thetasq <- theta^2 - varianc ww <- mean(thetasq) if(ww < cV * varianc) { ww <- 0 } weight <- ww/mean(theta^2) ################## # weight[ttt] <- 1 ##### fS[[name]][(1 + (l - 1) * lenBl):(l * lenBl)] <- theta * weight fS@W[[name]][(1 + (l - 1) * lenBl):(l * lenBl)] <- theta * weight } } for(j in 1:J) { lenBl <- lenBll name <- named[j] ##### vect <- as.vector(fB[[name]]) vect <- as.vector(fB@W[[name]]) for(l in (1:((n/2^j)/lenBl))) { theta <- vect[(1 + (l - 1) * lenBl):(l * lenBl)] ########### # thetar <- theta # ttt <- theta^2 > 2 * log(n) * varianc # theta[ttt] <- varianc^(1/2) ################ if(mean(theta^2) < varianc * t2) { ##### fB[[name]][(1 + (l - 1) * lenBl):(l * lenBl)] <- 0 fB@W[[name]][(1 + (l - 1) * lenBl):(l * lenBl)] <- 0 } else { thetasq <- theta^2 - varianc ww <- max(mean(thetasq), 0) weight <- ww/mean(theta^2) ################## # weight[ttt] <- 1 ##### fB[[name]][(1 + (l - 1) * lenBl):(l * lenBl)] <- theta * weight fB@W[[name]][(1 + (l - 1) * lenBl):(l * lenBl)] <- theta * weight } } } } list(fB = fB, fS = fS) } ################################################################################################################################################ ################################################################################################################################################ haarapr<-function(f = NA, z = NA, level = 1) { #this is a function HAARAPR in ../book1fig #approx and computes Fourier coeffic for Haar basis on [0,1] for(j in (0:level)) { if(j == 0) { bas <- haar(knots = length(z), level = 0, shift = 0) bas <- matrix(bas, ncol = 1) } else for(k in (0:(2^(j - 1) - 1))) { bas <- cbind(bas, matrix(haar(knots = length(z), level = j, shift = k), ncol = 1)) } } fourc <- matrix(f[2:(length(f) - 1)], nrow = 1) %*% bas[2:(length(f) - 1), ] fourc <- fourc + (f[1] * bas[1, ] + f[length(f)] * bas[length(f), ])/2 fourc <- fourc/(length(f) - 1) hapr <- bas %*% matrix(fourc, ncol = 1) list(fcoef = fourc, apr = hapr) } ################################################################################################################################################ ################################################################################################################################################ qlestJ<-function(J = 6, signal = NA, wavelet = "s8", cT = 4, Jdel = 0, cU = 1, cJ = 1, coefvar = 2, nj = 2) { if (wavelet=="s4"){wavelet="la8"} if (wavelet=="s5"){wavelet="la10"} if (wavelet=="s6"){wavelet="la12"} if (wavelet=="s7"){wavelet="la14"} if (wavelet=="s8"){wavelet="la16"} if (wavelet=="s9"){wavelet="la18"} if (wavelet=="s10"){wavelet="la20"} #this is qlestJ n <- length(signal) Js<-log2(n) f.dwt <- dwt(signal, filter = wavelet, n.levels = J) ##### varianc <- (mad(f.dwt[["d1"]], center = 0))^2 ##### named <- c("d1", "d2", "d3", "d4", "d5", "d6", "d7", "d8", "d9") ##### names <- c("s1", "s2", "s3", "s4", "s5", "s6", "s7", "s8", "s9") varianc <- (mad(f.dwt@W[["W1"]]))^2 named <- c("W1", "W2", "W3", "W4", "W5", "W6", "W7", "W8", "W9") names <- c("V1", "V2", "V3", "V4", "V5", "V6", "V7", "V8", "V9") # loop in s s <- 1 sumsq <- 0 while(s <= J - Jdel) { # loop in finest scales f <- f.dwt l <- s while(l >= 1) { name <- named[l] # vect <- as.vector(f[[name]]) vect <- as.vector(f@W[[name]]) if(((n/2^s)/2^(s - l)) < 1) { thresh <- varianc * 10^5 } else { thresh <- rev(sort(vect^2))[(cJ * (n/2^s))/(nj * 2^(s - l) )] } # f[[name]][(f[[name]])^2 <= min(cU * varianc * 2 * log(n), max(cT * (2^(s - l)) * varianc, thresh))] <- 0 f@W[[name]][(f@W[[name]])^2 <= min(cU * varianc * 2 * log(n), max(cT * (2^(s - l)) * varianc, thresh))] <- 0 l <- l - 1 } ##### fsq <- f^2 namesJ<-names[J] fsq<-f@V[[namesJ]] for (i in 1:J){ fsq<-c(fsq,f@W[[named[J-i+1]]]) } fsq<-fsq^2 sumsq <- c(sumsq, coefvar * varianc * length(fsq[fsq > 0]) - sum(fsq)) s <- s + 1 } s <- order(sumsq[-1])[1] #calculate empirical risk # phis <- as.vector(f.dwt[[names[J]]]) phis <- as.vector(f.dwt@V[[names[J]]]) emprisk <- sumsq[1 + s] # loop in fine scales f <- f.dwt l <- s while(l >= 1) { name <- named[l] ##### vect <- as.vector(f[[name]]) vect <- as.vector(f@W[[name]]) if((n/2^s)/2^(s - l) < 1) { thresh <- varianc * 10^5 } else { thresh <- rev(sort(vect^2))[(cJ * (n/2^s))/(nj * 2^(s - l))] } dmax <- max(cT * (2^(s - l)) * varianc, thresh) coefff <- min(cU * varianc * 2 * log(n), dmax) ##### f[[name]][(f[[name]])^2 <= coefff * rep(1, length(vect))] <- 0 f@W[[name]][(f@W[[name]])^2<=coefff* rep(1, length(vect))] <- 0 l <- l - 1 } ##### fsq1 <- f^2 fsq1<-f@V[[namesJ]]^2 for (i in 1:J){ fsq1<-c(fsq1,f@W[[named[J-i+1]]]^2) } ##### fsq <- f^2 - varianc fsq<-(f@V[[namesJ]]^2)-varianc for (i in 1:J){ fsq<-c(fsq,(f@W[[named[J-i+1]]]^2)-varianc) } fsq[fsq < 0] <- 0 fsq1[fsq1 <= 0] <- 1 ##### f <- (fsq/fsq1) * f for (i in 1:J){ f@W[[named[J-i+1]]]<-(fsq[(2^(Js-J+i-1)+1):(2^(Js-J+i))]/fsq1[(2^(Js-J+i-1)+1):(2^(Js-J+i))])*f@W[[named[J-i+1]]] } f@V[[namesJ]]<-(fsq[1:2^(Js-J)]/fsq1[1:2^(Js-J)])*f@V[[namesJ]] list(func = f, emprisk = emprisk, s = s) } ########################################################################################################################################### ############################################################################################################################################ rts<-function(x = NA, start = 1, deltat = 1, frequency = 1, end = if(length(dim(x)) == 2) dim(x)[1] else length(as.vector(x)), units = NULL, names = NULL, ts.eps = .Options$ts.eps) { if(is.dates(start) || is.character(start)) stop("Use the SPLUS function cts to create time series with calendar dates") if(is.dates(end) || is.character(end)) stop("Use the SPLUS function cts to create time series with calendar dates") dimx <- dim(x) if(is.null(dimx)) { if(is.list(x)) stop("a list cannot be converted to a time series") n <- length(x) multivariate <- F } else { if(length(dimx) > 2) { warning("x with dimension > 2 was coerced to a vector.") x <- as.vector(x) n <- length(x) multivariate <- F } else { n <- dimx[1] ncolx <- dimx[2] multivariate <- ncolx > 1 } } if(is.ts(x)) tsp(x) <- NULL no.deltat <- missing(deltat) no.frequency <- missing(frequency) if(no.frequency && !no.deltat) frequency <- 1/deltat else if(no.deltat && !no.frequency) deltat <- 1/frequency temp <- round(deltat, digits = 0) if(temp >= 1 && abs(deltat - temp) < ts.eps) { deltat <- temp if(no.frequency) frequency <- 1/temp } freq.int <- round(frequency, digits = 0) if(freq.int >= 1 && abs(frequency - freq.int) < ts.eps) { frequency <- freq.int if(no.deltat) deltat <- 1/freq.int } if(length(end) > 1) { if(frequency != freq.int) stop("frequency must be an integer if end is a vector") if(length(end) != 2 || end[2] != round(end[2], digits = 0)) stop("invalid specification of end") if(end[2] > frequency) stop("end incompatible with frequency") end <- end[1] + (end[2] - 1)/frequency } if(length(start) > 1) { if(frequency != freq.int) stop("frequency must be an integer if start is a vector") if(length(start) != 2 || start[2] != round(start[2], digits = 0)) stop("invalid specification of start") if(start[2] > frequency) stop("start incompatible with frequency") start <- start[1] + (start[2] - 1)/frequency } if(missing(end)) { if(frequency == freq.int) end <- start + (n - 1)/frequency else end <- start + (n - 1) * deltat } if(missing(start)) { if(frequency == freq.int) start <- end - (n - 1)/frequency else start <- end - (n - 1) * deltat } ndata <- trunc((end - start) * frequency + 1.01) if(multivariate) rows.to.use <- rep(1:n, length = ndata) if(ndata > n) { if(multivariate) x <- x[rows.to.use, , drop = F] else x <- rep(x, length = ndata) warning("Data replicated to match length implied by start, end, and deltat") } else if(ndata < n) { warning("Extra data ignored") if(multivariate) x <- x[rows.to.use, , drop = F] else length(x) <- ndata } cl <- class(x) no.ts.class <- as.logical((cl != "cts") * (cl != "rts") * (cl != "its")) class(x) <- c("rts", cl[no.ts.class]) pars <- c(start = start, deltat = deltat, frequency = frequency) if(!missing(units) && !is.character(units)) stop("Time units must be specified as a character string") attr(pars, "units") <- units if(!missing(ts.eps)) { old.opts <- options(ts.eps = ts.eps) on.exit(options(old.opts)) } tspar <- pars if(multivariate) { dn <- dimnames(x) rownames <- if(length(dn[[1]])) dn[[1]] else as.character(format(time(x))) colnames <- if(missing(names) || is.null(names)) { if(length(dn[[2]])) dn[[2]] else paste("Series", 1:ncolx) } else as.character(names) dimnames(x) <- list(rownames, colnames) } x } ########################################################################################################################################### ############################################################################################################################################ is.dates<-function(x) inherits(x, "dates") ########################################################################################################################################### ############################################################################################################################################ tspar<-function(x) attr(x, "tspar") ############################################################################################################################# ############################################################################################################################# complex<-function(length.d = 0, data = NULL, real = 0, imaginary = 0, modulus = 1, argument = 0) { cartesian <- !(missing(real) & missing(imaginary)) polar <- !(missing(modulus) & missing(argument)) if(cartesian && polar) stop("Invalid use of cartesian and polar forms") if(cartesian) data <- real + imaginary * (1i) else if(polar) { mult.of.pi <- abs((argument/pi) %% 1) data <- ifelse(mult.of.pi == 0.5, 0, modulus * cos(argument)) + ifelse(mult.of.pi == 0, 0i, modulus * sin(argument) * (1i)) } else if(missing(data)) return(vector("complex", length.d)) else data <- as.complex(data) if(missing(length.d)) data else if(length.d != length(data)) rep(data, length = length.d) else data } ########################################################################################################################################### ############################################################################################################################################ ch1<-function(fig = 2, l = 50) { #ch1 if(fig == 2) { tit <- c("(a)", "(b)", "(c)", "(d)") n <- 250 par(mfrow = c(1, 4)) z <- seq(0, 999, len = 100) for(i in 1:4) { X <- 999 * runif(n) den.est1 <- estcden(X = X, knots = 100)/1000 hist(X, xlab = "Simulated Winning Number", ylab = "Relative Frequency of Simulated Winning Numbers", breaks = seq(0, 999, len = l + 1), prob = T, main = tit[i]) lines(z, den.est1, type = "l") } ff <- paste("Figure 1.", fig, sep = "") } else { ff <- paste("Figure 1.", fig, sep = "") ff <- paste(ff, "not supported") } ff } ################################################################################################################################################ ################################################################################################################################################ ch2<-function(fig = 4, set.j = c(0, 1, 2, 3), set.J = -99.9, set.cf = -99.9, L = 6, knots = 100, set.wav = c("d4", "d12", "s8", "c12"), wav = "s8", n = 128, a = 1/3, CFUN = list(NA, NA)) { if (wav=="s4"){wav="la8"} if (wav=="s5"){wav="la10"} if (wav=="s6"){wav="la12"} if (wav=="s7"){wav="la14"} if (wav=="s8"){wav="la16"} if (wav=="s9"){wav="la18"} if (wav=="s10"){wav="la20"} for(i in 1:length(set.wav)){if(set.wav[i]=="s4"){set.wav[i]="la8"} if(set.wav[i]=="s5"){set.wav[i]="la10"} if(set.wav[i]=="s6"){set.wav[i]="la12"} if(set.wav[i]=="s7"){set.wav[i]="la14"} if(set.wav[i]=="s8"){set.wav[i]="la16"} if(set.wav[i]=="s9"){set.wav[i]="la18"} if(set.wav[i]=="s10"){set.wav[i]="la20"} } #ch2 ttle <- c("1. Uniform", "2. Normal", "3. Bimodal", "4. Strata", "5. Delta", "6. Angle", "7. Monotone", "8. Steps") if(is.na(CFUN[[1]]) & is.na(CFUN[[2]]) & fig == 3) { CFUN <- list(6, "2 - 2*x -sin(8*x)") ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".") } else { if(!is.na(CFUN[[2]])) { ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".") } } if(set.J[1] == -99.9) { set.J <- c(3, 5, 10) if(fig == 7) { set.J <- c(3, 5) } if(fig == 10 | fig == 15 | fig == 16) { set.J <- c(2, 3, 5) } if(fig == 11) { set.J <- c(3, 4, 6) } if(fig == 12) { set.J <- c(2, 3, 4) } } if(set.cf[1] == -99.9) { set.cf <- c(2, 5) if(fig == 13) { set.cf <- c(2, 8) } } if(fig == 0) { par(mfrow = c(1, 1)) z <- seq(0, 1, len = 10) vec <- matrix(rep(1, 10), ncol = 1) mat <- cbind(vec, vec + 1, vec + 2, vec + 3) matplot(z, mat, type = "l", lty = 1:4) } else if(fig == 1) { par(mfrow = c(2, 4)) z <- seq(0, 1, len = 100) for(i in 1:8) { plot(z, dcornerf(c = i, knots = 100, CFUN = CFUN), type = "l", xlab = "", ylab = "", main = ttle[i]) } } else if(fig == 2) { par(mfrow = c(1, length(set.j))) for(i in set.j) { z <- seq(0, 1, len = 50 + round(i * 20)) f <- 2^(1/2) * cos(pi * i * z) if(i == 0) { f <- f/2^(1/2) } plot(z, f, type = "l", xlab = "", ylab = "", main = paste("j = ", i, sep = "")) } } else if(fig == 3) { par(mfrow = c(2, 4)) for(i in 1:8) { for(JJ in set.J) { f1 <- trigcapr(f = dcornerf(c = i, knots = 300, CFUN = CFUN), knots = knots, level = JJ, xsq = 0) if(JJ == set.J[1]) { f <- f1$apr } else { f <- cbind(f, f1$apr) } } f <- cbind(dcornerf(c = i, knots = knots, CFUN = CFUN), f) matplot(seq(0, 1, len = knots), f, type = "l", xlab = "", ylab = "", main = ttle[i], lty = 1:(length(set.J) + 1)) } } else if(fig == 4) { par(mfrow = c(1, length(set.j))) for(i in set.j) { z <- seq(0, 1, len = 50 + round(i * 20)) f <- legpol(z, level = i) plot(z, f[, i + 1], type = "l", xlab = "", ylab = "", main = paste("j = ", i, sep = "")) } } else if(fig == 5) { par(mfrow = c(2, 4)) for(i in 1:8) { for(JJ in set.J) { f1 <- legapr(f = dcornerf(c = i, knots = 300, CFUN = CFUN), z = seq(0, 1, len = knots), level = JJ) if(JJ == set.J[1]) { f <- f1$apr } else { f <- cbind(f, f1$apr) } } f <- cbind(dcornerf(c = i, knots = knots, CFUN = CFUN), f) matplot(seq(0, 1, len = knots), f, type = "l", lty = 1:(length(set.J) + 1), xlab = "", ylab = "", main = ttle[i]) } } else if(fig == 7) { par(mfrow = c(2, 4)) for(i in 1:8) { for(JJ in set.J) { f1 <- haarapr(f = dcornerf(c = i, knots = knots, CFUN = CFUN), z = seq(0, 1, len = knots), level = JJ) if(JJ == set.J[1]) { f <- f1$apr } else { f <- cbind(f, f1$apr) } } f <- cbind(dcornerf(c = i, knots = knots, CFUN = CFUN), f) matplot(seq(0, 1, len = knots), f, type = "l", lty = 1:(length(set.J) + 1), xlab = "", ylab = "", main = ttle[i]) } } else if(fig == 8) { par(mfrow = c(1, 4)) for(i in 1:2) { fw <- rts(dcornerf(cornerf = set.cf[i], knots = 2^L, CFUN = CFUN), start = 0, delta = 1/(2^L - 1)) plot.wav(dwt(as.vector(fw), filter = "haar",n.levels=L),wds=L,main="",xlab="",ylab="") plot.wavr(mra(as.vector(fw), filter = "haar",n.level=L),wds=L,main="",xlab="",ylab="") } } else if(fig == 10) { par(mfrow = c(2, 4)) for(i in 1:8) { for(JJ in set.J) { f1 <- trigscapr(f = dcornerf(c = i, knots = 300, CFUN = CFUN), z = seq(0, 1, len = 300), level = JJ, xsq = 0) if(JJ == set.J[1]) { f <- f1$apr } else { f <- cbind(f, f1$apr) } } f <- cbind(dcornerf(c = i, knots = 300, CFUN = CFUN), f) matplot(seq(0, 1, len = 300), f, type = "l", lty = 1:(length(set.J) + 1), xlab = "", ylab = "", main = ttle[i]) } } else if(fig == 11) { par(mfrow = c(2, 4)) for(i in 1:8) { for(JJ in set.J) { f1 <- matrix(rep(1, 300), ncol = 1) for(j in 1:(JJ - 1)) { f1 <- cbind(f1, trigscapr(f = dcornerf(c = i, knots = 300, CFUN = CFUN), z = seq(0, 1, len = 300), level = j, xsq = 0)$apr) } f1 <- apply(f1, 1, sum)/JJ if(JJ == set.J[1]) { f <- f1 } else { f <- cbind(f, f1) } } f <- cbind(dcornerf(c = i, knots = 300, CFUN = CFUN), f) matplot(seq(0, 1, len = 300), f, type = "l", lty = (1:(length(set.J) + 1)), xlab = "", ylab = "", main = ttle[i]) } } else if(fig == 12) { par(mfrow = c(2, 4)) for(i in 1:8) { for(JJ in set.J) { for(j in JJ:(2 * JJ - 1)) { if(j == JJ) { f1 <- f1 <- trigscapr(f = dcornerf(c = i, knots = 300, CFUN = CFUN), z = seq(0, 1, len = 300), level = j, xsq = 0)$apr } else { f1 <- cbind(f1, trigscapr(f = dcornerf(c = i, knots = 300, CFUN = CFUN), z = seq(0, 1, len = 300), level = j, xsq = 0)$apr) } } f1 <- apply(f1, 1, sum)/JJ if(JJ == set.J[1]) { f <- f1 } else { f <- cbind(f, f1) } } f <- cbind(dcornerf(c = i, knots = 300, CFUN = CFUN), f) matplot(seq(0, 1, len = 300), f, type = "l", lty = (1:(length(set.J) + 1)), xlab = "", ylab = "", main = ttle[i]) } } else if(fig == 13) { par(mfrow = c(1, length(set.wav))) ##### for(i in set.wav) { ##### plot(wavelet(i)) for(i in 1:length(set.wav)){ figure108.wt.filter(set.wav[i],level=4) } } else if(fig == 14) { par(mfrow = c(1, 4)) for(i in 1:2) { fw <- rts(dcornerf(cornerf = set.cf[i], knots = n, CFUN = CFUN), start = 0, delta = 1/(n - 1)) ##### plot(dwt(fw, filter = wav)) ##### plot(mra(fw, wavelet = wav)) plot.wav(dwt(as.vector(fw), filter = wav,n.levels=5),wds=5,main="",xlab="",ylab="") plot.wavr(mra(as.vector(fw), filter = wav,n.level=5),wds=5,main="",xlab="",ylab="") } } else if(fig == 15) { par(mfrow = c(2, 4)) for(i in 1:8) { for(JJ in set.J) { f1 <- trigscapr(f = dcornerf(c = i, knots = 300, CFUN = CFUN), z = seq(0, 1, len = 300), level = JJ, xsq = 1) if(JJ == set.J[1]) { f <- f1$apr } else { f <- cbind(f, f1$apr) } } f <- cbind(dcornerf(c = i, knots = 300, CFUN = CFUN), f) matplot(seq(0, 1, len = 300), f, type = "l", lty = (1:(length(set.J) + 1)), xlab = "", ylab = "", main = ttle[i]) } } else if(fig == 16) { par(mfrow = c(2, 4)) for(i in 1:8) { for(JJ in set.J) { f1 <- trigscapr(f = dcornerf(c = i, knots = 300, CFUN = CFUN), z = seq(0, 1, len = 300), level = JJ, xsq = 2) if(JJ == set.J[1]) { f <- f1$apr } else { f <- cbind(f, f1$apr) } } f <- cbind(dcornerf(c = i, knots = 300, CFUN = CFUN), f) matplot(seq(0, 1, len = 300), f, type = "l", lty = (1:length(set.J)), xlab = "", ylab = "", main = ttle[i]) } } else if(fig == 17) { par(mfrow = c(2, 4)) for(i in 1:8) { for(JJ in set.J) { f1 <- trigcapr(f = dcornerf(c = i, knots = 300, CFUN = CFUN), knots = 300, level = JJ, xsq = 3, a = a) if(JJ == set.J[1]) { f <- f1$apr } else { f <- cbind(f, f1$apr) } } f <- cbind(dcornerf(c = i, knots = 300, CFUN = CFUN), f) matplot(seq(0, 1, len = 300), f, type = "l", lty = (1:(length(set.J) + 1)), xlab = "", ylab = "", main = ttle[i]) } } if(fig == 6) { ttle <- c("F(x)", "M(x)", "aM(2x) ", "aM(2x-1)") a <- sqrt(2) par(mfrow = c(1, 4)) plot(c(-0.25, 0, 0, 1, 1, 1.25), c(0, 0, 1, 1, 0, 0), type = "l", xlab = "x", ylab = "", main = ttle[1]) plot(c(-0.25, 0, 0, 0.5, 0.5, 1, 1, 1.25), c(0, 0, 1, 1, -1, -1, 0, 0), type = "l", xlab = "x", ylab = "", main = ttle[2]) plot(c(-0.25, 0, 0, 0.25, 0.25, 0.5, 0.5, 1.25), c(0, 0, a, a, - a, - a, 0, 0), type = "l", xlab = "x", ylab = "", main = ttle[3]) plot(c(-0.25, 0.5, 0.5, 0.75, 0.75, 1, 1, 1.25), c(0, 0, a, a, - a, - a, 0, 0), type = "l", xlab = "x", ylab = "", main = ttle[4]) } ff <- paste("Figure 2.", fig, sep = "") ff } ################################################################################################################################################ ################################################################################################################################################ ch3<-function(fig = 2, set.n = c(-99.9, 100, 200), cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, cB = 2, n = -99.9, s = 1, corden = -99.9, a = -99.9, b = 0.9, set.sigma = c(0.02, 0.1, 0.3), sigma = 0.1, cH = 1, cb = 8, d0 = 2, d1 = 0.5, d2 = 10, cTP = 4, del1 = 1, del2 = 2, a31 = 2, a32 = 1, DATA = -99.9, l = -99.9, set.sup1 = c(31.7, 59.7), set.sup2 = c( 30.7, 60.7), set.sup = c(-99.9, 100), arg = "cJ0", set.arg = c(4, 2, 1), alpha = 0.05, m = 100, reps = 100, set.nn = c(25, 50), set.l = c(3, 5), set.cden = c(1, 2, 6), sam = F, CFUN = list(NA, NA)) { #ch3 if(n == -99.9) { n <- 100 if(fig == 22) { n <- 200 } } if(l == -99.9) { if(fig <= 23) { l <- 10 } if(fig == 25) { l <- 25 } if(fig == 26) { l <- 50 } } titel <- c("1. Uniform", "2. Normal", "3. Bimodal", "4. Strata", "5. Delta", "6. Angle", "7. Monotone", "8. Steps") if(!is.na(CFUN[[2]])) { titel[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".") } ########################################################################### if(fig == 2) { par(mfrow = c(2, 4)) knots <- 100 if(set.n[1] == -99.9) { set.n <- c(50, 100, 200) } for(i in 1:8) { for(n1 in set.n) { X <- rcornerf(cornerf = i, n = n1, CFUN = CFUN) if(n1 == set.n[1]) { f <- estcden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) } else { f <- cbind(f, estcden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB)) } } f <- cbind(dcornerf(c = i, knots = knots, CFUN = CFUN), f) z <- seq(0, 1, l = knots) matplot(z, f, type = "l", lty = 1:(length(set.n) + 1), xlab = " ", ylab = " ", main = titel[i]) } } else if(fig == 3) { knots <- 300 par(mfrow = c(2, 4)) for(i in 1:8) { X <- rcornerf(cornerf = i, n = n, CFUN = CFUN) f <- estcden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) if(i == 5) { XMIN <- min(X) XMAX <- max(X) a <- floor((XMIN - 0.03) * 300) b <- floor((XMAX + 0.03) * 300) mmm <- hist(X, probability = T, nclas = floor(n/10), plot = F, xlim = c(XMIN - 0.03, XMAX + 0.03))$counts fc <- dcornerf(c = i, knots = 300, CFUN = CFUN) mmm <- max(c(mmm, f, fc)) hist(X, probability = T, nclas = floor(n/10), xlab = "", main = titel[i], xlim = c(XMIN - 0.03, XMAX + 0.03), ylim = c(0, mmm)) lines(seq(XMIN - 0.03, XMAX + 0.03, len = b - a), f[a:(b - 1)], type = "l", lty = 2, col = 3) lines(seq(XMIN - 0.03, XMAX + 0.03, len = b - a), fc[a:(b - 1)], type = "l") } else { mmm <- hist(X, plot = F, prob = T, nclass = floor(n/4))$counts fc <- dcornerf(c = i, knots = 300, CFUN = CFUN) mmm <- max(c(mmm, f, fc)) hist(X, probability = T, nclass = floor(n/4), xlab = "", main = titel[i], xlim = c(0, 1), ylim = c(0, mmm)) z <- seq(0, 1, l = 300) lines(z, f, type = "l", lty = 2, col = 3) lines(z, fc, type = "l") } } } else if(fig == 4) { if(a == -99.9) { a <- 0.4 } knots <- 300 par(mfrow = c(2, 4)) nbreaks <- min(floor(n/5), 35) + 5 breaks <- seq(0, 1, len = nbreaks) for(i in 1:8) { X <- rcornerf(cornerf = i, n = n, CFUN = CFUN) f <- estcden.int(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB, a = a, b = b) mmm <- hist(X, nclass = floor(n/3), prob = T, plot = F)$counts fc <- dcornerf(c = i, knots = 300, CFUN = CFUN) mmm <- max(c(mmm, f, fc)) hist(X, probability = T, nclass = floor(n/3), xlab = "", main = titel[i], xlim = c(0, 1), ylim = c(0, mmm)) z <- seq(a, b, l = 300) lines(z, f, type = "l", lty = 2, col = 3) lines(seq(0, 1, len = 300), fc, type = "l") } } else if(fig == 5) { knots <- 100 par(mfrow = c(2, 4)) for(i in 1:8) { X <- rcornerf(cornerf = i, n = n, CFUN = CFUN) NN <- order(X) aa <- X[NN[1]] - (X[NN[1 + s]] - X[NN[1]])/s bb <- X[NN[n]] + (X[NN[n]] - X[NN[n - s]])/s XLIM <- range(c(0, 1, aa, bb)) X1 <- (X - aa)/(bb - aa) f1 <- estcden(X = X1, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB)/(bb - aa) f <- estcden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) f1 <- f1[, 1] if(i == 5) { f <- estcden(X = X, knots = 300, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) XMIN <- min(X) XMAX <- max(X) a <- floor((XMIN - 0.03) * 300) b <- floor((XMAX + 0.03) * 300) mmm <- hist(X, probability = T, plot = F, xlim = c(XMIN - 0.03, XMAX + 0.03), nclass = floor(n/10))$counts fc <- dcornerf(c = i, knots = 300, CFUN = CFUN) mmm <- max(c(mmm, f, fc, f1)) hist(X, probability = T, xlab = "", main = titel[i], xlim = c(XMIN - 0.03, XMAX + 0.03), nclass = floor(n/10), ylim = c(0, mmm)) lines(seq(XMIN - 0.03, XMAX + 0.03, len = b - a), f[a:(b - 1)], type = "l", lty = 2, col = 3) lines(c(aa, seq(aa, bb, len = 100), bb), c(0, f1, 0), type = "l", lty = 3, col = 4) lines(seq(XMIN - 0.03, XMAX + 0.03, len = b - a), fc[a:(b - 1)], type = "l") } else { mmm <- hist(X, probability = T, nclass = floor(n/4), plot = F, xlim = XLIM)$counts fc <- dcornerf(c = i, knots = knots, CFUN = CFUN) mmm <- max(c(mmm, f, fc, f1)) hist(X, probability = T, nclass = floor(n/4), xlab = "", main = titel[i], xlim = XLIM, ylim = c(0, mmm)) z <- seq(0, 1, l = knots) lines(z, f, type = "l", lty = 2, col = 3) lines(c(aa, seq(aa, bb, len = knots), bb), c(0, f1, 0), type = "l", lty = 3, col = 4) lines(z, fc, type = "l") } } } else if(fig == 6) { knots <- 100 if(corden == -99.9) { corden <- 4 } par(mfrow = c(1, 4)) i <- corden if(!is.na(CFUN[[1]])) { i <- CFUN[[1]] } X <- rcornerf(cornerf = i, n = n, CFUN = CFUN) NN <- order(X) aa <- X[NN[1]] - (X[NN[1 + s]] - X[NN[1]])/s bb <- X[NN[n]] + (X[NN[n]] - X[NN[n - s]])/s XLIM <- range(c(0, 1, aa, bb)) X1 <- (X - aa)/(bb - aa) f1 <- estcden(X = X1, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB)/(bb - aa) f1 <- f1[, 1] mmm <- hist(X, probability = T, nclass = floor(n/2), plot = F, xlim = XLIM)$counts fc <- dcornerf(c = i, knots = knots, CFUN = CFUN) mmm <- max(c(mmm, fc, f1)) hist(X, probability = T, nclass = floor(n/2), xlab = "", main = titel[i], sub = "(a)", xlim = XLIM, ylim = c(0, mmm)) lines(seq(0, 1, len = knots), fc, type = "l", lty = 1, col = 1) lines(c(aa, seq(aa, bb, len = 100), bb), c(0, f1, 0), type = "l", lty = 2, col = 3) f1 <- estcden.sup(X = X, del = 0.01, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) aa <- f1$sup[1] bb <- f1$sup[2] str1 <- paste("a = ", round(aa, 2), sep = "") str2 <- paste("b = ", round(bb, 2), sep = "") str <- paste(str1, str2, sep = ", ") f1 <- f1$f plot(seq(0, 1, len = 100), dcornerf(c = i, knots = 100, CFUN = CFUN), sub = "(b)", type = "l", lty = 1, xlab = "", ylab = "", main = str, xlim = c(min(0, aa), max(1, bb)), ylim = c(0, 3.5), col = 1) lines(seq(aa, bb, len = knots), f1, type = "l", lty = 2, col = 3) for(j in 1:2) { subb <- c("(c)", "(d)") d <- scan(n = 2) str1 <- paste("d1 = ", d[1], sep = "") str2 <- paste("d2 = ", d[2], sep = "") str <- paste(str1, str2, sep = ", ") aa <- X[NN[1]] - d[1] bb <- X[NN[n]] + d[2] X1 <- (X - aa)/(bb - aa) f1 <- estcden(X = X1, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB)/(bb - aa) f1 <- f1[, 1] plot(seq(0, 1, len = 100), dcornerf(c = i, knots = 100, CFUN = CFUN), sub = subb[j], type = "l", lty = 1, xlab = "", ylim = c(0, 3.5), ylab = "", main = str, xlim = c(min(0, aa), max(1, bb)), col = 1) lines(c(aa, seq(aa, bb, len = 100), bb), c(0, f1, 0), type = "l", lty = 2, col = 3) } } else if(fig == 12) { knots <- 100 if(a == -99.9) { a <- 1.5 } if(set.n[1] == -99.9) { set.n <- c(50, 100, 200) } par(mfrow = c(2, 4)) for(i in 1:8) { for(n in set.n) { X <- rcornerf(cornerf = i, n = n, CFUN = CFUN) TT <- runif(n, min = 0, max = a) X <- X[X < TT] if(n == set.n[1]) { f <- estcden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) } else { f <- cbind(f, estcden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB)) } } f <- cbind(dcornerf(c = i, knots = knots, CFUN = CFUN), f) z <- seq(0, 1, l = knots) matplot(z, f, type = "l", lty = 1:(length(set.n) + 1), xlab = " ", ylab = " ", main = titel[i]) } } else if(fig == 13) { knots <- 100 if(a == -99.9) { a <- 1.5 } if(set.n[1] == -99.9) { set.n <- c(50, 100, 200) } par(mfrow = c(2, 4)) for(i in 1:8) { for(n in set.n) { X <- rcornerf(cornerf = i, n = n, CFUN = CFUN) TT <- runif(n, min = 0, max = a) D <- (X < TT) Y <- pmin(X, TT) if(n == set.n[1]) { f <- surv.estdenc(Y = Y, D = D, a = 0, b = 1, knots = knots, delJ = 0, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) } else { f <- cbind(f, surv.estdenc(Y = Y, D = D, a = 0, b = 1, knots = knots, delJ = 0, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB)) } } z <- seq(0, 1, l = knots) f <- cbind(dcornerf(c = i, knots = knots, CFUN = CFUN), f) matplot(z, f, type = "l", lty = 1:(length(set.n) + 1), xlab = " ", ylab = " ", main = titel[i]) } } else if(fig == 15) { par(mfrow = c(2, 4)) z <- seq(0, 1, len = 100) for(i in 1:8) { for(sigm in set.sigma) { f1 <- meser.conv(f = dcornerf(c = i, knots = length(z), CFUN = CFUN), J = 20, sigm = sigm)$apr f1 <- matrix(f1, ncol = 1) if(sigm == set.sigma[1]) { f <- f1 } else { f <- cbind(f, f1) } } f <- cbind(dcornerf(c = i, knots = 100, CFUN = CFUN), f) matplot(z, f, type = "l", lty = 1:(length(set.sigma) + 1), xlab = "", ylab = "", main = titel[i]) } } else if(fig == 16) { par(mfrow = c(2, 4)) if(set.n[1] == -99.9) { set.n <- c(50, 1000) } z <- seq(0, 1, len = 100) for(i in 1:8) { f <- NA for(n in set.n) { Y <- rcornerf(c = i, n = n, CFUN = CFUN) + rnorm(n, mean = 0, sd = sigma) f1 <- meser.estcurd(Y = Y, knots = length(z), sigm = sigma, cb = cb, d0 = d0, d1 = d1, d2 = d2, cH = cH, cB = cB) f1 <- matrix(f1, ncol = 1) f <- cbind(f, f1) } matplot(z, f, type = "l", lty = 2:(length(set.n) + 1), xlab = "", ylab = "", main = titel[i]) } } else if(fig == 17) { par(mfrow = c(2, 4)) z <- seq(0, 1, len = 100) for(i in 1:8) { Y <- rcornerf(c = i, n = n, CFUN = CFUN) + rnorm(n, mean = 0, sd = sigma) f.est <- estcden.meser(Y = Y, knots = length(z), sigma = sigma, cb = cb, d0 = d0, d1 = d1, d2 = d2, cH = cH, cB = cB) YMIN <- min(Y) YMAX <- max(Y) fc <- dcornerf(c = i, knots = 100, CFUN = CFUN) if(i == 15) { hist(Y, probability = TRUE, xlab = "", main = titel[i], xlim = c(YMIN - 0.1, YMAX + 0.1), nclass = floor(n/4), ylim = c(0, 20)) cond <- (z > YMIN - 0.1) & (z < YMAX + 0.1) lines(z[cond], f.est[cond], type = "l", lty = 2, col = 3) lines(z[cond], dcornerf(c = 5, knots = 100, CFUN = CFUN)[cond], type = "l", lty = 1, col = 1) } else { mmm <- hist(Y, probability = TRUE, plot = F, xlim = c(min(0, YMIN), max(YMAX, 1)), nclass = floor(n/4)) XLIM <- range(c(mmm$breaks, 0, 1)) mmm <- max(c(mmm$counts, f.est, fc)) hist(Y, probability = T, xlab = "", main = titel[i], xlim = XLIM, nclass = floor(n/4), ylim = c(0, mmm)) } lines(z, f.est, type = "l", lty = 2, col = 3) lines(z, fc, type = "l", lty = 1, col = 1) } } else if(fig == 18) { if(a == -99.9) { a <- 0.1 } if(set.n[1] == -99.9) { set.n <- c(50, 100, 200) } knots <- 100 par(mfrow = c(2, 4)) for(i in 1:8) { for(n in set.n) { Y <- lenb.gen(i = i, n = n, a = a, b = b, CFUN = CFUN) gv <- Y$gv Y <- Y$Y if(n == set.n[1]) { f <- lenb.estdenc(Y = Y, g = gv, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) } else { f <- cbind(f, lenb.estdenc(Y = Y, g = gv, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB)) } } z <- seq(0, 1, l = knots) f <- cbind(dcornerf(c = i, knots = knots, CFUN = CFUN), f) matplot(z, f, type = "l", lty = 1:(length(set.n) + 1), xlab = " ", ylab = " ", main = titel[i]) } } else if(fig == 19) { knots <- 20 if(set.n[1] == -99.9) { set.n <- c(50, 100, 200) } par(mfcol = c(2, 3)) for(i in c(1, 7, 8)) { for(n in set.n) { X <- rcornerf(cornerf = i, n = n, CFUN = CFUN) if(n == set.n[1]) { f1 <- estcden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) f2 <- monot(f1) f2 <- f2 } else { ff <- estcden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) f1 <- cbind(f1, ff) f2 <- cbind(f2, monot(ff)) } } z <- seq(0, 1, len = knots) matplot(z, f1, type = "l", lty = 2:length(set.n), xlab = " ", ylab = " ", main = titel[i], sub = "ESTIMATE", col = 2:(length(set.n) + 1)) lines(seq(0, 1, len = 100), dcornerf(c = i, knots = 100, CFUN = CFUN)) matplot(z, f2, type = "l", lty = 2:length(set.n), xlab = " ", ylab = " ", sub = "MONOTONIC PROJECTION", col = 2:(length(set.n) + 1)) lines(seq(0, 1, len = 100), dcornerf(c = i, knots = 100, CFUN = CFUN)) } } else if(fig == 20) { knots <- 100 if(corden == -99.9) { corden <- 7 } if(set.n[1] == -99.9) { set.n <- c(50, 100, 200) } i <- corden par(mfrow = c(1, 3)) z <- seq(0, 1, l = knots) for(n in set.n) { ttel <- paste(" n = ", n, sep = "") X <- rcornerf(cornerf = i, n = n, CFUN = CFUN) f1 <- estcden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) f2 <- estcden.der(X = X, knots = knots, cTP = cTP, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) fc <- dcornerf(c = i, knots = knots, CFUN = CFUN) mmm <- hist(X, probability = T, nclass = floor(n/4), plot = F, xlim = c(0, 1))$counts mmm <- max(c(mmm, f1, f2, fc)) hist(X, probability = T, nclass = floor(n/4), xlab = "", main = paste(titel[i], ttel, sep = " "), xlim = c(0, 1), ylim = c(0, mmm)) lines(z, fc, type = "l", lty = 1, col = 1) lines(z, f1, type = "l", lty = 2, col = 3) lines(z, f2, type = "l", lty = 3, col = 4) } } if(fig == 21) { set.alpha <- c(0.001, 0.005, 0.01, 0.02, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25) set.c <- c(1.95, 1.73, 1.63, 1.52, 1.48, 1.36, 1.22, 1.14, 1.07, 1.02) ccc <- set.c[set.alpha == alpha] par(mfrow = c(1, 1)) if(DATA[1] == -99.9) { DATA <- lottery.number X <- DATA/999 } else { DATA <- as.vector(DATA) X <- (DATA - min(DATA))/(max(DATA) - min(DATA)) } X <- sort(X) n <- length(X) tit <- paste(c("p-valK=", "p-valM=", "p-valC=", "p-valN="), round(tests(X = X, l = l, m = m, cJ0 = cJ0, cJ1 = cJ1), dig = 2), sep = "") tit <- paste(tit, rep("", 4), collapse = " ") sub <- paste(c("n = ", "alpha = ", "l = "), c(n, alpha, l), collapse = " ") lll <- (1:n)/n plot(X, lll, type = "S", xlab = "", ylab = "", main = tit, sub = sub) lines(c(0, 1), c(0, 1), type = "l", lty = 4) i <- order(abs(X - lll))[n] lines(c(X[i], X[i]), c(0, 1), type = "l", lty = 6) upbound <- lll + ccc * n^(-1/2) upbound[upbound >= 1] <- 1 lbound <- lll - ccc * n^(-1/2) lbound[lbound < 0] <- 0 lines(X, upbound, type = "S", lty = 2) lines(X, lbound, type = "S", lty = 2) } else if(fig == 22) { par(mfrow = c(length(set.cden), 1)) len <- length(set.nn) for(den in set.cden) { ll <- list(1) for(j in 1:len) { nn <- set.nn[j] for(i in 1:reps) { X <- rcornerf(c = den, n = nn, CFUN = CFUN) test <- tests(X = X, l = set.l[j], m = m, cJ0 = cJ0, cJ1 = cJ1) if(i == 1) { mat <- matrix(test, nrow = 1) } else { mat <- rbind(mat, matrix(test, nrow = 1)) } } ll <- c(ll, list(mat[, 1], mat[, 2], mat[, 3], mat[, 4])) } boxplot(ll[-1], main = titel[den], names = paste(rep(c("K", "M", "C", "N"), len), rep(set.nn, rep(4, len)), sep = ""), ylab = "p-value") } } else if(fig == 23) { knots <- 100 par(mfrow = c(1, 4)) for(i in c(2, 3, 4, 5)) { X <- rcornerf(cornerf = i, n = n, CFUN = CFUN) if(i < 5) { fcos <- estcden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB, FLAGBASIS = 1) fsin <- estsden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) fc <- dcornerf(c = i, knots = knots, CFUN = CFUN) riskc <- mean((fcos$fS - fc)^2) risks <- mean((fsin$fS - fc)^2) if(riskc < risks) { tit <- "(cosine)" } else { tit <- "(sine)" } if(fcos$risk < fsin$risk) { tit <- paste("cosine", tit, collapse = " ") } else { tit <- paste("sine", tit, collapse = " ") } } if(i == 5) { fcos <- estcden(X = X, knots = 300, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB, FLAGBASIS = 1) fsin <- estsden(X = X, knots = 300, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) fc <- dcornerf(c = i, knots = 300) riskc <- mean((fcos$fS - fc)^2) risks <- mean((fsin$fS - fc)^2) if(riskc < risks) { tit <- "(cosine)" } else { tit <- "(sine)" } XMIN <- min(X) XMAX <- max(X) a <- floor((XMIN - 0.03) * 300) b <- floor((XMAX + 0.03) * 300) if(fcos$risk < fsin$risk) { tit <- paste("cosine", tit, collapse = " ") } else { tit <- paste("sine", tit, collapse = " ") } mmm <- hist(X, plot = F, xlim = c(XMIN - 0.03, XMAX + 0.03), nclass = floor(n/10) + 5,, prob = T)$counts mmm <- max(c(mmm, fcos$fS, fsin$fS, fc)) hist(X, xlab = "", xlim = c(XMIN - 0.03, XMAX + 0.03), nclass = floor(n/10) + 5, ylim = c(0, mmm),prob=T, main = tit) lines(seq(XMIN - 0.03, XMAX + 0.03, len = b - a), fcos$fS[a:(b - 1)], type = "l", lty = 2, col = 3) lines(seq(XMIN - 0.03, XMAX + 0.03, len = b - a), fsin$fS[a:(b - 1)], type = "l", lty = 3, col = 4) lines(seq(XMIN - 0.03, XMAX + 0.03, len = b - a), fc[a:(b - 1)], type = "l") } if(i < 5) { fc <- dcornerf(c = i, knots = knots, CFUN = CFUN) mmm <- hist(X, nclass = floor(n/4), plot = F, xlim = c(0, 1), prob = T)$counts mmm <- max(c(mmm, fcos$fS, fsin$fS, fc)) hist(X, nclass = floor(n/4), xlab = "", main = tit, xlim = c(0, 1), ylim = c(0, mmm), prob = T) z <- seq(0, 1, l = knots) lines(z, fcos$fS, type = "l", lty = 2, col = 3) lines(z, fsin$fS, type = "l", lty = 3, col = 4) lines(z, fc, type = "l") } } } else if(fig == 24) { par(mfrow = c(1, 4)) ############here density is supported on the [min, max] X <- as.vector(rain.nyc1) a1 <- min(X) b1 <- max(X) Z <- (X - a1)/(b1 - a1) den.est1 <- estcden(X = Z, knots = 100)/(b1 - a1) a2 <- min(X) - del1 b2 <- max(X) + del1 Z <- (X - a2)/(b2 - a2) den.est2 <- estcden(X = Z, knots = 100)/(b2 - a2) X <- as.vector(rain.nyc1) a3 <- min(X) - del2 b3 <- max(X) + del2 Z <- (X - a3)/(b3 - a3) den.est3 <- estcden(X = Z, knots = 100)/(b3 - a3) #########density on [min,max] and default hist par(mfrow = c(1, 4)) hist(rain.nyc1, xlab = "Inches of Rain", ylab = "Relative Frequency", prob = T, main = "(a)") z <- seq(a1, b1, len = 100) lines(z, den.est1, xpd = T) ############b. my density supported on [min,max] plus the same estim hist(rain.nyc1, nclass = 40, xlab = "Inches of Rain", ylab = "Relative Frequency", prob = T, main = "(b)") z <- seq(a1, b1, len = 100) lines(z, den.est1, xpd = T) #############c. this is with 10 classes and est on [min-del1, max + del2] hist(rain.nyc1, breaks = seq(a2, b2, len = 10), xlab = "Inches of Rain", ylab = "Relative Frequency", prob = T, main = "(c)") z <- seq(a2, b2, len = 100) lines(z, den.est2, xpd = T) #############d. this is with 10 classes and est on [min-del1, max + del2] hist(rain.nyc1, breaks = seq(from = a3, to = b3, len = 10), xlab = "Inches of Rain", ylab = "Relative Frequency", prob = T, main = "(d)") z <- seq(a3, b3, len = 100) lines(z, den.est3, xpd = T) } else if(fig == 25) { if(DATA == -99.9) { DATA <- rain.nyc1 } knots <- 100 par(mfrow = c(1, 4)) X <- as.vector(DATA) aa <- min(X) bb <- max(X) str1 <- paste("min(X) = ", round(aa, 2), sep = "") str2 <- paste("max(X) = ", round(bb, 2), sep = "") str <- paste(str1, str2, sep = ", ") hist(X, xlab = "", ylab = "", breaks = seq(min(X), max(X), len = l), main = str, sub = "Histogram", prob = T) n <- length(X) NN <- order(X) aa <- X[NN[1]] - (X[NN[1 + s]] - X[NN[1]])/s bb <- X[NN[n]] + (X[NN[n]] - X[NN[n - s]])/s X1 <- (X - aa)/(bb - aa) str1 <- paste("a = ", round(aa, 2), sep = "") str2 <- paste("b = ", round(bb, 2), sep = "") str <- paste(str1, str2, sep = ", ") f1 <- estcden(X = X1, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB)/(bb - aa) f1 <- f1[, 1] plot(c(aa, seq(aa, bb, len = 100), bb), c(0, f1, 0), type = "l", lty = 1, xlab = "", ylab = "", main = str, sub = "Default") subb <- c("set.sup1", "set.sup2") for(j in 1:2) { if(j == 1) { aa <- set.sup1[1] bb <- set.sup1[2] } else { aa <- set.sup2[1] bb <- set.sup2[2] } str1 <- paste("a = ", aa, sep = "") str2 <- paste("b = ", bb, sep = "") str <- paste(str1, str2, sep = ", ") X1 <- (X - aa)/(bb - aa) f1 <- estcden(X = X1, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB)/(bb - aa) f1 <- f1[, 1] plot(c(aa, seq(aa, bb, len = knots), bb), c(0, f1, 0), type = "l", lty = 1, xlab = "", ylab = "", main = str, sub = subb[j]) } } else if(fig == 26) { if(DATA == -99.9) { DATA <- auto.stats[, "Turning Circle"] } knots <- 100 par(mfrow = c(1, 4)) X <- as.vector(DATA) aa <- min(X) bb <- max(X) str1 <- paste("min(X) = ", round(aa, 2), sep = "") str2 <- paste("max(X) = ", round(bb, 2), sep = "") str <- paste(str1, str2, sep = ", ") n <- length(X) hist(X, probability = T, xlab = "", ylab = "", breaks = seq(aa, bb, len = l), main = str, sub = paste("n = ", n, sep = "")) ######################now loop with different parameter NN <- order(X) aa <- X[NN[1]] - (X[NN[1 + s]] - X[NN[1]])/s bb <- X[NN[n]] + (X[NN[n]] - X[NN[n - s]])/s if(set.sup[1] != -99.9) { aa <- set.sup[1] bb <- set.sup[2] } str1 <- paste("a = ", round(aa, 2), sep = "") str2 <- paste("b = ", round(bb, 2), sep = "") str <- paste(str1, str2, sep = ", ") X1 <- (X - aa)/(bb - aa) ppp <- c(cJ0, cJ1, cJM, cT, cB) p <- 1 ttt <- c("cJ0 = ", "cJ1 = ", "cJM = ", "cT = ", "cB =") if(arg == "cJ1") { p <- 2 } if(arg == "cJM") { p <- 3 } if(arg == "cT") { p <- 4 } if(arg == "cB") { p <- 5 } for(j in 1:3) { ppp[p] <- set.arg[j] f1 <- estcden(X = X1, knots = knots, cJ0 = ppp[1], cJ1 = ppp[2], cJM = ppp[3], cT = ppp[4], cB = ppp[5])/(bb - aa) f1 <- f1[, 1] plot(c(aa, seq(aa, bb, len = knots), bb), c(0, f1, 0), type = "l", lty = 1, xlab = "", ylab = "", main = paste(ttt[p], set.arg[j], sep = ""), sub = str) } } fff <- paste("Figure 3.", fig, sep = "") if(fig == 1 | fig == 7 | fig == 8 | fig == 9 | fig == 10 | fig == 11 | fig == 14) { fff <- paste(fff, " is not supported", sep = "") } if(fig == 31) { fff <- mat } fff } ################################################################################################################################################ ################################################################################################################################################ ch4<-function(fig = 16, sigma = 1, set.n = c(50, 100, 200), r = 2, cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, cB = 2, n = -99.9, desden = 7, scalefun = 6, s0 = 0.5, s1 = 0.5, wavelet = "s8", snratio = 3, j0 = 6, cJ = 1, cU = 1, signal = "bumps", set.signal = c("doppler", "jumpsine", "crease", "blocks"), set.wavelet = c("s8", "s8", "s8", "haar"), k = 0.5, m0 = 2, m1 = 0.3, m2 = 6, muzeta = 0, muxi = 1, sdzeta = 0.7, sdxi = 0.5, corfun = 2, a = 0.005, b = 0.995, alpha = 0.3, t0 = 0.05, sigmaL = 0.2, cb = 8, d0 = 2, d1 = 0.5, d2 = 10, cH = 1, sigma.xi = 0.2, arg = "cT", set.arg = c(8, 4, 0.1, 0.01), DATAX = chernoff2[, 1], DATAY = chernoff2[, 3], X1=LifeCycleSavings[,2], Y1=LifeCycleSavings[,1], X2 = LifeCycleSavings[,1], Y2=LifeCycleSavings[,3], X3 = chernoff2[, 1], Y3 = chernoff2[, 4], X4 = chernoff2[, 1], Y4 = chernoff2[, 3], m = 6, CFUN = list(NA, NA), t1 = 0.2, t2 = 4, h = 1.45, knots = 50) { ######ch4 titel <- c("1. Uniform", "2. Normal", "3. Bimodal", "4. Strata", "5. Delta", "6. Angle", "7. Monotone", "8. Steps") if (wavelet=="s4"){wavelet="la8"} if (wavelet=="s5"){wavelet="la10"} if (wavelet=="s6"){wavelet="la12"} if (wavelet=="s7"){wavelet="la14"} if (wavelet=="s8"){wavelet="la16"} if (wavelet=="s9"){wavelet="la18"} if (wavelet=="s10"){wavelet="la20"} for(i in 1:length(set.wavelet)){if(set.wavelet[i]=="s4"){set.wavelet[i]="la8"} if(set.wavelet[i]=="s5"){set.wavelet[i]="la10"} if(set.wavelet[i]=="s6"){set.wavelet[i]="la12"} if(set.wavelet[i]=="s7"){set.wavelet[i]="la14"} if(set.wavelet[i]=="s8"){set.wavelet[i]="la16"} if(set.wavelet[i]=="s9"){set.wavelet[i]="la18"} if(set.wavelet[i]=="s10"){set.wavelet[i]="la20"} } if(!is.na(CFUN[[2]])) { titel[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".") } if(fig == 1) { if(n == -99.9) { n <- 100 } par(mfrow = c(2, 4)) for(i in 1:8) { X <- seq(0, 1, len = n) eps <- rnorm(n) ff <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN) Y <- ff + sigma * eps plot(X, Y, type = "p", xlab = "X ", ylab = "Y", main = titel[i]) abline(lsfit(X, Y)) } } else if(fig == 3) { if(n == -99.9) { n <- 100 } par(mfrow = c(2, 4)) z <- seq(0, 1, l = knots) for(i in 1:8) { for(n1 in set.n) { X <- seq(0, 1 - 1/n1, len = n1) eps <- rnorm(n1) ff <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN) Y <- ff + sigma * eps if(n1 == n) { X1 <- X Y1 <- Y } est <- estcregm(X = X, Y = Y, method = 2, knots = knots, r = r, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT) f.est <- negden(est, FLAGBUMP = 1, cB = cB) if(n1 == set.n[1]) { f <- f.est } else { f <- cbind(f, f.est) } } f <- cbind(dcornerf(c = i, knots = knots, CFUN = CFUN), f) llim <- range(f) llim <- range(c(llim, range(Y1))) matplot(z, f, type = "l", lty = 1:4, xlab = "X", ylab = "Y", main = titel[i], ylim = llim) lines(X1, Y1, type = "p", pch = 2) } } else if(fig == 4) { if(n == -99.9) { n <- 100 } par(mfrow = c(2, 4)) for(i in 1:8) { X <- rcornerf(c = desden, n = n, CFUN = CFUN) Y <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN) + sigma * dcornerf(c = scalefun, X = X, flag = 1) * rnorm(n) plot(X, Y, type = "p", xlab = "X ", ylab = "Y", main = titel[i]) abline(lsfit(X, Y)) } } else if(fig == 5) { if(n == -99.9) { n <- 100 } par(mfrow = c(2, 4)) z <- seq(0, 1, l = knots) for(i in 1:8) { for(n1 in set.n) { X <- rcornerf(c = desden, n = n1, CFUN = CFUN) eps <- rnorm(n1) ff <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN) Y <- ff + sigma * dcornerf(c = scalefun, X = X, flag = 1) * eps if(n1 == n) { X1 <- X Y1 <- Y } est <- estcregm(X = X, Y = Y, method = 4, knots = knots, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) f.est <- negden(est, FLAGBUMP = 1, cB = 2) if(n1 == set.n[1]) { f <- f.est } else { f <- cbind(f, f.est) } } f <- cbind(dcornerf(c = i, knots = knots, CFUN = CFUN), f) llim <- range(f) llim <- range(c(llim, range(Y1))) matplot(z, f, type = "l", lty = 1:4, xlab = "X", ylab = "Y", main = titel[i], ylim = llim) lines(X1, Y1, type = "p", pch = 2) } } else if(fig == 6) { if(n == -99.9) { n <- 100 } par(mfrow = c(2, 4)) z <- seq(0, 1, l = knots) for(i in 1:8) { for(n1 in set.n) { X <- rcornerf(c = desden, n = n1, CFUN = CFUN) eps <- rnorm(n1) ff <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN) Y <- ff + sigma * dcornerf(c = scalefun, X = X, flag = 1) * eps if(n1 == n) { X1 <- X Y1 <- Y } f.est <- estcregs(X = X, Y = Y, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, method = 4, s0 = s0, s1 = s1, r = r, cB = cB) if(n1 == set.n[1]) { f <- f.est } else { f <- cbind(f, f.est) } } f <- cbind(sigma * dcornerf(c = scalefun, knots = knots, CFUN = CFUN), f) llim <- range(f) llim <- range(c(llim, range(Y1))) matplot(z, f, type = "l", lty = 1:4, xlab = "X", ylab = "Y", main = titel[i], ylim = llim) lines(X1, Y1, type = "p", pch = 2) } } else if(fig == 8) { if(n == -99.9) { n <- 1024 } snr <- snratio noise.set <- c(1, 0.4) set.signal <- c("cubic", "ramp") set.wavelet <- c(wavelet, wavelet) set.tit1 <- c("SINGCUBIC", "SINGRAMP") set.tit2 <- c("NOISY SINGCUBIC", "NOISY SINGRAMP") par(mfcol = c(4, 2)) for(j in 1:2) { sign <- make.signal2(set.signal[j], seq(0,1,len = n)) signN <- make.signal2(set.signal[j], seq(0,1,len = n), snr = snr) sign.dwt <- dwt(sign, filter = set.wavelet[j],n.levels=j0) sign.dwt@W[["W1"]][155] <- noise.set[j] if(j == 2) { sign.dwt@W[["W2"]][130] <- noise.set[j] } sign <- idwt(sign.dwt) signN.dwt <- dwt(signN, filter = set.wavelet[j],n.levels=j0) signN.dwt@W[["W1"]][155] <- noise.set[j] if(j == 2) { signN.dwt@W[["W2"]][130] <- noise.set[j] } signN <- idwt(signN.dwt) plot(seq(0, 1, len = n),signN, type = "l", xlab = " ", ylab = " ", main = set.tit2[j]) f.ql <- idwt(qlestJ(J = j0, signal = signN, wavelet = set.wavelet[j], cT = cT, cU = cU, cJ = cJ)$func) plot(seq(0, 1, len = n),f.ql, type = "l", xlab = " ", ylab = " ", main = "UNIVERSAL") ##### plot(waveshrink(signN, wavelet = set.wavelet[j], shrink.rule = "adapt"), type = "l", xlab = "", ylab = "", main = "SURESHRINK") signN.wcn<- dwt(signN,filter=set.wavelet[j],n.levels=j0) plot( seq(0, 1, len = n),idwt(wdenr(signN.wcn,J=j0,thresh='s',den='hs')),type = "l", xlab = "", ylab = "", main = "SURESHRINK") plot(seq(0, 1, len = n),sign, type = "l", xlab = " ", ylab = " ", main = set.tit1[j]) } } else if(fig == 9) { if(n == -99.9) { n <- 1024 } sign <- make.signal2(signal, seq(0,1,len = n)) signN <- make.signal2(signal, seq(0,1,len = n), snr = snratio) f.ql <- idwt(qlestJ(J = j0, signal = signN, wavelet = wavelet, cT = cT, cU = cU, cJ = cJ)$func) par(mfrow = c(1, 4)) plot.wav(dwt(sign, filter = wavelet,n.levels=j0),wds=j0,main="",xlab="",ylab="") title("Signal") plot.wav(dwt(signN, filter = wavelet,n.levels=j0),wds=j0,main="",xlab="",ylab="") title(main = "Noisy Signal") plot.wav(dwt(f.ql, filter = wavelet,n.levels=j0),wds=j0,main="",xlab="",ylab="") title("Universal") ##### plot(dwt(waveshrink(signN, filter = wavelet, shrink.rule = "adapt"))) signN.wcn<- dwt(signN,filter=wavelet,n.levels=j0) plot.wav( wdenr(signN.wcn,J=j0,thresh='s',den='hs'),wds=j0,main="",xlab="",ylab="") title("SureShrink") } else if(fig == 10) { if(n == -99.9) { n <- 1024 } snr <- snratio flagJ <- 1 J <- 6 coefvar <- 2 set.tit1 <- set.signal # set.tit2 <- c("NOISY DOPPLER", "NOISY JUMPSINE", "NOISY CREASE", # "NOISY BLOCKS") set.tit2 <- c(paste("noisy ", set.tit1[1]), paste("noisy ", set.tit1[2]), paste("noisy ", set.tit1[3]), paste("noisy ", set.tit1[4])) par(mfcol = c(4, 4)) for(j in 1:4) { sign <- make.signal2(set.signal[j], seq(0,1,len = n)) plot(seq(0, 1, len = n),sign, type = "l", xlab = " ", ylab = " ", main = set.tit1[j]) signN <- make.signal2(set.signal[j], seq(0,1,len = n), snr = snr) plot(seq(0, 1, len = n),signN, type = "l", xlab = " ", ylab = " ", main = set.tit2[j]) f.ql <- idwt(qlestJ(J = j0, signal = signN, wavelet = set.wavelet[j], cT = cT, cU = cU, cJ = cJ)$func) plot(seq(0, 1, len = n),f.ql, type = "l", xlab = " ", ylab = " ", main = "UNIVERSAL") ##### plot(waveshrink(signN, wavelet = set.wavelet[j], shrink.rule = "adapt"), type = "l", xlab = "", ylab = "", main = "SURESHRINK") signN.wcn<- dwt(signN,filter=set.wavelet[j],n.levels=j0) plot( seq(0, 1, len = n),idwt(wdenr(signN.wcn,J=j0,thresh='s',den='hs')),type = "l", xlab = "", ylab = "", main = "SURESHRINK") } } else if(fig == 11) { if(n == -99.9) { n <- 100 } method <- 4 par(mfrow = c(2, 4)) z <- seq(0, 1, len = knots) for(i in 1:8) { for(n1 in set.n) { X <- rcornerf(c = desden, n = n1, CFUN = CFUN) ff <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN)/max(dcornerf(c = i, X = X, flag = 1, CFUN = CFUN)) if(i == 1) { ff <- ((3/4) * ff)/ff } U <- runif(n1) Y <- rep(1, n1) Y[U > ff] <- 0 if(n1 == n) { X1 <- X Y1 <- Y } est <- estcregm(X = X, Y = Y, method = method, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, knots = knots) est <- negden(est, FLAGBUMP = 1, cB = cB) est[est > 1] <- 1 if(n1 == set.n[1]) { f <- est } else { f <- cbind(f, est) } } f9 <- dcornerf(c = i, knots = knots, CFUN = CFUN) if(i == 1) { f <- cbind((3 * f9)/4, f) } else { f <- cbind(f9/max(f9), f) } llim <- range(f) llim <- range(c(llim, range(Y1))) matplot(z, f, type = "l", lty = 1:4, xlab = "X", ylab = "Y", main = titel[i], ylim = llim) lines(X1, Y1, type = "p", pch = 2) } } else if(fig == 12) { ##########Poisson Regression if(n == -99.9) { n <- 100 } method <- 4 par(mfrow = c(2, 4)) z <- seq(0, 1, l = knots) for(i in 1:8) { for(n1 in set.n) { X <- rcornerf(c = desden, n = n1, CFUN = CFUN) ff <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN)/max(dcornerf(c = i, X = X, flag = 1, CFUN = CFUN)) if(i == 1) { ff <- ((3/4) * ff)/ff } for(j in 1:n1) { if(j == 1) { Y <- rpois(1, lambda = ff[j]) } else { Y <- c(Y, rpois(1, lambda = ff[j])) } } if(n1 == n) { X1 <- X Y1 <- Y } est <- estcregm(X = X, Y = Y, method = method, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, knots = knots) est <- negden(est, FLAGBUMP = 1, cB = cB) if(n1 == set.n[1]) { f <- est } else { f <- cbind(f, est) } } f9 <- dcornerf(c = i, knots = knots, CFUN = CFUN) if(i == 1) { f <- cbind((3 * f9)/4, f) } else { f <- cbind(f9/max(f9), f) } llim <- range(f) llim <- range(c(llim, range(Y1))) matplot(z, f, type = "l", lty = 1:4, xlab = "X", ylab = "Y", main = titel[i], ylim = llim) lines(X1, Y1, type = "p", pch = 2) } } else if(fig == 13) { ##########Cauchy Errors if(n == -99.9) { n <- 50 } par(mfrow = c(2, 4)) z <- seq(0, 1, l = 100) for(i in 1:8) { X <- seq(0, 1, len = 50) ff <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN) Y <- ff + rcauchy(50, scale = k) plot(X, Y, type = "p", xlab = "X ", ylab = "Y ", main = titel[i]) abline(lsfit(X, Y)) } } else if(fig == 14) { # this is median regression with traditional cutoff par(mfrow = c(2, 4)) z <- seq(0, 1, len = knots) for(i in 1:8) { if(i == 5) { knots <- 100 } for(n1 in set.n) { X <- runif(n1) ff <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN) Y <- ff + rcauchy(n1, scale = k) est <- estcregmed(X = X, Y = Y, method = 4, m0 = m0, m1 = m1, m2 = m2, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, knots = knots) est <- negden(est, FLAGBUMP = 1, cB = cB) if(n1 == set.n[1]) { f <- est } else { f <- cbind(f, est) } } f <- cbind(dcornerf(c = i, knots = knots, CFUN = CFUN), f) z <- seq(0, 1, len = knots) z <- matrix(z, ncol = 1) matplot(z, f, type = "l", lty = 1:(length(set.n) + 1), xlab = " ", ylab = " ", main = titel[i]) } } else if(fig == 15) { ##########this is for quartiles knots <- 100 par(mfrow = c(2, 4)) if(n == -99.9) { n <- 100 } for(i in 1:8) { X <- seq(0, 1, len = n) Y <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN) + sigma * dcornerf(c = 6, X = X, flag = 1) * rnorm(n) est1 <- estcregmed(X = X, Y = Y, alpha = 0.25, method = 4, m0 = m0, m1 = m1, m2 = m2, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, knots = knots) # est1 <- negden(est1, FLAGBUMP = 1, cB = cB) est2 <- estcregmed(X = X, Y = Y, alpha = 0.75, method = 4, m0 = m0, m1 = m1, m2 = m2, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, knots = knots) # est2 <- negden(est2, FLAGBUMP = 1, cB = cB) plot(X, Y, type = "p", xlab = "X ", ylab = "Y", main = titel[i], pch = 2) z <- seq(0, 1, len = 100) lines(z, est1, type = "l", lty = 2, col = 2) lines(z, est2, type = "l", lty = 3, col = 3) lines(z, dcornerf(c = i, knots = 100, CFUN = CFUN), type = "l", lty = 1) } } else if(fig == 16) { if(n == -99.9) { n <- 100 } par(mfrow = c(2, 4)) knots <- 100 z <- seq(0, 1, len = knots) for(i in 1:8) { if(i == 5) { knots <- 100 } X <- seq(0, 1, len = n) ff <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN) U <- runif(n) Y <- ff + sigma * rnorm(n, sd = 1 + abs(t2 - 1) * rbinom(n, 1, t1)) estcl <- estcregm(X = X, Y = Y, method = 4, knots = knots, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) estcl <- negden(estcl, FLAGBUMP = 1, cB = cB) estm <- estcregmed(X = X, Y = Y, alpha = 0.5, method = 4, m0 = m0, m1 = m1, m2 = m2, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, knots = knots) estm <- negden(estm, FLAGBUMP = 1, cB = cB) scale1 <- mad(Y - estm) esth <- estcregmed(X = X, Y = Y, method = 4, m0 = m0, m1 = m1, m2 = m2, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, knots = knots, FLAGH = 1, scale = scale1, param = h) esth <- negden(esth, FLAGBUMP = 1, cB = cB) plot(X, Y, type = "p", xlab = " ", ylab = " ", main = titel[i]) f <- dcornerf(c = i, knots = knots, CFUN = CFUN) z <- seq(0, 1, len = knots) z <- matrix(z, ncol = 1) lines(z, f, type = "l", lty = 1, col = 1) lines(z, estcl, type = "l", lty = 2, col = 2) lines(z, estm, type = "l", lty = 3, col = 3) lines(z, esth, type = "l", lty = 4, col = 4) } } else if(fig == 17) { #this is for mixtures###### if(n == -99.9) { n <- 100 } par(mfrow = c(2, 4)) z <- seq(0, 1, len = knots) for(i in 1:8) { for(n1 in set.n) { X <- seq(0, 1, len = n1) ff <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN)/max(dcornerf(c = i, X = X, flag = 1, CFUN = CFUN)) if(i == 1) { ff <- ((3/4) * ff)/ff } eta <- rnorm(n1, mean = muzeta, sd = sdzeta) xi <- rnorm(n1, mean = muxi, sd = sdxi) fff <- rep(0, n1) fff[runif(n1) < ff] <- 1 Y <- eta * fff + (1 - fff) * xi if(n1 == n) { X1 <- X Y1 <- Y } Y <- (Y - muxi)/(muzeta - muxi) est <- estcregm(X = X, Y = Y, method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, knots = knots) est <- negden(est, FLAGBUMP = 1, cB = cB) est[est > 1] <- 1 if(n1 == set.n[1]) { f <- est } else { f <- cbind(f, est) } } f9 <- dcornerf(c = i, knots = knots, CFUN = CFUN) if(i == 1) { f <- cbind((3 * f9)/4, f) } else { f <- cbind(f9/max(f9), f) } llim <- range(f) llim <- range(c(llim, range(Y1))) matplot(z, f, type = "l", lty = 1:4, xlab = "X", ylab = "Y", main = titel[i], ylim = llim) lines(X1, Y1, type = "p", pch = 2) } } else if(fig == 18) { par(mfcol = c(2, length(set.n))) for(n1 in set.n) { X <- runif(n1) error <- sigma * fractgn(n = n1, alpha = alpha)$z Z <- seq(0, 1, len = n1) YR <- dcornerf(c = corfun, X = X, flag = 1, CFUN = CFUN) + error YF <- dcornerf(c = corfun, X = Z, flag = 1, CFUN = CFUN) + error f <- dcornerf(c = corfun, X = Z, flag = 1, CFUN = CFUN) estR <- estcregm(X = X, Y = YR, method = 4, knots = n1, r = r, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT) # estR <- negden(estR, FLAGBUMP = 1, cB = cB) estF <- estcregm(X = Z, Y = YF, method = 4, knots = n1, r = r, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT) # estF <- negden(estF, FLAGBUMP = 1, cB = cB) str <- paste(" alpha =", alpha) matplot(cbind(Z, Z, Z), cbind(f, estF, YF), type = "llp", lty = c(1, 3, 1), pch = c(1, 1, 2), xlab = "", ylab = "Y", sub = paste("n = ", n1), main = paste( "FIXED DESIGN", str, sep = ",")) matplot(cbind(Z, Z, X), cbind(f, estR, YR), type = "llp", lty = c(1, 3, 1), pch = c(1, 1, 2), xlab = "", ylab = "Y", sub = paste("n = ", n1), main = paste( "RANDOM DESIGN", str, sep = ",")) } } else if(fig == 19) { ########categorical data---illustration of the data if(n == -99.9) { n <- 50 } par(mfrow = c(1, 2)) X <- rcornerf(c = desden, n = n, CFUN = CFUN) Y1 <- dcornerf(c = corfun, X = X, flag = 1, CFUN = CFUN) + sigma * rnorm(n) Y <- 0 * Y1 bound.set <- c(-50, -1, 1, 3, 50) m <- length(bound.set) - 1 for(i in 1:m) { Y[bound.set[i] <= Y1 & Y1 < bound.set[i + 1]] <- i } plot(X, Y1, type = "p", xlab = "X", ylab = "Y", main = "UNOBSERVED DATA", xlim = c(0, 1)) for(i in c(-1, 1, 3)) { lines(seq(0, 1, len = 30), rep(i, 30), type = "l", lty = 2) } plot(seq(0, 1, len = 10), seq(-2, 4, len = 10), type = "n", yaxp = c(-2, 4, 7), xlab = "X", ylab = "CATEGORY", main = "CATEGORICAL DATA", xlim = c(0, 1)) text(X[Y == 1], rep(-2, length(X[Y == 1])), labels = "1") text(X[Y == 2], rep(0, length(X[Y == 2])), labels = "2") text(X[Y == 3], rep(2, length(X[Y == 3])), labels = "3") text(X[Y == 4], rep(4, length(X[Y == 4])), labels = "4") } else if(fig == 20) { ########categorical data estimates ##########do not use est.f which is for testing the scoring if(n == -99.9) { n <- 100 } par(mfrow = c(2, 4)) knots <- 50 z <- seq(0, 1, len = n) for(i in 1:8) { X <- rcornerf(c = desden, n = n, CFUN = CFUN) Y1 <- dcornerf(c = i, X = X, flag = 1, CFUN = CFUN) + sigma * rnorm(n) Y <- 0 * Y1 bound.set <- c(-50, -1, 1, 3, 50) m <- length(bound.set) - 1 for(j in 1:m) { Y[bound.set[j] <= Y1 & Y1 < bound.set[j + 1]] <- j } est <- estcregcat(X = X, Y = Y, method = 4, bound.set = bound.set, knots = n, a = a, b = b, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, cB = cB) est.f1 <- est$f.pilot1 est.prob <- est$est.prob est1 <- negden(est.f1, FLAGBUMP = 1, cB = cB) z <- matrix(z, ncol = 1) matplot(z, cbind(dcornerf(c = i, knots = n, CFUN = CFUN), est1, est.prob), type = "l", lty = c(1, 2, 3), xlab = "X ", ylab = " ", main = titel[i]) } } else if(fig == 21) { if(n == -99.9) { n <- 50 } illp.heat1expb(knots = n, time = t0, sigma = sigmaL, J.MAX = m) } else if(fig == 22) { if(n == -99.9) { n <- 100 } knots <- n par(mfrow = c(2, 4)) z <- seq(0, 1, len = knots) for(i in 1:8) { U <- runif(n) X <- U + rnorm(n, sd = sigma.xi) Y <- dcornerf(c = i, X = U, flag = 1, CFUN = CFUN) + sigma * rnorm(n) f.est1 <- estcreg.erpred(Y = Y, X = X, knots = knots, cb = cb, d0 = d0, d1 = d1, d2 = d2, cH = cH, sigma.xi = sigma.xi) f.est <- negden(f.est1, FLAGBUMP = 1, cB = 0.5) plot(X, Y, type = "p", pch = 2, xlab = "U", ylab = "Y", main = titel[i]) lines(z, f.est, type = "l", lty = 2, col = 2) lines(seq(0, 1, len = 100), dcornerf(c = i, knots = 100, CFUN = CFUN), type = "l", lty = 1, col = 1) } } else if(fig == 23) { par(mfrow = c(3, 4)) mm <- c("(a)", "(b)", "(c)", "(d)") for(i in 1:3) for(j in 1:4) { if(j == 1) { X <- X1 Y <- Y1 } else if(j == 2) { X <- X2 Y <- Y2 } else if(j == 3) { X <- X3 Y <- Y3 } else { X <- X4 Y <- Y4 } if(i == 1) { plot(X, Y, main = mm[j], pch = 3, sub = paste("n", length(X), sep = " = ")) } else if(i == 2) { plot(X, Y, pch = 3) abline(lsfit(X, Y)) } else { aa <- min(X) bb <- max(X) X1 <- (X - aa)/(bb - aa) f.est <- estcregm(X = X, Y = Y, knots = 100, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, method = 4) ######################################################## plot(X, Y, pch = 3) lines(seq(aa, bb, len = 100), f.est, type = "l") } } } else if(fig == 24) { X <- as.vector(DATAX) Y <- as.vector(DATAY) n <- length(X) aa <- min(X) bb <- max(X) X1 <- (X - aa)/(bb - aa) par(mfrow = c(1, length(set.arg))) ppp <- c(cJ0, cJ1, cJM, cT, r, s0, s1) names <- c("cJ0", "cJ1", "cJM", "cT", "r", "s0", "s1") j <- 1 for(i in 2:7) { if(arg == names[i]) { j <- i } } for(i in 1:length(set.arg)) { ppp[j] <- set.arg[i] a <- ppp f.est <- estcregm(X = X1, Y = Y, knots = 100, cJ0 = a[1], cJ1 = a[2], cJM = a[3], cT = a[4], r = a[5], s0 = a[6], s1 = a[7], method = 4) plot(X, Y, pch = 3, xlab = "X", ylab = "Y", ylim = c(min(min(f.est), min(Y)), max(max(f.est), max(Y))), main = paste(names[j], set.arg[i], sep = " = "), sub = paste("n", n, sep = " = ")) lines(seq(aa, bb, len = 100), f.est, type = "l") } } fff <- paste("Figure 4.", fig, sep = "") if(fig == 2 | fig == 7 | fig < 1 | fig > 24) { fff <- paste(fff, " is not supported", sep = "") } fff } ################################################################################################################################################ ################################################################################################################################################ ch5<-function(fig = 12, set.seas = c(1, 2, 6), a = -99.9, b = -99.9, sigma = -99.9, sigmasc = 0.5, s0 = 0.5, s1 = 0.5, cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, r = 2, cB = 2, n = -99.9, cJ0sp = 4, cJ1sp = 0.5, cJMsp = 6, cTsp = 4, cBsp = 2, Per = 20, trendf = 3, scalef = 2, ss = 1, sc = 1, set.obs = c(1, 1, 1, 1, 1, 0, 0), set.period = c(8, 12), set.lambda = c(0, 2), lbscale = 0.1, TMAX = 35, Tseas = 10, set.adc = c(2, 4, 7), w1 = c(2, 1.5, 1), w2 = c(1, 2, 1.7), w3 = c(1.4, 1.5, 2), w4 = c(1, 1, 1, 1), set.sigma1 = c(0, 2, 5), wc = c(1, 2, 3), JW = 5, sigma1 = 1, sigma2 = 1, DELAY = 3, bP = 0.4, bS = 0.8, price0 = 1, sigmaP = 1, sigmaS = 0.5, ManualPer = F, seasest = "c", DATA = hstart, FLAGNEG = 0, CFUN = list(NA, NA), A = 2, B = 2, sd = 1, jump = 0.8) { ####ch5 (Time series) if(a == -99.9) { if(fig == 4 | fig == 5 | fig == 6 | fig == 12 | fig == 14) { a <- -0.3 } else { a <- 0.4 } } if(sigma == -99.9) { if(fig == 1 | fig == 2) { sigma <- 1 } else if(fig == 12) { sigma <- 2 } else if(fig == 13) { sigma <- 0.3 } else { sigma <- 0.5 } } if(n == -99.9) { if(fig == 1 | fig == 2 | fig == 13) { n <- 100 } else { n <- 120 } } if(b == 0) { b <- 0.01 } if(cJ0 == -99.9) { cJ0 <- 4 if(fig == 13) { cJ0 <- 1 } } titel <- c("1. Uniform", "2. Normal", "3. Bimodal", "4. Strata", "5. Delta", "6. Angle", "7. Monotone", "8. Steps") if(!is.na(CFUN[[2]])) { titel[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".") } ########################################################################## ########################################################################## if(fig == 1) { par(mfrow = c(3, 1)) z <- seq(0, 1, l = 100) if(b == -99.9) { b <- 0.3 } m <- ceiling(n/Per) for(i in set.seas) { # eps <- arima.sim(n, model = list(ar = a, ma = (-1) * b)) eps <- arima.sim(n, model = list(ar = a, ma = b)) X <- seq(0, 1, len = Per) ff <- rep((dcornerf(c = i, X = X, flag = 1, CFUN = CFUN) - 1), m) Y <- ff[1:n] + sigma * eps f <- matrix(ff[1:n], ncol = 1) Y <- matrix(Y, ncol = 1) matplot(1:n, cbind(f, Y), type = "l", lty = c(1, 2), xlab = " ", ylab = " ", main = titel[i]) lines(1:n, Y, type = "p", pch = 0, cex = 1.5, col = 2) } } else if(fig == 2) { if(b == -99.9) { b <- 0.3 } par(mfrow = c(2, 4)) z <- seq(1, Per, len = 50) m <- floor(n/Per) for(i in 1:8) { # eps <- arima.sim(n, model = list(ar = a, ma = (-1) * b)) eps <- arima.sim(n, model = list(ar = a, ma = b)) eps <- matrix(eps[1:(m * Per)], ncol = m, nrow = Per, byrow = F) eps <- apply(eps, 1, mean) X <- seq(0, 1, len = Per) ff <- matrix(dcornerf(c = i, X = X, flag = 1, CFUN = CFUN), ncol = 1) - 1 Y <- ff + sigma * eps f.est <- estcregm(X = X, Y = Y, knots = 50, method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) ff <- dcornerf(c = i, knots = 100, CFUN = CFUN) - 1 ymin <- min(min(Y), min(ff)) ymax <- max(max(Y), max(ff)) plot(seq(1, Per, len = 100), ff, type = "l", lty = 1, xlab = " ", ylab = " ", main = titel[i], ylim = c(ymin, ymax), col = 1) lines(z, f.est, type = "l", lty = 3, col = 3) lines(1:Per, Y, type = "l", lty = 2, col = 2) lines(1:Per, Y, type = "p", pch = 2, col = 2) } } else if(fig == 3) { if(b == -99.9) { b <- 0.5 } par(mfrow = c(4, 1)) # Y <- sigma * arima.sim(n, model = list(ar = a, ma = (-1) * b)) Y <- sigma * arima.sim(n, model = list(ar = a, ma = b)) plot(1:n, Y, type = "p", pch = 0, main = "1. Data", xlab = "", ylab = "") lines(1:n, Y, type = "l") f <- spden.arma(ar = a, ma = b, knots = 100, sigma = sigma) z <- seq(0, 1, len = 100) * pi plot(z, f, type = "l", main = "2. Spectral Density", xlab = "", ylab = "") spect <- spec.pgram(Y, taper = 0,plot=FALSE) z <- seq(0, 1, len = length(spect$freq)) * pi plot(z, (10^(spect$spec/10))/(2 * pi), type = "l", main = "3. Periodogram", xlab = "", ylab = "") est.nonp <- estspden(X = Y, knots = 100, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp) plot(seq(0, pi, l = 100), est.nonp, type = "l", main = "4. The Estimated Spectral Density", xlab = "", ylab = "") } else if(fig == 4 | fig == 5) { knots <- 1000 if(b == -99.9) { b <- -0.5 } JMAX <- floor((2 * n)/TMAX) par(mfrow = c(5, 2)) X <- seq(0, 1, len = n) ff <- dcornerf(c = trendf, X = seq(0, 1, len = n), flag = 1, CFUN = CFUN) ff <- ff + ss * sin((2 * pi * (1:n))/Tseas) + sc * cos((2 * pi * (1:n))/Tseas) plot(1:n, ff, type = "l", main = "1. Deterministic Part", xlab = "", ylab = "") scale <- 1 + dcornerf(c = scalef, X = seq(0, 1, len = n), flag = 1, CFUN = CFUN) # eps <- arima.sim(n, model = list(ar = a, ma = (-1) * b)) eps <- arima.sim(n, model = list(ar = a, ma = b)) eps <- eps/(var(eps))^(1/2) Y <- ff + scale * sigmasc * eps plot(1:n, Y, main = "2. Data", xlab = "", ylab = "") f.est <- estcregm(X = X, Y = Y, knots = n, method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, JJMAX = JMAX) fff <- dcornerf(c = trendf, X = seq(0, 1, len = n), flag = 1, CFUN = CFUN) matplot(1:n, cbind(fff, f.est), type = "l", lty = c(1, 3), main = "3. The Estimated Trend", xlab = "", ylab = "") res <- Y - f.est plot(1:n, res, main = "4. Detrended Data", xlab = "", ylab = "") est.nonp <- estspden(X = res, knots = knots, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp) nn1 <- 1 + floor((knots * set.lambda[1])/pi) nn2 <- floor((knots * set.lambda[2])/pi) period1 <- (2 * pi)/((pi * order(est.nonp[nn1:nn2])[nn2 - nn1])/knots) plot(seq(0, pi, l = knots), est.nonp, type = "l", main = "5. Spectral Density of Detrended Data", xlab = "", ylab = "", sub = paste("THE ESTIMATED PERIOD =", round(period1, digits = 2), sep = "")) if(ManualPer) { period <- scan() } else { period <- round(period1) } if(period >= set.period[1] & period <= set.period[2]) { seas <- matrix(res, ncol = period, nrow = floor(length(X)/period), byrow = T) seas <- apply(seas, 2, mean) f.est <- estcregm(X = seq(0, 1, len = period), Y = seas, knots = period, method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) plot(1:period, f.est, type = "l", ylim = c(min(seas), max(seas)), main = "6. The Estimated Seasonal Component", xlab = "", ylab = "", sub = paste( "THE USED PERIOD = ", period, sep = "")) lines(1:period, seas, type = "p", pch = 0, cex = 1.5) if(seasest == "u") { seas <- f.est } res <- res - rep(seas, ceiling(n/period + 5))[1:n] plot(1:n, res, main = "7. Detrended and Deseasonalized Data", xlab = "", ylab = "", sub = paste("THE USED SEASEST = ", seasest, sep = "")) } else { warning("Estimated period is beyond the assigned interval") } scale.est <- estcregm(X = X, Y = res^2, knots = n, method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) scale.est[scale.est < lbscale] <- lbscale scale.est <- scale.est^(1/2) matplot(1:n, cbind(scale * sigmasc, scale.est), type = "l", lty = c(1, 3), main = "8. Estimated Scale Function", xlab = "", ylab = "") res <- res/(scale.est + 0.01) res <- res - mean(res) plot(1:n, res, main = "9. Rescaled Residuals", xlab = "", ylab = "") est.nonp <- estspden(X = res, knots = knots, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp) #coeff <- arima.mle(res, model = list(order = c(1, 0, 1)))$model coeff <- arima(res, order = c(1, 0, 1),include.mean=FALSE,method="ML")$model # cfar <- signif(coeff$ar, digits = 2) cfar <- signif(coeff$phi, digits = 2) # cfma <- signif((-1) * coeff$ma, digits = 2) cfma <- signif(coeff$theta, digits = 2) tt1 <- paste("est.a = ", cfar, collapse = "") tt2 <- paste("est.b = ", cfma, collapse = "") tt <- paste(c(tt1, tt2), collapse = " ") f <- spden.arma(ar = a, ma = b, knots = knots, sigma = sigma) f <- matrix(f, ncol = 1) est.nonp <- matrix(est.nonp, ncol = 1) matplot(seq(0, pi, len = knots), cbind(f, est.nonp), type = "l", lty = c(1, 3), main = "10. Spectral Density of Rescaled Residuals", xlab = "", ylab = "", sub = tt) } else if(fig == 6) { knots <- 1000 if(b == -99.9) { b <- -0.5 } JMAX <- floor((2 * n)/TMAX) par(mfrow = c(5, 2)) X <- seq(0, 1, len = n) ff <- dcornerf(c = trendf, X = seq(0, 1, len = n), flag = 1, CFUN = CFUN) ff <- ff + ss * sin((2 * pi * (1:n))/Tseas) + sc * cos((2 * pi * (1:n))/Tseas) Tobs <- length(set.obs) m <- floor(n/Tobs) X1 <- rep(set.obs, m) if(m * Tobs < n) { X1 <- c(X1, set.obs[1:(n - m * Tobs)]) } XO <- (1:n)[X1 == 1] ffO <- ff[X1 == 1] plot(XO, ffO, type = "p", main = "1. Deterministic Part", xlab = "", ylab = "") scale <- 1 + dcornerf(c = scalef, X = seq(0, 1, len = n), flag = 1, CFUN = CFUN) # eps <- arima.sim(n, model = list(ar = a, ma = (-1) * b)) eps <- arima.sim(n, model = list(ar = a, ma = b)) eps <- eps/(var(eps))^(1/2) Y <- ff + scale * sigmasc * eps YO <- Y[X1 == 1] plot(XO, YO, main = "2. Data", xlab = "", ylab = "") f.est <- estcregm(X = XO/n, Y = YO, knots = n, method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, JJMAX = JMAX) fff <- dcornerf(c = trendf, X = seq(0, 1, len = n), flag = 1, CFUN = CFUN) matplot(1:n, cbind(fff, f.est), type = "l", lty = c(1, 3), main = "3. The Estimated Trend", xlab = "", ylab = "") res <- Y - f.est resO <- res[X1 == 1] res <- res - mean(resO) plot(XO, resO, main = "4. Detrended Data", xlab = "", ylab = "") est.nonp <- estspden(X = (res * X1), TT = X1, FLAGMIS = 1, knots = knots, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp) nn1 <- 1 + floor((knots * set.lambda[1])/pi) nn2 <- floor((knots * set.lambda[2])/pi) period1 <- (2 * pi)/((pi * order(est.nonp[nn1:nn2])[nn2 - nn1])/knots) plot(seq(0, pi, l = knots), est.nonp, type = "l", main = "5. Spectral Density of Detrended Data", xlab = "", ylab = "", sub = paste("THE ESTIMATED PERIOD = ", round(period1, digits = 2), sep = "")) period <- round(period1) if(ManualPer == T) { period <- scan() } if(period >= set.period[1] & period <= set.period[2]) { seas <- matrix(res * X1, ncol = period, nrow = floor(n/period), byrow = T) seas <- apply(seas, 2, mean) nnn <- matrix(X1, ncol = period, nrow = floor(n/period), byrow = T) nnn <- apply(nnn, 2, mean) seas <- seas/nnn f.est <- estcregm(X = seq(0, 1, len = period), Y = seas, knots = period, method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) plot(1:period, f.est, type = "l", ylim = c(min(seas), max(seas)), main = "6. The Estimated Seasonal Component", xlab = "", ylab = "", sub = paste( "THE USED PERIOD = ", period, sep = "")) lines(1:period, seas, type = "p", pch = 0, cex = 1.5) if(seasest == "u") { seas <- f.est } res <- res - rep(seas, 15)[1:n] resO <- res[X1 == 1] plot(XO, resO, main = "7. Detrended and Deseasonalized Data", xlab = "", ylab = "", sub = paste("THE USED SEASEST = ", seasest, sep = "")) } else { warning("The estimated period is beyond the assigned interval") } scale.est <- estcregm(X = XO/n, Y = resO^2, knots = n, method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) scale.est[scale.est < lbscale] <- lbscale scale.est <- scale.est^(1/2) matplot(1:n, cbind(scale * sigmasc, scale.est), type = "l", lty = c(1, 3), main = "8. Estimated Scale Function", xlab = "", ylab = "") res <- res/(scale.est + 0.01) res <- res - mean(res[X1 == 1]) plot(XO, res[X1 == 1], main = "9. Rescaled Residuals", xlab = "", ylab = "") est.nonp <- estspden(X = (res * X1), TT = X1, FLAGMIS = 1, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = 2) # coeff <- arima.mle(res, model = list(order = c(1, 0, 1)))$model coeff <- arima(res, order = c(1, 0, 1), include.mean = FALSE, method = "ML")$model # cfar <- signif(coeff$ar, digits = 2) cfar <- signif(coeff$phi, digits = 2) # cfma <- signif((-1) * coeff$ma, digits = 2) cfma <- signif(coeff$theta, digits = 2) tt1 <- paste("est.a = ", cfar, collapse = "") tt2 <- paste("est.b = ", cfma, collapse = "") tt <- paste(c(tt1, tt2), collapse = " ") f <- spden.arma(ar = a, ma = b, knots = knots, sigma = sigma) f <- matrix(f, ncol = 1) est.nonp <- matrix(est.nonp, ncol = 1) matplot(seq(0, pi, len = knots), cbind(f, est.nonp), type = "l", lty = c(1, 3), main = "10. Spectral Density of Rescaled Residuals", xlab = "", ylab = "", sub = tt) } else if(fig == 7) { K <- length(set.adc) par(mfcol = c(K, 2)) z <- seq(0, 1, l = n) if(b == -99.9) { b <- 0.3 } titel1 <- c("First Noisy Composition", "Second Noisy Composition", "Third Noisy Composition", "Fourth Noisy Composition") titel2 <- c("First Component", "Second Component", "Third Component", "Fourth Component") ww1 <- c("w11 = ", "w12 = ", "w13 = ", "w14 = ") ww2 <- c("w21 = ", "w22 = ", "w23 = ", "w24 = ") ww3 <- c("w31 = ", "w32 = ", "w33 = ", "w34 = ") ww4 <- c("w41 = ", "w42 = ", "w43 = ", "w44 = ") ww1 <- paste(ww1[1:K], w1, sep = "") ww2 <- paste(ww2[1:K], w2, sep = "") ww3 <- paste(ww3[1:K], w3, sep = "") ww4 <- paste(ww4[1:K], w4, sep = "") subtitle <- c(paste(ww1, collapse = " , "), paste(ww2, collapse = " , "), paste(ww3, collapse = " , "), paste(ww4, collapse = " , ")) for(i in (1:K)) { if(i == 1) { fmat <- matrix(dcornerf(c = set.adc[i], X = z, flag = 1, CFUN = CFUN), nrow = 1, byrow = T) } else { fmat <- rbind(fmat, matrix(dcornerf(c = set.adc[i], X = z, flag = 1, CFUN = CFUN), nrow = 1, byrow = T)) } } if(K == 2) { W <- matrix(c(w1, w2), ncol = K, nrow = K, byrow = T) } if(K == 3) { W <- matrix(c(w1, w2, w3), ncol = K, nrow = K, byrow = T) } if(K == 4) { W <- matrix(c(w1, w2, w3, w4), ncol = K, nrow = K, byrow = T) } scale <- 1 + dcornerf(c = scalef, X = 1:n, flag = 1, CFUN = CFUN) Ymat <- W %*% fmat # eps <- arima.sim(n * K, model = list(ar = a, ma = (-1) * b)) eps <- arima.sim(n * K, model = list(ar = a, ma = b)) err <- sigma * scale * eps err.mat <- matrix(err, nrow = K, ncol = n, byrow = T) Ymat <- Ymat + err.mat est <- estcomp.ts(Y = Ymat, X = z, W = W, knots = 50, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) for(i in 1:K) { plot(seq(1, n, len = n), Ymat[i, ], type = "p", xlab = " ", ylab = " ", main = titel1[i], sub = subtitle[i]) } for(i in (1:K)) { f <- matrix(dcornerf(c = set.adc[i], knots = 50, CFUN = CFUN), ncol = 1) matplot(seq(1, n, len = 50), cbind(f, negden(est[i, ], FLAGBUMP = 1, cB = cB)), type = "l", lty = c(1, 3), xlab = " ", ylab = " ", main = titel2[i]) } } else if(fig == 8) { K <- length(set.adc) par(mfcol = c(K, length(set.sigma1))) z <- seq(0, 1, l = n) if(b == -99.9) { b <- 0.3 } titel2 <- c("First Component", "Second Component", "Third Component", "Fourth Component") subtitle <- c(paste("sigma1 = ", set.sigma1[1], sep = ""), paste("sigma1 = ", set.sigma1[2], sep = ""), paste("sigma1 = ", set.sigma1[3], sep = "")) for(i in (1:K)) { if(i == 1) { fmat <- matrix(dcornerf(c = set.adc[i], X = z, flag = 1, CFUN = CFUN), nrow = 1, byrow = T) } else { fmat <- rbind(fmat, matrix(dcornerf(c = set.adc[i], X = z, flag = 1, CFUN = CFUN), nrow = 1, byrow = T)) } } if(K == 2) { W <- matrix(c(w1, w2), ncol = K, nrow = K, byrow = T) } if(K == 3) { W <- matrix(c(w1, w2, w3), ncol = K, nrow = K, byrow = T) } if(K == 4) { W <- matrix(c(w1, w2, w3, w4), ncol = K, nrow = K, byrow = T) } scale <- 1 + dcornerf(c = scalef, X = 1:n, flag = 1, CFUN = CFUN) Ymat <- W %*% fmat # eps <- arima.sim(n * K, model = list(ar = a, ma = (-1) * b)) eps <- arima.sim(n * K, model = list(ar = a, ma = b)) err <- sigma * scale * eps err.mat <- matrix(err, nrow = K, ncol = n, byrow = T) Ymat <- Ymat + err.mat for(j in (1:length(set.sigma1))) { W.er <- W + (1/sqrt(n)) * set.sigma1[j] * matrix(rnorm(K * K), ncol = K, nrow = K) est <- estcomp.ts(Y = Ymat, X = z, W = W.er, knots = 50, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) for(i in (1:K)) { f <- matrix(dcornerf(c = set.adc[i], knots = 50, CFUN = CFUN), ncol = 1) matplot(seq(1, n, len = 50), cbind(f, negden(est[i, ], FLAGBUMP = 1, cB = cB)), type = "l", lty = c(1, 3), xlab = " ", ylab = " ", main = titel2[ i], sub = subtitle[j]) } } } else if(fig == 9) { K <- length(set.adc) par(mfcol = c(K, 2)) z <- seq(0, 1, l = n) if(b == -99.9) { b <- 0.3 } titel1 <- c("First Training Noisy Composition", "Second Training Noisy Composition", "Third Training Noisy Composition", "Fourth Training Noisy Composition") ww1 <- c("w11 = ", "w12 = ", "w13 = ", "w14 = ") ww2 <- c("w21 = ", "w22 = ", "w23 = ", "w24 = ") ww3 <- c("w31 = ", "w32 = ", "w33 = ", "w34 = ") ww4 <- c("w41 = ", "w42 = ", "w43 = ", "w44 = ") ww1 <- paste(ww1[1:K], w1, sep = "") ww2 <- paste(ww2[1:K], w2, sep = "") ww3 <- paste(ww3[1:K], w3, sep = "") ww4 <- paste(ww4[1:K], w4, sep = "") subtitle <- c(paste(ww1, collapse = " , "), paste(ww2, collapse = " , "), paste(ww3, collapse = " , "), paste(ww4, collapse = " , ")) for(i in (1:K)) { if(i == 1) { fmat <- matrix(dcornerf(c = set.adc[i], X = z, flag = 1, CFUN = CFUN), nrow = 1, byrow = T) } else { fmat <- rbind(fmat, matrix(dcornerf(c = set.adc[i], X = z, flag = 1, CFUN = CFUN), nrow = 1, byrow = T)) } } if(K == 2) { W <- matrix(c(w1, w2), ncol = K, nrow = K, byrow = T) } if(K == 3) { W <- matrix(c(w1, w2, w3), ncol = K, nrow = K, byrow = T) } if(K == 4) { W <- matrix(c(w1, w2, w3, w4), ncol = K, nrow = K, byrow = T) } W <- rbind(W, matrix(wc, ncol = K, nrow = 1)) scale <- 1 + dcornerf(c = scalef, X = 1:n, flag = 1, CFUN = CFUN) Ymat <- W %*% fmat # eps <- arima.sim(n * (K + 1), model = list(ar = a, ma = (-1) * b)) eps <- arima.sim(n * (K + 1), model = list(ar = a, ma = b)) err <- sigma * scale * eps err.mat <- matrix(err, nrow = (K + 1), ncol = n, byrow = T) Ymat <- Ymat + err.mat for(i in 1:K) { plot(seq(1, n, len = n), Ymat[i, ], type = "p", xlab = " ", ylab = " ", main = titel1[i], sub = subtitle[i]) } wwc <- c("wc1 = ", "wc2 = ", "wc3 = ", "wc4 = ") wwc <- paste(wwc[1:K], wc, sep = "") plot(seq(1, n, len = n), Ymat[(K + 1), ], type = "p", xlab = " ", ylab = " ", main = "The Noisy Composition", sub = paste(wwc, collapse = " , ")) est <- estcomp.ts(Y = Ymat[1:K, ], X = z, W = W[1:K, 1:K], knots = 50, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, FLAGW = 1, JW = JW) estb <- estcregm(Y = Ymat[(K + 1), ], X = z, knots = 50, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, method = 4, FLAGADDTS = 1) for(i in 1:K) { mmm <- negden(est$f.mat[i, ], FLAGBUMP = 1, cB = cB) if(i == 1) { mmat <- matrix(mmm, ncol = 1) } else { mmat <- cbind(mmat, matrix(mmm, ncol = 1)) } } matplot(seq(1, n, len = 50), mmat, type = "l", lty = 1:K, xlab = " ", ylab = " ", main = "Estimated Components") ssb <- estb$fourc[1:JW] sss <- est$theta.mat theta <- rbind(matrix(ssb, nrow = 1, ncol = JW, byrow = T), sss) if(K == 2) { lregr <- lm(theta[1, ] ~ theta[2, ] + theta[3, ] - 1) weights <- coefficients(lregr) } if(K == 3) { lregr <- lm(theta[1, ] ~ theta[2, ] + theta[3, ] + theta[4, ] - 1) weights <- coefficients(lregr) } if(K == 4) { lregr <- lm(theta[1, ] ~ theta[2, ] + theta[3, ] + theta[4, ] + theta[5, ] - 1) weights <- coefficients(lregr) } weights <- round(weights, digits = 1) wwc <- c("wc1 = ", "wc2 = ", "wc3 = ", "wc4 = ") wwc <- paste(wwc[1:K], weights, sep = "") subt <- paste(wwc, collapse = " , ") subt <- paste("Estimated weights: ", subt, sep = " ") plot(seq(1, n, len = 50), negden(estb$f, FLAGBUMP = 1, cB = cB), type = "l", lty = 1, xlab = " ", ylab = " ", main = "Estimate of the Underlying Composition", sub = subt) } else if(fig == 10) { par(mfrow = c(3, 1)) knots <- 200 k <- DELAY if(b == -99.9) { b <- 1 } Z <- sigma1 * rnorm(n + abs(k)) if(k >= 1) { X <- Z[(k + 1):(n + k)] Y <- b * Z[1:n] + sigma2 * rnorm(n) } else { X <- Z[1:n] Y <- b * Z[(abs(k) + 1):(n + abs(k))] + sigma2 * rnorm(n) } est <- estcrospden(X = X, Y = Y, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) z <- seq(0, pi, len = knots) plot(1:n, X, type = "p", pch = 0, xlab = "", ylab = "", main = "First Time Series") lines(1:n, X, type = "l") plot(1:n, Y, type = "p", pch = 0, xlab = "", ylab = "", main = paste("Second Time Series with DELAY = ", k, sep = "")) lines(1:n, Y, type = "l") matplot(z, cbind(matrix(est$Koh, ncol = 1), matrix(est$phase, ncol = 1)), type = "l", lty = c(1, 2), main = "The Estimated Absolute Coherency and Phase Spectrum") } else if(fig == 11) { par(mfrow = c(4, 1)) knots <- 100 ZX <- sigmaP * rnorm(n) ZY <- sigmaS * rnorm(n) for(i in 1:n) { if(i == 1) { Y <- bS * price0 + ZY[1] X <- (-1) * bP * Y[1] + ZX[1] } else { Y <- c(Y, bS * X[i - 1] + ZY[i]) X <- c(X, (-1) * bP * Y[i] + ZX[i]) } } est <- estcrospden(X = X, Y = Y, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) z <- seq(0, pi, len = knots) plot(1:n, X, type = "p", pch = 0, xlab = "", ylab = "", main = "Price") lines(1:n, X, type = "l") plot(1:n, Y, type = "p", pch = 0, xlab = "", ylab = "", main = "Supply") lines(1:n, Y, type = "l") plot(z, est$Koh, type = "l", xlab = "", ylab = "", main = "The Estimated Absolute Coherency") plot(z, est$phase, type = "l", xlab = "", ylab = "", main = "The Estimated Phase Spectrum") } else if(fig == 12) { if(b == -99.9) { b <- 0.4 } knots <- 100 par(mfrow = c(4, 1)) Y <- runif(1) YV <- Y # eps <- arima.sim(n, model = list(ar = a, ma = (-1) * b)) eps <- arima.sim(n, model = list(ar = a, ma = b)) eps <- (sigma * eps)/(var(eps))^(1/2) for(i in 1:n) { Y <- (A * Y)/(1 + B * Y^2) + dnorm(Y, sd = sd) * eps[i] YV <- c(YV, Y) } YV <- YV[-1] plot(1:n, YV, type = "p", main = "1. A time series simulated by a dynamic model", xlab = "t", ylab = "Y ( t )") lines(1:n, YV, type = "l") plot(YV[ - n], YV[-1], type = "p", main = "2. A scatter plot of Y(t) versus Y(t-1) ", xlab = "Y ( t - 1 )", ylab = "Y ( t )") X <- YV[ - n] XMIN <- min(X) XMAX <- max(X) X <- (X - XMIN)/(XMAX - XMIN) f.est <- estcregm(X = X, Y = YV[-1], knots = knots, method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) z <- seq(XMIN, XMAX, length = knots) matplot(z, cbind(matrix((A * z)/(1 + B * z^2), ncol = 1), f.est), type = "l", lty = c(1, 3), main = "3. Estimate of an iterative map", xlab = "t", ylab = "f ( t )") f.est <- estcregm(X = X, Y = YV[-1], flagX = 1, method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) Y <- YV[-1] - f.est scale.est <- estcregm(X = X, Y = Y^2, knots = knots, method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) scale.est[scale.est < 0] <- 0 scale.est <- scale.est^(1/2) scale.est[scale.est < 0] <- 0 matplot(z, cbind(sigma * matrix(dnorm(z, sd = sd), ncol = 1), scale.est), type = "l", lty = c(1, 3), main = "4. Estimate of a scale map", xlab = "t", ylab = "s ( t )") } else if(fig == 13) { if(b == -99.9) { b <- 0.4 } jump <- c(jump, 0.6) b0 <- 1 b1 <- -0.02 b2 <- 0.0001 knots <- max(c(100, n)) bbounds <- c(0.1, 0.9) bknots <- 9 par(mfcol = c(2, 2)) X <- 1:n trend <- b0 + b1 * X + b2 * X^2 trend.jump <- trend A <- (X > jump[2] * n) trend.jump[A] <- trend[A] + rep(jump[1], n)[A] ff <- trend ff.jump <- trend.jump # eps <- arima.sim(n, model = list(ar = a, ma = (-1) * b)) eps <- arima.sim(n, model = list(ar = a, ma = b)) eps <- eps/(var(eps))^(1/2) Y <- ff + sigma * eps Y.jump <- ff.jump + sigma * eps est <- estcreg.jump(X = seq(0, 1, length = n), Y = Y, knots = n, cJ0 = cJ0, cJ1 = cJ1, cT = cT, bbounds = bbounds, bknots = bknots) matplot(1:n, Y, type = "l", main = "Time Series", xlab = "t", ylab = "") points(1:n, Y, type = "p") matplot(1:n, cbind(ff, est), type = "l", lty = c(1, 3), xlab = "t", ylab = "", main = "Trend and Its Estimate") est <- estcreg.jump(X = seq(0, 1, length = n), Y = Y.jump, knots = n, cJ0 = cJ0, cJ1 = cJ1, cT = cT, bbounds = bbounds, bknots = bknots) plot(1:n, Y.jump, type = "l", main = "Time Series", xlab = "t", ylab = "") points(1:n, Y.jump, type = "p") matplot(1:n, cbind(ff.jump, est), type = "l", lty = c(1, 3), xlab = "t", ylab = "", main = "Trend and Its Estimate") } else if(fig == 14) { knots <- 1000 if(b == -99.9) { b <- -0.5 } JMAX <- floor((2 * n)/TMAX) par(mfrow = c(5, 2)) Y <- as.vector(DATA) n <- length(Y) X <- seq(0, 1, len = n) plot(1:n, Y, type = "l", main = "1. Data", xlab = "", ylab = "") plot(1:n, Y, main = "2. Data", xlab = "", ylab = "") f.est <- estcregm(X = X, Y = Y, knots = n, method = 2, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, JJMAX = JMAX) plot(1:n, f.est, type = "l", main = "3. The Estimated Trend", xlab = "", ylab = "") res <- Y - f.est plot(1:n, res, main = "4. Detrended Data", xlab = "", ylab = "") est.nonp <- estspden(X = res, knots = knots, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp, FLAGNEG = FLAGNEG) nn1 <- 1 + floor((knots * set.lambda[1])/pi) nn2 <- floor((knots * set.lambda[2])/pi) period1 <- (2 * pi)/((pi * order(est.nonp[nn1:nn2])[nn2 - nn1])/knots) plot(seq(0, pi, l = knots), est.nonp, type = "l", main = "5. Spectral Density of Detrended Data", xlab = "", ylab = "", sub = paste("THE ESTIMATED PERIOD =", round(period1, digits = 2), sep = "")) if(ManualPer) { period <- scan() } else { period <- round(period1) } if(period >= set.period[1] & period <= set.period[2]) { seas <- matrix(res, ncol = period, nrow = floor(length(X)/period), byrow = T) seas <- apply(seas, 2, mean) f.est <- estcregm(X = seq(0, 1, len = period), Y = seas, knots = period, method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) plot(1:period, f.est, type = "l", ylim = c(min(seas), max(seas)), main = "6. The Estimated Seasonal Component", xlab = "", ylab = "", sub = paste( "THE USED PERIOD = ", period, sep = "")) lines(1:period, seas, type = "p", pch = 0, cex = 1.5) ############################# #this is for Fig.1.11 #plot(1:period, seas, type = "p", pch = 0, main = # "6. The Estimated Seasonal Component", xlab = # "", ylab = "", sub = paste("THE USED PERIOD = ", # period, sep = "")) ############################# if(seasest == "u") { seas <- f.est } res <- res - rep(seas, ceiling(n/period + 5))[1:n] plot(1:n, res, main = "7. Detrended and Deseasonalized Data", xlab = "", ylab = "", sub = paste("THE USED SEASEST = ", seasest, sep = "")) } else { warning("Estimated period is beyond the assigned interval") } scale.est <- estcregm(X = X, Y = res^2, knots = n, method = 2, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r) scale.est[scale.est < lbscale] <- lbscale scale.est <- scale.est^(1/2) plot(1:n, scale.est, type = "l", main = "8. Estimated Scale Function", xlab = "", ylab = "") res <- res/(scale.est + 0.01) res <- res - mean(res) plot(1:n, res, main = "9. Rescaled Residuals", xlab = "", ylab = "") est.nonp <- estspden(X = res, knots = knots, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp, FLAGNEG = FLAGNEG) plot(seq(0, pi, l = knots), est.nonp, type = "l", main = "10. Spectral Density of Rescaled Residuals", xlab = "", ylab = "") } fff <- paste("Figure 5.", fig, sep = "") fff } ############################################################################################################################# ############################################################################################################################# ch6<-function(fig = 12, c11 = 2, c12 = 2, c21 = 3, c22 = 3, c31 = 4, c32 = 4, J11 = 5, J12 = 5, J21 = 8, J22 = 8, J31 = 8, J32 = 8, c1 = 4, c2 = 2, knots1 = 30, knots2 = 100, knots5 = 50, q = 1, t = 3, n = -99.9, CFUN = list(NA, NA), sigma = 0.2, set.k = -99.9, set.n = c(50, 100, 200), knots7 = 50, knots33 = 20, cJ0 = 4, cJ1 = 0.5, cJM = -99.9, cT = -99.9, cB = -99.9, estimate = "o", cD = 1, arg = "cJ0", set.arg = c(6, 4, 2, 0, -1), DATA = state.x77[, c(2, 3)], s0 = 0.5, s1 = 0.5, m1 = 0.4, m2 = 0.5, sd1 = 0.2, sd2 = -0.15, mX = 0.5, sdX = 0.2, mY1 = -0.3, sdY1 = 0.1, mY2 = 0.2, sdY2 = 0.1, pr = 0.3, DATAS = switzerland, X1 = -99.9, X2 = NA, Y = NA) { #ch6 Multivariate if(n == -99.9) { if(fig == 10) { n <- 200 } if(fig == 4) { n <- 100 } if(fig == 5 | fig == 6 | fig == 8) { n <- 50 } if(fig == 7) { n <- 500 } if(fig == 9) { n <- 200 } } if(cB == -99.9) { cB <- 1 if(fig == 5 | fig == 6 | fig == 12) { cB <- 2 } } if(estimate == "o") { estimate <- "u" if(fig == 4) { estimate <- "h" } } if(cT == -99.9) { cT <- 4 if(estimate == "h" | (fig >= 6 & fig <= 9)) { cT <- 2 } } if(set.k == -99.9) { if(fig == 7) { set.k <- c(1, 2, 4, 7) } else if(fig == 8) { set.k <- c(2, 7) } else if(fig == 9) { set.k <- c(2, 3) } } if(cJM == -99.9) { if(fig <= 6 | fig == 11 | fig == 12) { cJM <- 2 } else { cJM <- 0.5 } } titel <- c("1. Uniform", "2. Normal", "3. Bimodal", "4. Strata", "5. Delta", "6. Angle", "7. Monotone", "8. Steps") if(!is.na(CFUN[[2]])) { titel[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".") } ######################################################################## ######################################################################## if(fig == 1) { par(mfrow = c(3, 3)) z <- seq(0, 1, len = knots1) x <- z y <- z f1 <- outer(dcornerf(c = c11, knots = knots1, CFUN = CFUN), dcornerf(c = c12, knots = knots1, CFUN = CFUN)) f2 <- outer(dcornerf(c = c21, knots = knots1, CFUN = CFUN), dcornerf(c = c22, knots = knots1, CFUN = CFUN)) f3 <- outer(dcornerf(c = c31, knots = knots1, CFUN = CFUN), dcornerf(c = c32, knots = knots1, CFUN = CFUN)) zz <- seq(0, 1, len = 50) f1.im <- outer(dcornerf(c = c11, knots = 50, CFUN = CFUN), dcornerf(c = c12, knots = 50, CFUN = CFUN)) f2.im <- outer(dcornerf(c = c21, knots = 50, CFUN = CFUN), dcornerf(c = c22, knots = 50, CFUN = CFUN)) f3.im <- outer(dcornerf(c = c31, knots = 50, CFUN = CFUN), dcornerf(c = c32, knots = 50, CFUN = CFUN)) persp(z, z, f1, xlab = "x", ylab = "y", zlab = "f(x,y)", box = F) title(main = "(a)") persp(z, z, f2, xlab = "x", ylab = "y", zlab = "f(x,y)", box = F) title(main = "(b)") persp(z, z, f3, xlab = "x", ylab = "y", zlab = "f(x,y)", box = F) title(main = "(c)") image(zz, zz, f1.im) image(zz, zz, f2.im) image(zz, zz, f3.im) contour(x, y, f1) contour(x, y, f2) contour(x, y, f3) } else if(fig == 2) { par(mfrow = c(2, 3)) z <- seq(0, 1, len = knots1) f11 <- trigcapr(f = dcornerf(c = c11, knots = knots2, CFUN = CFUN), level = J11, xsq = 0, knots = knots1)$apr f12 <- trigcapr(f = dcornerf(c = c12, knots = knots2, CFUN = CFUN), level = J12, xsq = 0, knots = knots1)$apr f1 <- outer(as.vector(f11), as.vector(f12)) f21 <- trigcapr(f = dcornerf(c = c21, knots = knots2, CFUN = CFUN), level = J21, xsq = 0, knots = knots1)$apr f22 <- trigcapr(f = dcornerf(c = c22, knots = knots2, CFUN = CFUN), level = J22, xsq = 0, knots = knots1)$apr f2 <- outer(as.vector(f21), as.vector(f22)) f31 <- trigcapr(f = dcornerf(c = c31, knots = knots2, CFUN = CFUN), level = J31, xsq = 0, knots = knots1)$apr f32 <- trigcapr(f = dcornerf(c = c32, knots = knots2, CFUN = CFUN), level = J32, xsq = 0, knots = knots1)$apr f3 <- outer(as.vector(f31), as.vector(f32)) persp(z, z, f1, xlab = "x", ylab = "y", zlab = "", box = F) title(sub = "(a)") persp(z, z, f2, xlab = "x", ylab = "y", zlab = "", box = F) title(main = "COSINE APPROXIMATION", sub = "(b)") persp(z, z, f3, xlab = "x", ylab = "y", zlab = "", box = F) title(sub = "(c)") f11 <- legapr(f = dcornerf(c = c11, knots = knots2, CFUN = CFUN), level = J11, z = z)$apr f12 <- legapr(f = dcornerf(c = c12, knots = knots2, CFUN = CFUN), level = J12, z = z)$apr f1 <- outer(as.vector(f11), as.vector(f12)) f21 <- legapr(f = dcornerf(c = c21, knots = knots2, CFUN = CFUN), level = J21, z = z)$apr f22 <- legapr(f = dcornerf(c = c22, knots = knots2, CFUN = CFUN), level = J22, z = z)$apr f2 <- outer(as.vector(f21), as.vector(f22)) f31 <- legapr(f = dcornerf(c = c31, knots = knots2, CFUN = CFUN), level = J31, z = z)$apr f32 <- legapr(f = dcornerf(c = c32, knots = knots2, CFUN = CFUN), level = J32, z = z)$apr f3 <- outer(as.vector(f31), as.vector(f32)) persp(z, z, f1, xlab = "x", ylab = "y", zlab = "", box = F) title(sub = "(a)") persp(z, z, f2, xlab = "x", ylab = "y", zlab = "", box = F) title(main = "POLYNOMIAL APPROXIMATION", sub = "(b)") persp(z, z, f3, xlab = "x", ylab = "y", zlab = "", box = F) title(sub = "(c)") } else if(fig == 3) { Z <- seq(0, 1, len = knots1) c1.mat <- c(c11, c21, c31) c2.mat <- c(c12, c22, c32) par(mfrow = c(length(set.n), 3)) subb <- c(paste("SAMPLE SIZE = ", set.n[1], sep = ""), paste("SAMPLE SIZE = ", set.n[2], sep = ""), paste("SAMPLE SIZE = ", set.n[3], sep = "")) tit <- "Universal Estimator" if(estimate != "u") { tit <- "Hard-Threshold Estimator" } for(i in 1:length(set.n)) { nn <- set.n[i] for(j in 1:3) { c1 <- c1.mat[j] c2 <- c2.mat[j] X1 <- rcornerf(c = c1, n = nn, CFUN = CFUN) X2 <- rcornerf(c = c2, n = nn, CFUN = CFUN) if(estimate == "u") { f.est <- estcdens.2dim(X1 = X1, X2 = X2, knots = knots1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) } else { f.est <- estcden.2dim(X1 = X1, X2 = X2, knots = knots1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) } persp(Z, Z, f.est, xlab = "X", ylab = "Y", zlab = "", box = F) if(i == 1 & j == 2) { title(main = tit, sub = subb[i]) } if(i != 1 & j == 2) { title(sub = subb[i]) } } } } else if(fig == 4) { par(mfrow = c(1, 2)) X1 <- rcornerf(c = 7, n = n, CFUN = CFUN) X2 <- rcornerf(c = 2, n = n, CFUN = CFUN) X2[X1 > 0.5] <- rcornerf(c = 4, n = n, CFUN = CFUN)[X1 > 0.5] Z <- seq(0, 1, len = knots1) if(estimate == "h") { f.est <- estcden.2dim(X1 = X1, X2 = X2, knots = knots1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) } else { f.est <- estcdens.2dim(X1 = X1, X2 = X2, knots = knots1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) } tit1 <- " Hard - Threshold" tit2 <- "Estimator " if(estimate == "u") { tit1 <- " Universal" } persp(Z, Z, f.est, xlab = "X", ylab = "Y", zlab = "f", box = F) title(main = tit1, sub = "DEFAULT EYE LOCATION") theta<-acos(6/sqrt(36+4))*180/pi phi<-acos(30/sqrt(36+4+900))*180/pi r<-sqrt(36+4+900) #persp(Z, Z, f.est, xlab = "X", ylab = "Y", zlab = "f", eye = c(6, 2, 30), box = F) persp(Z, Z, f.est, xlab = "X", ylab = "Y", zlab = "f", theta=theta,phi=phi,r=r, box = F) title(main = tit2, sub = "REVERSE EYE LOCATION") } else if(fig == 5) { par(mfrow = c(1, 3)) X1 <- rcornerf(c = c11, n = n, CFUN = CFUN) X2 <- rcornerf(c = c21, n = n, CFUN = CFUN) Y1 <- rcornerf(c = c31, n = n, CFUN = CFUN) Y2 <- rcornerf(c = c32, n = n, CFUN = CFUN) p.est <- patrec.2dim(X1 = X1, X2 = X2, Y1 = Y1, Y2 = Y2, knots = knots5, q = q, thr = t, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB, estimate = estimate) Z <- seq(0, 1, len = knots5) f1 <- dcornerf.mul(c1 = 2, c2 = 2, knots = knots5, CFUN = CFUN) f2 <- dcornerf.mul(c1 = 4, c2 = 4, knots = knots5, CFUN = CFUN) p.f <- matrix(2, ncol = knots5, nrow = knots5) p.f[f1 < q * f2] <- 0 thrlev <- t * (log(n + 3)/n)^(1/2) p.f[f1 < thrlev & f2 < thrlev] <- 1 plot(X1, X2, type = "p", pch = "1", xlim = c(0, 1), ylim = c(0, 1), xlab = "X", ylab = "Y", main = "Training Sets") lines(Y1, Y2, type = "p", pch = "2") image(Z, Z, p.f, add = F) title(main = "Ideal Discrimination Rule") image(Z, Z, p.est, add = F) title(main = "Discrimination Rule") } else if(fig == 6) { par(mfrow = c(2, 2)) X1 <- runif(n) X2 <- runif(n) Z1 <- ceiling(X1 * n) Z2 <- ceiling(X2 * n) f1 <- dcornerf(c = c11, X = X1, flag = 1, CFUN = CFUN) * dcornerf(c = c12, X = X2, flag = 1, CFUN = CFUN) er <- sigma * rnorm(n) Z <- seq(0, 1, len = knots1) f <- 2 + f1 + er f.mat <- matrix(0, ncol = n, nrow = n) for(i in 1:n) { f.mat[Z1[i], Z2[i]] <- f[i] } persp(seq(0, 1, len = n), seq(0, 1, len = n), f.mat, xlab = "X1", ylab = "X2", zlab = "Y", box = F) title(sub = "(a)") persp(Z, Z, 2 + estcreg.2dim(Y = f1 + er, X1 = X1, X2 = X2, knots = knots1, cD = cD, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB), box = F, xlab = "X1", ylab = "X2", zlab = "f") title(sub = "(b)") X1 <- runif(n) X2 <- runif(n) Z1 <- ceiling(X1 * n) Z2 <- ceiling(X2 * n) f3 <- dcornerf(c = c31, X = X1, flag = 1, CFUN = CFUN) * dcornerf(c = c32, X = X2, flag = 1, CFUN = CFUN) er <- sigma * rnorm(n) f <- 2 + f3 + er f.mat <- matrix(0, ncol = n, nrow = n) for(i in 1:n) { f.mat[Z1[i], Z2[i]] <- f[i] } persp(seq(0, 1, len = n), seq(0, 1, len = n), f.mat, xlab = "X1", ylab = "X2", zlab = "Y", box = F) title(sub = "(c)") persp(Z, Z, 2 + estcreg.2dim(Y = f3 + er, X1 = X1, X2 = X2, knots = knots1, cD = cD, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB), xlab = "X1", ylab = "X2", zlab = "f", box = F) title(sub = "(d)") } else if(fig == 7) { for(k in 1:length(set.k)) { if(k == 1) { X <- runif(n) f <- dcornerf(c = set.k[k], X = X, flag = 1, CFUN = CFUN) X.mat <- matrix(X, ncol = 1) } else { X <- runif(n) f <- f + dcornerf(c = set.k[k], X = X, flag = 1, CFUN = CFUN) X.mat <- cbind(X.mat, matrix(X, ncol = 1)) } } Y <- f + sigma * rnorm(n) f.est <- estcreg.admul(Y = Y, X.mat = X.mat, k.set = set.k, knots = knots7, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT) par(mfrow = c(1, length(set.k))) z <- seq(0, 1, len = knots7) for(i in 1:length(set.k)) { matplot(z, cbind(dcornerf(c = set.k[i], knots = knots7, CFUN = CFUN) - 1, f.est[, i]), type = "l", lty = c(1, 3), main = titel[set.k[i]], xlab = "", ylab = "") } } else if(fig == 8) { par(omd = c(0, 0.5, 0, 1), mfcol = c(1, 1)) X1 <- rcornerf(c = 7, n = n, CFUN = CFUN) X2 <- rcornerf(c = 1, n = n, CFUN = CFUN) X2[X1 > 0.5] <- rcornerf(c = 6, n = n, CFUN = CFUN)[X1 > 0.5] Y <- dcornerf(c = set.k[1], X = X1, flag = 1, CFUN = CFUN) + dcornerf(c = set.k[2], X = X2, flag = 1, CFUN = CFUN) + sigma * rnorm(n) Z1 <- ceiling(X1 * n) Z2 <- ceiling(X2 * n) f.mat <- matrix(0, ncol = n, nrow = n) for(i in 1:n) { f.mat[Z1[i], Z2[i]] <- Y[i] } z <- seq(0, 1, len = knots7) f.est <- estcreg.adbiv(Y = Y, X1 = X1, X2 = X2, knots = knots7, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB, cD = cD) persp(seq(0, 1, len = n), seq(0, 1, len = n), f.mat, xlab = "X1", ylab = "X2", zlab = "Y", box = F) title(main = "Scattergram") par(omd = c(0.5, 1, 0, 1), mfg = c(1, 1, 1, 2), new = T) matplot(z, cbind(dcornerf(c = set.k[1], knots = knots7, CFUN = CFUN) - 1, f.est[, 2]), type = "l", lty = c(1, 3), main = titel[set.k[1]], xlab = "X1", ylab = "f1") par(omd = c(0.5, 1, 0, 1), mfg = c(1, 2, 1, 2)) matplot(z, cbind(dcornerf(c = set.k[2], knots = knots7, CFUN = CFUN) - 1, f.est[, 3]), type = "l", lty = c(1, 3), main = titel[set.k[2]], xlab = "X2", ylab = "f2") par(omd = c(0, 1, 0, 1)) } else if(fig == 9) { par(mfrow = c(1, 3)) X1 <- rcornerf(c = 7, n = n, CFUN = CFUN) X2 <- rcornerf(c = 1, n = n, CFUN = CFUN) X2[X1 > 0.5] <- rcornerf(c = 6, n = n, CFUN = CFUN)[X1 > 0.5] Y <- dcornerf(c = set.k[1], X = X1, flag = 1, CFUN = CFUN) + dcornerf(c = set.k[2], X = X2, flag = 1, CFUN = CFUN) + sigma * rnorm(n) z <- seq(0, 1, len = knots7) f.est <- estcreg.adbiv(Y = Y, X1 = X1, X2 = X2, knots = knots7, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB, cD = cD) matplot(z, cbind((2 * f.est[, 1])/f.est[, 1], f.est[, 1]), type = "l", lty = c(1, 3), main = paste("Constant Term. ", paste(" n = ", n, sep = ""), collapse = " "), xlab = "", ylab = "") matplot(z, cbind(dcornerf(c = set.k[1], knots = knots7, CFUN = CFUN) - 1, f.est[, 2]), type = "l", lty = c(1, 3), main = titel[set.k[1]], xlab = "X1", ylab = "f1") matplot(z, cbind(dcornerf(c = set.k[2], knots = knots7, CFUN = CFUN) - 1, f.est[, 3]), type = "l", lty = c(1, 3), main = titel[set.k[2]], xlab = "X2", ylab = "f2") } else if(fig == 10) { knots1 <- 10 par(mfrow = c(2, 2)) X <- rnorm(n, mean = mX, sd = sdX) mmean <- m1 + m2 * X sdev <- sd1 + sd2 * X UU <- runif(n) ll <- rep(0, n) ll[UU < pr] <- 1 for(i in 1:2) { if(i == 1) { Y <- mmean + sdev * rnorm(n) m <- length(X[X > 0 & X < 1 & Y > 0 & Y < 1]) Y <- mmean + sdev * rnorm(n) } else { Y <- mmean + ll * rnorm(n, mean = mY2, sd = sdY2) Y <- Y + (1 - ll) * rnorm(n, mean = mY1, sd = sdY1) m <- length(X[X > 0 & X < 1 & Y > 0 & Y < 1]) } tit <- paste(c("n = ", "m = "), c(n, m), collapse = ", ") tit <- paste("Data: ", tit, collapse = " ") plot(X, Y, main = tit, xlim = c(min(c(0, X)), max(c(1, X)))) Z <- seq(0, 1, len = 2 * knots1) f.est <- estcden.cond(X = X, Y = Y, knots = 2 * knots1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB, s0 = s0, s1 = s1) persp(Z, Z, f.est, xlab = "X", ylab = "Y", zlab = "f ( Y | X )", box = F) title(main = "Conditional Density") } } else if(fig == 11) { if(nrow(DATA) == 2) { Y1 <- as.vector(DATA[1, ]) Y2 <- as.vector(DATA[2, ]) } else { Y1 <- as.vector(DATA[, 1]) Y2 <- as.vector(DATA[, 2]) } a1 <- min(Y1) b1 <- max(Y1) X1 <- (Y1 - a1)/(b1 - a1) a2 <- min(Y2) b2 <- max(Y2) X2 <- (Y2 - a2)/(b2 - a2) n <- length(X1) Z1 <- seq(a1, b1, len = knots1) Z2 <- seq(a2, b2, len = knots1) par(mfrow = c(2, ceiling((length(set.arg) + 1)/2))) tit <- "Universal Estimator" if(estimate != "u") { tit <- "Hard-Threshold Estimator" } plot(Y1, Y2, xlab = "X1", ylab = "X2", main = paste("n", n, sep = " = ")) ppp <- c(cJ0, cJ1, cJM, cT, cB) names <- c("cJ0", "cJ1", "cJM", "cT", "cB") j <- 1 for(i in 2:5) { if(arg == names[i]) { j <- i } } for(i in 1:length(set.arg)) { ppp[j] <- set.arg[i] if(estimate == "u") { f.est <- estcdens.2dim(X1 = X1, X2 = X2, knots = knots1, cJ0 = ppp[1], cJ1 = ppp[2], cJM = ppp[3], cT = ppp[4], cB = ppp[5]) } else { f.est <- estcden.2dim(X1 = X1, X2 = X2, knots = knots1, cJ0 = ppp[1], cJ1 = ppp[2], cJM = ppp[3], cT = ppp[4], cB = ppp[5]) } persp(Z1, Z2, f.est, xlab = "X1", ylab = "X2", zlab = "DENSITY", box = F) if(i == 1) { title(main = tit, sub = paste(names[j], set.arg[i], sep = " = ")) } else { title(sub = paste(names[j], set.arg[i], sep = " = ")) } } } else if(fig == 12) { if(X1[1] == -99.9) { par(mfrow = c(1, 2)) data <- DATAS data <- (6 * data)/(max(abs(as.vector(matrix(data, ncol = 1))))) contour(data, xlab = "X1", ylab = "X2") title(main = "Spatial Data") lr <- nrow(data) lc <- ncol(data) X2 <- rep(seq(0, 1, len = lc), lr) X1 <- sort(X2) Z2 <- seq(0, lc, len = knots1) Z1 <- seq(0, lr, len = knots1) persp(Z1, Z2, estcreg.2dim(Y = matrix(data, ncol = lc, nrow = lr, byrow = T), X1 = X1, X2 = X2, knots = knots1, cD = cD, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB), box = F, xlab = "X1", ylab = "X2", zlab = "f") title(main = "Estimate") } else { par(mfrow = c(1, 1)) Z2 <- seq(min(X2), max(X2), len = knots1) Z1 <- seq(min(X1), max(X1), len = knots1) persp(Z1, Z2, estcreg.2dim(Y = Y, X1 = X1, X2 = X2, knots = knots1, cD = cD, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB), box = F, xlab = "X1", ylab = "X2", zlab = "f") title(main = "Estimate") } } fff <- paste("Figure 6.", fig, sep = "") fff } ############################################################################################################################# ############################################################################################################################# ch7<-function(fig = 5, k = 100, sigma = 1, set.n = -99.9, m = 30, cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, cB = 2, n = -99.9, d = 1, snratio = 3, set.signal = c("doppler", "jumpsine"), wavelet = "s8", t1 = 0, t2 = 5, CFUN = list(NA, NA)) { if (wavelet=="s4"){wavelet="la8"} if (wavelet=="s5"){wavelet="la10"} if (wavelet=="s6"){wavelet="la12"} if (wavelet=="s7"){wavelet="la14"} if (wavelet=="s8"){wavelet="la16"} if (wavelet=="s9"){wavelet="la18"} if (wavelet=="s10"){wavelet="la20"} #ch7 if(fig == 5) { n <- 1024 } else { n <- 100 } if(fig == 2) { par(mfrow = c(1, 1)) z <- seq(-0.4999, 0.4999, len = 3000) moll <- exp(-1/(1 - 4 * z^2)) z <- c(-0.6, z, 0.6) moll <- c(0, moll, 0) plot(z, moll, type = "l", xlab = "", ylab = "") } else if(fig == 3) { if(set.n[1] == -99.9) { set.n <- c(50, 100, 100) } knots <- 300 par(mfcol = c(2, length(set.n))) tit1 <- c(" Truncated", "Brownian", "Motion ") tit2 <- c(" Truncated", "White", "Noise ") z <- seq(0, 1, len = knots) arg <- outer(z, pi * (1:(k - 1))) basB <- (sqrt(2) * sin(arg))/pi basB <- basB/matrix((1:(k - 1)), ncol = k - 1, nrow = knots, byrow = T) basB <- cbind(matrix(z, ncol = 1, nrow = knots, byrow = F), basB) basW <- sqrt(2) * cos(arg) basW <- cbind(matrix(rep(1, knots), ncol = 1, nrow = knots, byrow = F), basW) for(i in 1:length(set.n)) { n <- set.n[i] noise <- (d * rnorm(k))/sqrt(n) Brown <- basB %*% matrix(noise, ncol = 1, nrow = k, byrow = F) plot(z, Brown, xlab = "", ylab = "", type = "l", sub = paste("n = ", n, sep = "")) #,main = tit1[i]) WN <- basW %*% matrix(noise, ncol = 1, nrow = k, byrow = F) plot(z, WN, xlab = "", ylab = "", type = "l", sub = paste("n = ", n, sep = "")) #main = tit2[i] } sss <- paste(" k = ", k, sep = "") titl1 <- c("Frequency-Limited Brownian Motion,", sss) titl1 <- paste(titl1, collapse = "") titl2 <- c("Frequency-Limited White Noise,", sss) titl2 <- paste(titl2, collapse = "") par(omd = c(0, 1, 0, 1), mfg = c(1, 1, 2, 1)) title(titl1) par(omd = c(0, 1, 0, 1), mfg = c(2, 1, 2, 1)) title(titl2) } else if(fig == 4) { kk=m titl <- c("1. Uniform", "2. Normal", "3. Bimodal", "4. Strata", "5. Delta", "6. Angle", "7. Monotone", "8. Steps") if(!is.na(CFUN[[2]])) { titl[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".") } if(set.n[1] == -99.9) { set.n <- c(50, 100, 200) } knots <- 100 par(mfrow = c(2, 4)) z <- seq(0, 1, len = knots) for(i in 1:8) { for(n in set.n) { noise <- (sqrt(d/n)) * rnorm(k) theta <- trigcapr(f = dcornerf(c = i, knots = 300, CFUN = CFUN), level = (k - 1))$fcoef hat.theta <- theta + noise f.est <- estfilt(hat.theta = hat.theta, knots = knots, kk = kk, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) if(n == set.n[1]) { fmat <- f.est } else { fmat <- cbind(fmat, f.est) } } f <- matrix(dcornerf(c = i, knots = knots, CFUN = CFUN), ncol = 1) fmat <- cbind(f, fmat) matplot(z, fmat, xlab = "", ylab = "", type = "l", lty = 1:(1 + length(set.n)), main = titl[i]) } } else if(fig == 5) { par(mfcol = c(4, length(set.signal))) snr <- snratio for(i in 1:length(set.signal)) { sign <- make.signal2(set.signal[i], seq(0,1,len = n)) signN <- make.signal2(set.signal[i], seq(0,1,len = n), snr = snr) plot(seq(0, 1, len = n),signN, type = "l", xlab = " ", ylab = " ", main = paste("noisy ", set.signal[i], collapse = " ")) ##### plot(waveshrink(signN, wavelet = wavelet, shrink.rule = "adapt"), type = "l", xlab = "", ylab = "", main = "sureshrink") signN.wcn<- dwt(signN,filter=wavelet,n.levels=6) plot( seq(0, 1, len = n),idwt(wdenr(signN.wcn,J=6,thresh='s',den='hs')),type = "l", xlab = "", ylab = "", main = "SURESHRINK") lines(seq(0, 1, len = n), sign, type = "l", lty = 3, col = 2) estf <- blockw(signal = signN, wavelet = wavelet, t1 = t1, t2 = t2) fS <- idwt(estf$fS) yyl <- c(min(c(fS, sign)), max(c(fS, sign))) plot(seq(0, 1, len = n),fS, type = "l", xlab = " ", ylab = " ", main = paste("increasing blocks and t =", t1, sep = " "), ylim = yyl) lines(seq(0, 1, len = n), sign, type = "l", lty = 3, col = 2) fB <- idwt(estf$fB) yyl <- c(min(c(fB, sign)), max(c(fB, sign))) plot(seq(0, 1, len = n),fB, type = "l", xlab = " ", ylab = " ", main = paste("constant blocks and t = ", t2, sep = " "), ylim = yyl) lines(seq(0, 1, len = n), sign, type = "l", lty = 3, col = 2) } } ff <- paste("Figure 7.", fig, sep = "") ff } ############################################################################################################################# ############################################################################################################################# ch8<-function(fig = 16, n = -99.9, cdensity = -99.9, set.nb = c(5, 9, 25), set.h = -99.9, set.X = c(4, 5, 8), kernel = "aaa", h = 0.3, regrfun = 8, sigma = 0.5, X=LifeCycleSavings[,4], Y=LifeCycleSavings[,3], set.kernel = c("box", "triangle", "parzen", "normal"), CFUN = list(NA, NA)) { ### this is ch8 ############################################################################ if(fig == 1) { if(n == -99.9) { n <- 50 } if(cdensity == -99.9) { cdensity <- 3 } set.nclass=set.nb par(mfrow = c(1, length(set.nclass))) X <- rcornerf(c = cdensity, n = n, CFUN = CFUN) f <- dcornerf(c = cdensity, knots = 100, CFUN = CFUN) for(i in (set.nclass + 1)) { mmm <- hist(X, probability = T, plot = F, breaks = seq(0, 1, len = i), xlim = c(0, 1))$counts mmm <- max(f, mmm) hist(X, probability = T, breaks = seq(0, 1, len = i), xlab = "", xlim = c(0, 1), ylim = c(0, mmm)) lines(seq(0, 1, len = 100), f, type = "l") } } else if(fig == 2) { if(n == -99.9) { n <- 50 } if(set.h[1] == -99.9) { set.h <- c(0.1, 0.2, 0.3) } if(cdensity == -99.9) { cdensity <- 3 } par(mfrow = c(1, 3)) X <- rcornerf(c = cdensity, n = n, CFUN = CFUN) f <- dcornerf(c = cdensity, knots = 100, CFUN = CFUN) for(i in set.h) { d <- density(X, n = 300, window = "rectangular", from = -0.1, to = 1.1, width = i) plot(d, type = "l", main = paste("h = ", i, sep = ""), xlab = "", ylab = "", ylim = c(0, max(c(max(d$y), max(f))))) lines(seq(0, 1, len = 100), f, type = "l", lty = 1, col = 2) lines(seq(-0.05, 0, len = 3), rep(0, 3), type = "l", col = 2) lines(seq(1, 1.05, len = 3), rep(0, 3), type = "l", col = 2) } } else if(fig == 3) { if(set.h[1] == -99.9) { set.h <- c(1, 0.5) } par(mfrow = c(1, 2)) for(h in set.h) { d1 <- dnorm(seq(0, 12, len = 100), mean = set.X[1], sd = h) d2 <- dnorm(seq(0, 12, len = 100), mean = set.X[2], sd = h) d3 <- dnorm(seq(0, 12, len = 100), mean = set.X[3], sd = h) plot(seq(0, 12, len = 100), (d1 + d2 + d3)/3, type = "l", xlab = "", ylab = "", ylim = c(0, 0.4/h), main = paste("h = ", h, sep = "")) lines(seq(0, 12, len = 100), d1, type = "l", lty = 2) lines(seq(0, 12, len = 100), d2, type = "l", lty = 2) lines(seq(0, 12, len = 100), d3, type = "l", lty = 2) lines(set.X, rep(0, 3), type = "p", pch = 4, cex = 3) lines(rep(set.X[1], 2), c(0, max(d1) - 0.01/h^2), type = "l", lty = 8) lines(rep(set.X[2], 2), c(0, max(d1) - 0.01/h^2), type = "l", lty = 8) lines(rep(set.X[3], 2), c(0, max(d1) - 0.01/h^2), type = "l", lty = 8) } } else if(fig == 4) { if(n == -99.9) { n <- 100 } if(set.h[1] == -99.9) { set.h <- c(0.15, 0.6) } if(cdensity == -99.9) { cdensity <- 4 } if(kernel == "aaa") { kernel <- "gaussian" } par(mfrow = c(1, 3)) X <- rcornerf(c = cdensity, n = n, CFUN = CFUN) a <- -0.4 b <- 1.4 d <- density(X, n = 300, window = kernel, from = a, to = b) f <- c(rep(0, 2), dcornerf(c = cdensity, knots = 100, CFUN = CFUN), rep(0, 2)) z <- c(a, 0, seq(0, 1, len = 100), 1, b) plot(z, f, type = "l", lty = 1, main = "default h", xlab = "", xlim = c(a, b), ylab = "", ylim = c(0, max(c(max(d$y), max(f))))) lines(d, type = "l", lty = 2, col = 2) d <- density(X, n = 300, window = kernel, width = set.h[1], from = a, to = b) plot(z, f, type = "l", lty = 1, main = paste("h = ", set.h[1], sep = ""), xlab = "", ylab = "", xlim = c(a, b), ylim = c(0, max(c(max(d$y), max(f))))) lines(d, type = "l", lty = 2, col = 2) d <- density(X, n = 300, window = kernel, width = set.h[2], from = a, to = b) plot(z, f, type = "l", lty = 1, main = paste("h = ", set.h[2], sep = ""), xlab = "", ylab = "", xlim = c(a, b), ylim = c(0, max(c(max(d$y), max(f))))) lines(d, type = "l", lty = 2, col = 2) } else if(fig == 5) { par(mfrow = c(1, 1)) if(n == -99.9) { n <- 10 } X <- seq(0, 1, len = n) Y <- dcornerf(c = regrfun, X = X, flag = 1, CFUN = CFUN) + sigma * rnorm(n) R <- dcornerf(c = regrfun, X = seq(0, 1, len = 300), flag = 1, CFUN = CFUN) f <- 0 for(z in seq(0, 1, len = 300)) { YY <- Y YY[abs(z - X) > h] <- 0 f <- c(f, sum(YY)/(2 * h * n)) } f <- f[-1] ymax <- max(c(max(f), max(R), max(Y))) ymin <- min(c(min(f), min(R), min(Y))) plot(X, Y, type = "p", pch = 4, xlab = "X", ylab = "Y", main = paste("h = ", h, sep = ""), ylim = c(ymin, ymax)) lines(seq(0, 1, len = 300), R, type = "l") lines(seq(0, 1, len = 300), f, type = "l", lty = 2, col = 2) } else if(fig == 6) { par(mfrow = c(1, 1)) z <- seq(0, 1, len = 100) f <- 2.5 + cos(7 * z) f.x0 <- 2.5 + cos(7 * 0.6) K <- dnorm(z, mean = 0.6, sd = 0.05) plot(z, f, xlab = "", ylab = "", type = "l", lty = 1, ylim = c(0, max(K * f)), sub = "x") lines(z, K, type = "l", lty = 2) lines(z, f * K, type = "l", lty = 3) int1 <- matrix(f * K, nrow = 1, byrow = T) %*% Updiag(100)/100 lines(z, int1, type = "l", lty = 6) lines(c(0.6, 0.6), c(-1, 15), type = "l", lty = 8) lines(c(0, 1), c(f.x0, f.x0), type = "l", lty = 8) lines(0.6, f.x0, type = "p", pch = 4, cex = 2) lines(1, f.x0, type = "p", pch = 7, cex = 2) } else if(fig == 7) { par(mfrow = c(1, length(set.h))) if(n == -99.9) { n <- 25 } if(kernel == "aaa") { kernel <- "normal" } if(set.h[1] == -99.9) { set.h <- c(0.1, 0.2, 0.3) } par(mfrow = c(1, length(set.h))) X <- seq(0, 1, len = n) Y <- 3 + sin(2 * pi * X) + sigma * rnorm(n) f <- 3 + sin(2 * pi * seq(0, 1, len = 100)) for(i in 1:length(set.h)) { est <- ksmooth(X, Y, kernel, x.points = seq(0, 1, len = 100), bandwidth = set.h[i])$y matplot(seq(0, 1, len = 100), matrix(c(f, est), ncol = 2, nrow = 100, byrow = F), type = "l", lty = c(1, 2), xlab = "", ylab = "", main = paste("h = ", set.h[i], sep = ""), ylim = c(min(Y), max(Y))) lines(X, Y, type = "p", pch = 4) } } else if(fig == 8) { h <- 0.15 par(mfrow = c(1, 1)) x <- seq(0, 1, len = 50) f <- 10 + 10 * dcornerf(c = 3, X = seq(0, 0.8, len = 50), flag = 1, CFUN = CFUN) Y <- f + rnorm(50, sd = 0.5) plot(x, Y, type = "p", pch = 4, xlab = "X", ylab = "", ylim = c(0, 35), xlim = c(0, 1.2)) lines(x, f, type = "l", lty = 3) xx <- seq(0, 1.2, len = 1000) k1 <- dunif(xx, min = 0.3 - h, max = 0.3 + h) k2 <- dunif(xx, min = 0.65 - h, max = 0.65 + h) k3 <- dunif(xx, min = 1 - h, max = 1 + h) lines(xx, k1, type = "l", lty = 2) lines(xx, k2, type = "l", lty = 2) lines(xx, k3, type = "l", lty = 2) pp <- c(0.3, 0.65, 1) for(i in 1:3) { xc <- pp[i] xxx <- x[pp[i] - h <= x & x <= pp[i] + h] yyy <- Y[pp[i] - h <= x & x <= pp[i] + h] coef <- lsfit(xxx, yyy)$coef b0 <- coef[1] b1 <- coef[2] regr <- b0 + b1 * xxx regrf <- b0 + b1 * xc lines(xxx, regr, type = "l") lines(c(xc, xc), c(regrf, regrf), type = "p", pch = 2, cex = 2) lines(c(xc, xc), c(-1, regrf), type = "l", lty = 8) } } else if(fig == 9) { if(set.h[1] == -99.9) { set.h <- c(0.15, 0.06, 0.03) } if(n == -99.9) { n <- 50 } par(mfrow = c(2, 3)) z <- seq(0, 1, len = 50) x <- seq(0, 1, len = n) f <- 10 + 10 * dcornerf(c = 3, X = seq(0, 0.8, len = n), flag = 1, CFUN = CFUN) Y <- f + rnorm(n, sd = sigma) f <- 10 + 10 * dcornerf(c = 3, X = seq(0, 0.8, len = 50), flag = 1, CFUN = CFUN) aa <- min(c(min(f), min(Y))) bb <- max(c(max(f), max(Y))) mtit <- c("", "RECTANGULAR KERNEL", "") for(i in 1:3) { est <- loclin(X = x, Y = Y, h = set.h[i], kernel = "r", knots = 50) aaa <- min(c(aa, min(est))) bbb <- max(c(bb, max(est))) matplot(z, matrix(c(f, est), nrow = 50, ncol = 2, byrow = F), type = "l", lty = c(1, 3), ylab = "", xlab = "", sub = paste("h = ", set.h[i], sep = ""), ylim = c(aaa, bbb), xlim = c(0, 1), main = mtit[i]) lines(seq(0, 1, len = n), Y, type = "p", pch = 4) } mtit <- c("", "GAUSSIAN KERNEL", "") for(i in 1:3) { est <- loclin(X = x, Y = Y, h = set.h[i], kernel = "g", knots = 50) aaa <- min(c(aa, min(est))) bbb <- max(c(bb, max(est))) matplot(z, matrix(c(f, est), nrow = 50, ncol = 2, byrow = F), type = "l", lty = c(1, 3), ylab = "", xlab = "", sub = paste("h = ", set.h[i], sep = ""), ylim = c(aaa, bbb), xlim = c(0, 1), main = mtit[i]) lines(seq(0, 1, len = n), Y, type = "p", pch = 4) } } else if(fig == 10) { par(mfrow = c(1, 1)) z <- seq(0.65, 1, len = 50) plot(z, 1/(4 * abs(z - 0.6)), xlab = "X", ylab = "", type = "l", xlim = c(0, 1), ylim = c(0, 5)) z <- seq(0.5, 0.65, len = 50) lines(z, 1/(4 * abs(z - 0.7)), type = "l") z <- seq(0.45, 0.5, len = 50) lines(z, 1/(4 * abs(z - 0.3)), type = "l") z <- seq(0, 0.45, len = 50) lines(z, 1/(4 * abs(z - 0.6)), type = "l") lines(c(0.3, 0.6, 0.7), c(0, 0, 0), type = "p", pch = 4, cex = 2) lines(c(0, 1), c(0, 0), type = "l", lty = 8) } else if(fig == 12) { par(mfrow = c(1, 1)) X <- seq(0, 1, len = 6) Y <- c(3, 1, 5, 2, 6, 1) plot(spline(X, Y, n = 60), type = "l", ylim = c(0.8, 6), xlab = "X", ylab = "Y") lines(c(0, 0.2), c(3, 1), type = "l", lty = 2) lines(c(0.2, 0.4), c(1, 5), type = "l", lty = 2) lines(c(0.4, 0.6), c(5, 2), type = "l", lty = 2) lines(c(0.6, 0.8), c(2, 6), type = "l", lty = 2) lines(c(0.8, 1), c(6, 1), type = "l", lty = 2) lines(X, Y, type = "p", pch = 4, cex = 2) } else if(fig == 13) { par(mfrow = c(1, 2)) if(n == -99.9) { n <- 50 } x <- seq(0, 1, len = n) f <- 10 + 10 * dcornerf(c = 3, X = seq(0, 0.8, len = n), flag = 1, CFUN = CFUN) for(i in 1:2) { Y <- f + rnorm(n, sd = sigma) est <- smooth.spline(x, Y) est.x <- est$x est.y <- est$y ff <- 10 + 10 * dcornerf(c = 3, X = seq(0, 0.8, len = length(est$x)), flag = 1, CFUN = CFUN) aa <- min(c(min(ff), min(Y), min(est.y))) bb <- max(c(max(ff), max(Y), max(est.y))) matplot(est.x, matrix(c(ff, est.y), ncol = 2, nrow = length(est.x), byrow = F), type = "l", lty = c(1, 3), xlab = "X", ylab = " ", ylim = c(aa, bb), xlim = c(0, 1)) lines(x, Y, type = "p", pch = 4) } } else if(fig == 16) { if(set.h == -99.9) { set.h <- c(0.1, 0.2, 0.3, 0.4) } X <- as.vector(X) Y <- as.vector(Y) par(mfrow = c(1, length(set.h))) n <- length(X) a1 <- min(X) b1 <- max(X) X1 <- (X - a1)/(b1 - a1) a2 <- min(Y) b2 <- max(Y) Y1 <- (Y - a2)/(b2 - a2) for(j in 1:length(set.h)) { h <- set.h[j] tit <- paste("h", h, sep = " = ") if(kernel == "aaa") { kernel <- "normal" } est <- ksmooth(X1, Y1, kernel = kernel, x.points = seq(0, 1, len = 100), bandwidth = h)$y tit <- paste(c(tit, paste("kernel is ", kernel, collapse = "")), collapse = ", ") plot(X, Y, xlab = "X", ylab = "Y", type = "p", pch = 4, main = tit, sub = paste("n", n, sep = " = ")) lines(seq(a1, b1, len = 100), (a2 + (b2 - a2) * est), type = "l") } } else if(fig == 17) { X <- as.vector(X) Y <- as.vector(Y) par(mfrow = c(1, length(set.kernel))) n <- length(X) a1 <- min(X) b1 <- max(X) X1 <- (X - a1)/(b1 - a1) a2 <- min(Y) b2 <- max(Y) Y1 <- (Y - a2)/(b2 - a2) for(j in 1:length(set.kernel)) { tit <- paste("h", h, sep = " = ") kernel <- set.kernel[j] est <- ksmooth(X1, Y1, kernel = kernel, x.points = seq(0, 1, len = 100), bandwidth = h)$y tit <- paste(c(tit, paste("kernel is ", kernel, collapse = "")), collapse = ", ") plot(X, Y, xlab = "X", ylab = "Y", type = "p", pch = 4, main = tit, sub = paste("n", n, sep = " = ")) lines(seq(a1, b1, len = 100), (a2 + (b2 - a2) * est), type = "l") } } fff <- paste("Figure 8.", fig, sep = "") fff } ############################################################################################################################# ############################################################################################################################# dcornerf<-function(cornerf = 2, knots = 100, X = NA, flag = 0, CFUN = list(NA, NA)) { #this is a function DCORNERF in ../book1f3 that returns #values of the corner function # number "cornerf" at "knots" points between 0 and 1 # 1 - Uniform, 2 - Normal, 3 - Bimodal, 4 - Strata # 5 - Delta, 6 - Angle, 7 - Monotone, 8 - Steps, #9 - # if flag=0 - use equidistant, if flag = 1 - use X z <- seq(from = 0, to = 1, len = knots) if(flag == 1) { z <- X } if(!is.na(CFUN[[1]]) && !is.na(CFUN[[2]]) && cornerf == CFUN[[1]]) { cornerf <- 10 } if(cornerf == 1) { f <- dunif(z) } else if(cornerf == 2) { f <- dnorm(z, mean = 0.5, sd = 0.15) } else if(cornerf == 3) { f <- 0.5 * dnorm(z, 0.4, 0.12) + 0.5 * dnorm(z, 0.7, 0.08) } else if(cornerf == 4) { f <- 0.5 * dnorm(z, 0.2, 0.06) + 0.5 * dnorm(z, 0.75, 0.08) } else if(cornerf == 5) { f <- dnorm(z, 0.5, 0.02) } else if(cornerf == 6) { f1 <- dnorm(z, mean = 1, sd = 0.7)/0.16095 f2 <- dnorm(z, mean = 0, sd = 0.7)/0.16095 f <- 0.5 * f1 * (z <= 0.5) + 0.5 * f2 * (z > 0.5) } else if(cornerf == 7) { f <- dnorm(z, 2, 0.8)/(sum(dnorm(seq(0, 1, len = 1000), 2, 0.8))/1000) } else if(cornerf == 8) { f <- 0.6 * (z <= 1/3) + 0.9 * (z > 1/3) * (z <= 3/4) + (204/120) * (z > 3/4) } else if(cornerf == 10) { ll <- max(200, length(z)) x <- seq(0, 1, len = ll) eval(parse(text = paste("f <- ", CFUN[[2]]))) f[f < 0] <- 0 if(max(f) == 0) { stop("The custom function is negative") } f <- f/mean(f) z[z == 0] <- 1/ll lz <- length(z) if(length(ll) > lz) { z <- c(z, rep(1/ll, length(ll) - length(z))) } f <- f[round(ll * z)] f <- f[1:lz] } f } ############################################################################################################################# ############################################################################################################################# dcornerf.mul<-function(c1 = 2, c2 = 2, knots = 100, X1 = NA, X2 = NA, FLAG = 0, CFUN = list(NA, NA)) { #this is function dcornerf.mul in ../book1fig that returns #values of bivariate corner functions matrix X1(raws) times X2(colums) # 1 - Uniform #2 - Normal #3 - Bimodal #4 - Strata # if FLAG=0 - use equidistant, if flag=1 - use X1 and X2 Z1 <- seq(0, 1, len = knots) Z2 <- Z1 if(FLAG == 1) { Z1 <- X1 Z2 <- X2 } f <- outer(dcornerf(c = c1, knots = knots, X = X1, flag = FLAG, CFUN = CFUN), dcornerf(c = c2, knots = knots, X = X2, flag = FLAG, CFUN = CFUN)) f } ############################################################################################################################# ############################################################################################################################# estcden<-function(X = NA, knots = 100, cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, reg = 0, cVAL = 1, cB = 2, FLAGNNEG = 1, FLAGHYPT = 0, FLAGBASIS = 0) { #this is ESTCDEN in book1fign that estimates density via cosine basis # if reg=1 then the program return density at points X # b <- 4 #if FLAGHYPT=1 then returns test statistics for the nonparam test sect. 3.8 #if FLAGBASIS=1 then returns both function and estimated empir risk n <- length(X) JMAX <- ceiling(cJ0 + cJ1 * log(n + 3)) est <- estimfcd(X = X, J = cJM * JMAX) theta1 <- est$theta thetasq1 <- est$thetasq theta <- theta1[1:JMAX] thetasq <- thetasq1[1:JMAX] error <- matrix((cVAL/n) - thetasq, nrow = 1) %*% Updiag(JMAX) J <- order(error)[1] theta <- theta[1:J] #############here the case J=1 (because it may be a good idea to set J=0) if((J == 1) & (cVAL/n - thetasq[1] >= 0)) { theta <- 0 } thetasq <- thetasq[1:J] arg <- outer(seq(0, 1, len = knots), pi * (1:(cJM * JMAX))) if(reg == 1) { arg <- outer(X, pi * (1:(cJM * JMAX))) } bas <- (2^(1/2)) * cos(arg) # theta[thetasq < rep(log(J + 3)/(2 * n), J)] <- 0 theta <- (theta * thetasq)/(thetasq + (1/n)) if(cJM <= 1) { if(JMAX > J) { theta <- c(theta, rep(0, JMAX - J)) } } if(cJM > 1) { rest.theta <- theta1[(J + 1):(cJM * JMAX)] rest.theta[rest.theta^2 < (cT * log(n + 3))/n] <- 0 theta <- c(theta, rest.theta) } fS <- 1 + bas %*% theta # list(estT = negden(fT), estH = negden(fH), estS = negden(fS), theta = # theta1, thetasq = thetasq1, N = J) if(FLAGNNEG == 1) { fS <- negden(fS, FLAGBUMP = 1, cB = cB) } if(FLAGHYPT == 1) { fS <- theta1[1:JMAX] fS <- sum(fS^2) } if(FLAGBASIS == 1) { thetasq <- theta^2 thetasq <- thetasq[thetasq > 0] risk <- 2 * length(thetasq) - sum(thetasq) - 1 fS <- list(fS = fS, risk = risk) } fS } ############################################################################################################################# ############################################################################################################################# Updiag<-function(J = 2) { #this is Updiag in book1fig that returnes matrix J*J with 1 on and #above duig and zeros below m <- matrix(1, nrow = J, ncol = J) m[row(m) > col(m)] <- 0 m } ############################################################################################################################# ############################################################################################################################# negden<-function(f = NA, delta = 0.01, FLAGBUMP = 1, cB = 2) { #this is negden in book1fig that finds nonnegative projection #FLAGBUM =1 then the program removes bumps whose int f^2 dx # less than cof*\int (f - f.neg)^2 dx flag <- 0 f1 <- f k <- length(f) AREA <- (k/(k - 1)) * mean(f) - (f[1] + f[k])/(2 * (k - 1)) if(all(f >= 0)) { flag <- 1 } if(all(f <= 2 * delta) | (AREA <= 2 * delta)) { flag <- 2 } while(flag == 0) { f <- f - delta f[f < 0] <- 0 int <- (k/(k - 1)) * mean(f) - (f[1] + f[k])/(2 * (k - 1)) if(int <= AREA) { if(int > (10 * delta)) { f <- f * (AREA/int) } flag <- 1 } } if(FLAGBUMP == 1) { AREASQ <- mean((f - f1)^2) f <- rem.bump1(f = f, AREASQ = AREASQ, coef = cB) } if(flag == 1) { if(mean(f) > (10 * delta)) { f <- f * (AREA/mean(f)) } } f[f < 0] <- 0 f } ############################################################################################################################# ############################################################################################################################# rem.bump1<-function(f = NA, AREASQ = NA, coef = 1) { ##this is rem.bump1 in book1fig that removes any bump with L_2 area ## larger than coef*AREASQ, n <- length(f) vec <- abvec(f) if(length(vec) > 2) { vec <- vec[ - c(1, 2)] k <- length(vec)/2 for(s in 1:k) { if(sum((f[vec[2 * s - 1]:vec[2 * s]])^2)/n <= coef * AREASQ) { f[vec[2 * s - 1]:vec[2 * s]] <- 0 } } } f } ############################################################################################################################# ############################################################################################################################# estcden.der<-function(X = NA, knots = NA, cJ0 = NA, cJ1 = NA, cJM = NA, cT = NA, cTP = NA, cB = NA) { #this is estcden.der in book1fig that estimates density via cosine basis # plus X and X^2 n <- length(X) JMAX <- ceiling(cJ0 + cJ1 * log(n + 3)) j <- 0 while(j <= JMAX) { fcsq <- estimfcd.der(X = X, J = j)$thetasq errc <- (j + 2)/n - sum(fcsq) if(j == 0) { err <- errc } else { err <- c(err, errc) } j <- j + 1 } J <- order(err)[1] J <- J - 1 est <- estimfcd.der(X = X, J = J) fc <- est$theta fcsq <- est$thetasq #########Now I choose between the cos-polyn and just cosine basis######## JJ <- length(fc) if((fcsq[JJ] > (cTP * log(n + 3))/n) | (fcsq[JJ - 1] > (cTP * log(n + 3))/n)) { z <- seq(0, 1, len = knots) pp <- estimfcd.der(X = z, J = J) if(J == 0) { bas <- cbind(pp$psi1, pp$psi2) } else { arg <- outer(z, pi * (1:J)) bas <- (2^(1/2)) * cos(arg) bas <- cbind(bas, pp$psi1, pp$psi2) } thetaS <- (fc * fcsq)/(fcsq + 1/n) thetaS <- matrix(thetaS, ncol = 1) fS <- 1 + bas %*% thetaS f.est <- negden(fS, FLAGBUMP = 1, cB = cB) } else { f.est <- estcden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) } f.est } ############################################################################################################################# ############################################################################################################################# estcden.int<-function(X = NA, knots = 100, cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, cB = 2, FLAGNNEG = 1, a = 0, b = 1) { #this is ESTCDEN.INT in book1fign that estimates density via cosine basis #over the interval [a,b] n <- length(X) JMAX <- ceiling(cJ0 + cJ1 * log(n + 3)) Y <- X[X <= b] Y <- X[X >= a] Y <- (Y - a)/(b - a) m <- length(Y) if(m > 10) { theta0 <- m/n ###########estimation Fourier coefficients bass <- (2^(1/2)) * cos(outer(Y, pi * (1:(cJM * JMAX)))) l <- matrix(rep(1, m), nrow = 1) theta1 <- (l/n) %*% bass thetasq1 <- theta1^2 - theta0/n thetasq1[thetasq1 < 0] <- 0 theta <- theta1[1:JMAX] thetasq <- thetasq1[1:JMAX] error <- matrix((theta0/n) - thetasq, nrow = 1) %*% Updiag(JMAX) J <- order(error)[1] theta <- theta[1:J] #############here the case J=1 (because it may be a good idea to set J=0) if((J == 1) & (theta0/n - thetasq[1] >= 0)) { theta <- 0 } thetasq <- thetasq[1:J] arg <- outer(seq(0, 1, len = knots), pi * (1:(cJM * JMAX))) bas <- (2^(1/2)) * cos(arg) theta <- (theta * thetasq)/(thetasq + (theta0/n)) if(cJM <= 1) { if(JMAX > J) { theta <- c(theta, rep(0, JMAX - J)) } } if(cJM > 1) { rest.theta <- theta1[(J + 1):(cJM * JMAX)] rest.theta[rest.theta^2 < (theta0 * cT * log(n + 3))/n] <- 0 theta <- c(theta, rest.theta) } fS <- theta0 + bas %*% theta if(FLAGNNEG == 1) { fS <- negden(fS, FLAGBUMP = 1, cB = cB) } fS <- fS/(b - a) } else { fS <- rep(0, knots) } fS } ############################################################################################################################# ############################################################################################################################# estcden.sup<-function(X = NA, del = 0.01, knots = 100, cJ0 = NA, cJ1 = NA, cJM = NA, cT = NA, cB = NA) { #this is a function estcden.sup that finds a minimal support # such that the estimate vanishes at the boundary points flag <- 1 a <- min(X) b <- max(X) while(flag == 1) { XX <- (X - a)/(b - a) f <- estcden(X = XX, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB)/(b - a) d1 <- f[1, 1] d100 <- f[knots, 1] if((d1 + d100) <= 0.01) { flag <- 0 } else { if(d1 > 0) { a <- a - del } if(d100 > 0) { b <- b + del } } } list(f = f, sup = c(a, b)) } ############################################################################################################################# ############################################################################################################################# estcomp.ts<-function(Y = NA, X = X, W = NA, knots = 50, cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, cB = 2, s0 = 0.5, s1 = 0.5, r = 2, FLAGW = 0, JW = 5) { #this is estcomp.ts in book1fign that estimates # additive components in time series for Sect.5.5 #Y is matrix with nrows=K #FLAGW=1 then return Four coefficients and their significance ###Finding Fourier coefficients for observed curves K <- ncol(W) B <- solve(W) n <- length(X) for(i in (1:K)) { est <- estcregm(X = X, Y = Y[i, ], knots = 20, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, s0 = s0, s1 = s1, r = r, method = 4, FLAGADDTS = 1) fourc <- est$fourc sigsq <- est$sigsq if(i == 1) { sigsq.s <- sigsq fourc.c <- fourc JMAXv <- length(fourc) } else { sigsq.s <- sigsq.s + sigsq fourc.c <- c(fourc.c, fourc) JMAXv <- c(JMAXv, length(fourc)) } } ####Finding Fourier coefficients for underlying additive components JMAX <- min(JMAXv) for(i in (1:K)) { if(i == 1) { fourc.m <- matrix(fourc.c[1:JMAX], nrow = 1, byrow = T) } else { fourc.m <- rbind(fourc.m, matrix(fourc.c[(1 + sum(JMAXv[1:(i - 1)])):(JMAX + sum(JMAXv[1:(i - 1)]))], nrow = 1, byrow = T)) } } theta.m <- B %*% fourc.m sigsq <- sigsq.s/K sigmasq.m <- sigsq * apply(B^2, 1, sum) #######estimation of K components for(i in (1:K)) { theta1 <- theta.m[i, ] sigsq <- sigmasq.m[i] JM1 <- min(JMAX, ceiling(cJ0 + cJ1 * log(n + 3))) thetasq1 <- theta1^2 - sigsq/n thetasq1[thetasq1 < 0] <- 0 theta <- theta1[1:JM1] thetasq <- thetasq1[1:JM1] error <- matrix((sigsq/n) - thetasq, nrow = 1) %*% Updiag(JM1) J <- order(error)[1] theta <- theta[1:J] thetasq <- thetasq[1:J] theta[1] <- theta[1]/2^(1/2) arg <- outer(seq(0, 1, len = knots), pi * (0:(J - 1))) bas <- (2^(1/2)) * cos(arg) fS <- bas %*% ((theta * thetasq)/(thetasq + sigsq/n)) # if(JMAX > JM1) { # theta.rest <- theta1[(JM1 + 1):JMAX] # theta.rest[theta.rest < (cT * sigsq * log(n + 3))/n] <- 0 # arg <- outer(seq(0, 1, len = knots), pi * ((JM1 + 1): # JMAX)) # bas <- (2^(1/2)) * cos(arg) # fS <- fS + bas %*% theta.rest # } if(i == 1) { fmat <- t(fS) theta.mat <- matrix(theta1[1:JW], ncol = JW, nrow = 1) aaa <- rep(1, JW) aaa[theta[1:JW]^2 < (cT * sigsq * log(n + 20))/n] <- 0 sign.mat <- matrix(aaa, ncol = JW, nrow = 1) } else { fmat <- rbind(fmat, t(fS)) theta.mat <- rbind(theta.mat[, (1:JW)], matrix(theta1[1:JW], ncol = JW, nrow = 1)) aaa <- rep(1, JW) aaa[theta1[1:JW]^2 < (cT * sigsq * log(n + 20))/n] <- 0 sign.mat <- rbind(sign.mat[, 1:JW], matrix(aaa, ncol = JW, nrow = 1)) } } if(FLAGW == 1) { fmat <- list(f.mat = fmat, theta.mat = theta.mat, sign.mat = sign.mat) } fmat ######it returns matrix with rows being estimates of the components ######or Four coef, their length and significance otherwise } ############################################################################################################################# ############################################################################################################################# estcreg<-function(X = NA, Y = NA, cJ0 = 4, cJ1 = 1/2, cJM = 6, cT = 4, method = NA, knots = 100, flagX = 0, s0 = 0.5, s1 = 0.5, r = 2) { #this is estcreg in book1fig that estimates regression via cosine basis # it transfers X onto [0,1] only if X are beyond [0,1] # it returns the regression function supported on domain of [0,1] # ######method gives different procedures of estimtion Fourier coefficients #method=2 - direct summation assuming uniform distribution of X, #################and sig is GIVEN, sig=noise.sd*coef.sd #method=4 - heteroscedastic random design, use s =s0 +s1* ln(ln(n+20)) #######methods are described in Chapter 4 #Jsig=Jsig0 + Jsig1*log(n) cosine coefficients are used to calculate # the sigma is calculated for method 2 as # mad(Y-fSS(with Jsig cos coeffic)) # here it is "T" - truncated or "S" - smoothed #flagX=1 then return values at points X #flagX=0 then return values at points seq(0,1,. l=knots) #rs=5 for equidistant, and rs = 10 a <- min(X) b <- max(X) if((a < 0) | (b > 1)) { X <- (X - a)/(b - a) } n <- length(X) zzz <- seq(0, 1, len = knots) if(flagX == 1) { zzz <- X } J.MAX <- ceiling(cJ0 + cJ1 * log(n + 3)) J.MAX1 <- floor(cJM * J.MAX) est <- estcregfc(X = X, Y = Y, method = method, JMAX = J.MAX1, r = r) fc <- est$theta fcsq <- est$thetasq theta <- fc[1:J.MAX] thetasq <- fcsq[1:J.MAX] sigsq <- est$sigsq error <- matrix((sigsq/n) - thetasq, nrow = 1) %*% Updiag(J.MAX) J <- order(error)[1] if(J == 1) { fS <- theta[1] + 0 * zzz } else { theta <- theta[1:J] thetasq <- thetasq[2:J] arg <- outer(zzz, pi * (1:(J - 1))) bas <- (2^(1/2)) * cos(arg) fS <- bas %*% (theta[2:J] * (thetasq/(thetasq + (sigsq/n)))) + theta[1] } if(cJM > 1) { if(J == 1) { arg <- outer(zzz, pi * (1:(J.MAX1 - 1))) } else { arg <- outer(zzz, pi * (J:(J.MAX1 - 1))) } bas <- (2^(1/2)) * cos(arg) rest.theta <- fc[(J + 1):J.MAX1] rest.theta[rest.theta^2 <= (cT * sigsq * log(n + 3))/n] <- 0 fS <- fS + bas %*% rest.theta } fS } ############################################################################################################################# ############################################################################################################################# estcregm<-function(X = NA, Y = NA, cJ0 = 4, cJ1 = 1/2, cJM = 6, cT = 4, method = NA, knots = 100, flagX = 0, s0 = 0.5, s1 = 0.5, r = 2, JJMAX = 100, FLAGADDTS = 0) { #this is estcregm in book1fig that estimates regression via cosine basis # it transfers X onto [0,1] only if X are beyond [0,1] # it returns the regression function supported on domain of [0,1] # ######method gives different procedures of estimtion Fourier coefficients #method=2 - direct summation assuming uniform distribution of X, #################and sig is GIVEN, sig=noise.sd*coef.sd #method=4 - heteroscedastic random design, use s =s0 +s1* ln(ln(n+20)) #######methods are described in Chapter 4 #Jsig=Jsig0 + Jsig1*log(n) cosine coefficients are used to calculate # the sigma is calculated for method 2 as # mad(Y-fSS(with Jsig cos coeffic)) # here it is "T" - truncated or "S" - smoothed #flagX=1 then return values at points X #flagX=0 then return values at points seq(0,1,. l=knots) #rs=5 for equidistant, and rs = 10 #FLAGADDTS=1 - this is a different return values for additive t.series Sect.5.5 a <- min(X) b <- max(X) if((a < 0) | (b > 1)) { X <- (X - a)/(b - a) } n <- length(X) zzz <- seq(0, 1, len = knots) if(flagX == 1) { zzz <- X } J.MAX <- ceiling(cJ0 + cJ1 * log(n + 3)) J.MAX1 <- floor(cJM * J.MAX) est <- estcregfc(X = X, Y = Y, method = method, JMAX = J.MAX1, s0 = s0, s1 = s1, r = r) fc <- est$theta fS <- estcreg(X = est$X, Y = est$Y, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, knots = knots, method = method, flagX = 1, s0 = s0, s1 = s1, r = r) # denS <- estcden(X = est$X, reg = 1)$estS sigsq <- n^2 * mean(((est$Y - fS) * est$X12)^2) fcsq <- fc^2 - sigsq/n fcsq[fcsq < 0] <- 0 theta <- fc[1:J.MAX] thetasq <- fcsq[1:J.MAX] error <- matrix((sigsq/n) - thetasq, nrow = 1) %*% Updiag(J.MAX) J <- order(error)[1] ##############this is only for detrending in Spectral density J <- min(J, JJMAX) if(cJM > 1) { J.MAX1 <- min(J.MAX1, JJMAX + 1) } ########################################################################## if(J == 1) { fS <- theta[1] + 0 * zzz } else { theta <- theta[1:J] thetasq <- thetasq[2:J] arg <- outer(zzz, pi * (1:(J - 1))) bas <- (2^(1/2)) * cos(arg) fS <- bas %*% (theta[2:J] * (thetasq/(thetasq + (sigsq/n)))) + theta[1] } if(cJM > 1) { if(J == 1) { arg <- outer(zzz, pi * (1:(J.MAX1 - 1))) } else { arg <- outer(zzz, pi * (J:(J.MAX1 - 1))) } bas <- (2^(1/2)) * cos(arg) rest.theta <- fc[(J + 1):J.MAX1] rest.theta[rest.theta^2 <= (cT * sigsq * log(n + 3))/n] <- 0 fS <- fS + bas %*% rest.theta } ##########this is for detrending in Spectral Density##### if(FLAGADDTS == 1) { fS <- list(f = fS, fourc = fc, sigsq = sigsq, J = J) } fS } ############################################################################################################################# ############################################################################################################################# estcregs<-function(X = NA, Y = NA, knots = 100, cJ0 = 4, cJ1 = 1/2, cJM = 6, cT = 4, method = 4, s0 = 0.5, s1 = 0.5, r = 2, cB = cB) { #this is estcregs in book1fig that estimates # scale function for heteroscedastic regression f <- estcregm(X = X, Y = Y, method = 4, flagX = 1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, knots = knots, cT = cT, s0 = 0.5, s1 = 0.5, r = 2) Z <- (Y - f)^2 Z <- estcregm(X = X, Y = Z, method = 4, cJ0 = cJ0, cJ1 = , 5, cJM = cJM, cT = cT, s0 = 0.5, knots = knots, s1 = 0.5, r = 2) Z <- negden(Z, FLAGBUMP = 1, cB = cB) sqrt(Z) } ############################################################################################################################# ############################################################################################################################# estfilt<-function(hat.theta = NA, knots = 100, cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, cB = 2, kk = 30) { #this is estfilt in book1fign that filteres from white noise k <- length(hat.theta) sigmasq <- mean((hat.theta[(k - kk):k])^2) n <- 1/sigmasq JMAX <- ceiling(cJ0 + cJ1 * log(n + 3)) thetasq1 <- hat.theta^2 - sigmasq thetasq1[thetasq1 < 0] <- 0 theta <- hat.theta[1:JMAX] thetasq <- thetasq1[1:JMAX] error <- matrix(sigmasq - thetasq, nrow = 1) %*% Updiag(JMAX) J <- order(error)[1] theta <- theta[1:J] thetasq <- thetasq[1:J] JMM <- min(k, cJM * JMAX) - 1 theta <- (theta * thetasq)/(thetasq + sigmasq) if((J + 1) >= JMM) { JMM <- J + 1 rest.theta <- 0 } else { rest.theta <- hat.theta[(J + 1):JMM] rest.theta[rest.theta^2 < (cT * log(n + 3))/n] <- 0 } theta <- c(theta, rest.theta) arg <- outer(seq(0, 1, len = knots), pi * (1:(JMM - 1))) bas <- cbind(matrix(rep(1, knots), ncol = 1, nrow = knots), (2^(1/2)) * cos(arg)) f <- bas %*% theta f <- negden(f, FLAGBUMP = 1, cB = cB) f } ############################################################################################################################# ############################################################################################################################# estimfcd<-function(X = NA, J = 10) { # ESTIMFCD in book1fig estimates J Fourier coef and squared Fourier # coefficients for data X and cosine bases on [0,1] n <- length(X) bas <- (2^(1/2)) * cos(outer(X, pi * (1:J))) l <- matrix(rep(1, n), nrow = 1) fc <- (l/n) %*% bas fcsq <- (n/(n - 1)) * fc^2 - (l %*% bas^2)/(n * (n - 1)) fcsq[fcsq < 0] <- 0 list(theta = fc, thetasq = fcsq) } ############################################################################################################################# ############################################################################################################################# estimfcd.der<-function(X = NA, J = 10) { # estimfcd.der in book1fig estimates J Fourier coef, J=0,1,... # for cos basis on [0,1] plus x^2 term #return Fourier coeff EXCEPT of theta_0 which is 1 n <- length(X) if(J == 0) { fc <- mean(X - 0.5)/sqrt(1/12) fc1 <- mean((X^2 - 1/3 - (X - 0.5)))/sqrt(4/45 - 1/12) fc <- c(fc, fc1) fcsq <- fc^2 - 1/n fcsq[fcsq < 0] <- 0 psi1 <- (X - 0.5)/sqrt(1/12) psi2 <- (X^2 - 1/3 - (X - 0.5))/sqrt(4/45 - 1/12) } else { bas <- (2^(1/2)) * cos(outer(X, pi * (1:J))) vec <- 1:J psi1 <- matrix(X - 0.5, ncol = 1) - sqrt(2) * pi^(-2) * bas %*% matrix(vec^(-2) * (cos(pi * vec) - 1), ncol = 1) vec1 <- (J + 1):(J + 50) normsq <- 2 * pi^(-4) * sum(vec1^(-4) * (cos(pi * vec1) - 1)^2) psi1 <- psi1/sqrt(normsq) ###########calculation psi2############## psi2 <- matrix(X^2 - 1/3, ncol = 1) - (4/(sqrt(2) * pi^2)) * bas %*% matrix((vec^(-2)) * cos(pi * vec), ncol = 1) b <- (1/12 - 4 * pi^(-4) * sum(vec^(-4) * (1 - cos(pi * vec))))/sqrt(normsq) psi2 <- psi2 - b * psi1 normsq <- 4/45 - 8 * pi^(-4) * sum(vec^(-4)) - b^2 psi2 <- psi2/sqrt(normsq) bas <- cbind(bas, psi1, psi2) l <- matrix(rep(1, n), nrow = 1) fc <- (l/n) %*% bas fcsq <- fc^2 - 1/n fcsq[fcsq < 0] <- 0 } list(theta = fc, thetasq = fcsq, psi1 = psi1, psi2 = psi2) } ############################################################################################################################# ############################################################################################################################# estsden<-function(X = NA, knots = 100, cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, reg = 0, cVAL = 1, cB = 2, FLAGNNEG = 1, FLAGHYPT = 0, FLAGBASIS = 1) { #this is ESTSDEN in book1fign that estimates density via sine basis # and returns risks # if reg=1 then the program return density at points X # b <- 4 #if FLAGHYPT=1 then returns test statistics for the nonparam test sect. 3.8 #if FLAGBASIS=1 then returns both function and estimated empir risk n <- length(X) JMAX <- ceiling(cJ0 + cJ1 * log(n + 3)) bas <- (2^(1/2)) * sin(outer(X, pi * (1:(cJM * JMAX)))) l <- matrix(rep(1, n), nrow = 1) fc <- (l/n) %*% bas fcsq <- (n/(n - 1)) * fc^2 - (l %*% bas^2)/(n * (n - 1)) fcsq[fcsq < 0] <- 0 theta1 <- fc thetasq1 <- fcsq theta <- theta1[1:JMAX] thetasq <- thetasq1[1:JMAX] error <- matrix((cVAL/n) - thetasq, nrow = 1) %*% Updiag(JMAX) J <- order(error)[1] theta <- theta[1:J] #############here the case J=1 (because it may be a good idea to set J=0) if((J == 1) & (cVAL/n - thetasq[1] >= 0)) { theta <- 0 } thetasq <- thetasq[1:J] arg <- outer(seq(0, 1, len = knots), pi * (1:(cJM * JMAX))) if(reg == 1) { arg <- outer(X, pi * (1:(cJM * JMAX))) } bas <- (2^(1/2)) * sin(arg) # theta[thetasq < rep(log(J + 3)/(2 * n), J)] <- 0 theta <- (theta * thetasq)/(thetasq + (1/n)) if(cJM <= 1) { if(JMAX > J) { theta <- c(theta, rep(0, JMAX - J)) } } if(cJM > 1) { rest.theta <- theta1[(J + 1):(cJM * JMAX)] rest.theta[rest.theta^2 < (cT * log(n + 3))/n] <- 0 theta <- c(theta, rest.theta) } fS <- bas %*% theta if(FLAGNNEG == 1) { fS <- negden(fS, FLAGBUMP = 1, cB = cB) } if(FLAGHYPT == 1) { fS <- theta1[1:JMAX] fS <- sum(fS^2) } if(FLAGBASIS == 1) { thetasq <- theta^2 thetasq <- thetasq[thetasq > 0] risk <- 2 * length(thetasq) - sum(thetasq) fS <- list(fS = fS, risk = risk) } fS } ############################################################################################################################# ############################################################################################################################# estspden<-function(X = NA, TT = NA, FLAGMIS = 0, knots = 100, cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, cB = 2, FLAGNEG = 1) { #this is estspden in book1fign that estimates spectr density #FLAGMIS=1 for the case of missed observations n <- length(X) if(FLAGMIS == 1) { n <- sum(TT) } JMAX <- ceiling(cJ0 + cJ1 * log(n + 3)) theta1 <- acf(X, lag.max = cJM * JMAX + 1, type = "covariance", plot = F)$acf[, 1, 1] if(FLAGMIS == 1) { cc <- acf(TT, cJM * JMAX + 1, type = "covariance", plot = F)$acf[, 1, 1] + mean(TT)^2 theta1 <- (theta1 + mean(X)^2)/cc } d <- 2 * sum(theta1[1:JMAX]^2) - theta1[1]^2 thetasq1 <- theta1^2 - d/n thetasq1[thetasq1 < 0] <- 0 theta <- theta1[1:JMAX] thetasq <- thetasq1[1:JMAX] error <- matrix(d/n - thetasq, nrow = 1) %*% Updiag(JMAX) J <- order(error)[1] theta <- theta[1:J] thetasq <- thetasq[1:J] arg <- outer(seq(0, pi, len = knots), (0:(cJM * JMAX))) bas <- cos(arg)/pi theta <- (theta * thetasq)/(thetasq + (d/n)) theta[1] <- theta[1]/2 if(cJM <= 1) { if(JMAX > J) { theta <- c(theta, rep(0, JMAX - J + 1)) } } if(cJM > 1) { rest.theta <- theta1[(J + 1):(cJM * JMAX + 1)] rest.theta[rest.theta^2 < (cT * d * log(n + 3))/n] <- 0 theta <- c(theta, rest.theta) } f <- bas %*% theta if(FLAGNEG == 1) { f <- negden(f, FLAGBUMP = 1, cB = cB) } else { f[f < 0] <- 0 } f } ############################################################################################################################# ############################################################################################################################# exp.ron<-function(fig = "den", a = 5, b = 70, knots = 100, cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, cB = 2, ncl = 50) { #this is exp for analysing Ron's Data in ds.Sam #1st column 0 or 1 , 1 if uncensored, second : 100 - age #fig = "hs" - histogram of cens data #fig="hn" - hist of non-censored data #fig="ht" - hist og total data #fig="den" - density over [a,b], for ds.Sam [3,71] is the range. X <- ds.Sam[, 2] D <- ds.Sam[, 1] XR <- 100 - X if(fig == "den") { aa <- (a - min(XR))/(max(XR) - min(XR)) cc <- (max(XR) - b)/(max(X) - min(X)) bb <- 1 - aa - cc YY <- (X - min(X))/(max(X) - min(X)) par(mfrow = c(2, 4)) for(JJ in seq(2, 16, len = 8)) { est <- surv.estdenc(Y = YY, D = D, a = aa, b = bb, cJ0 = JJ, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB, knots = knots) est <- rev(est) z <- seq(a, b, len = knots) plot(z, est, type = "l", sub = paste("the cJ0 = ", JJ, sep = "")) } } if(fig == "ht") { hist(XR, prob = T, nclass = 50, ylab = "Total") } if(fig == "hn") { hist(XR[D == 1], prob = T, nclass = ncl, ylab = "Uncensored") } if(fig == "hn") { hist(XR[D == 1], prob = T, nclass = ncl, ylab = "Uncensored") } if(fig == "hs") { hist(XR[D == 0], prob = T, nclass = ncl, ylab = "Censored") } } ############################################################################################################################# ############################################################################################################################# fractgn<-function(n = 10, alpha = 0.5) { #this is fractgn in book1fig that generates fractional Gaussian #noise # H = 1-\alpha/2 H <- 1 - alpha/2 # #this is the programm from BERAN (1996, p. 218) ################################################## k <- 0:(n - 1) H2 <- 2 * H result <- (abs(k - 1)^H2 - 2 * abs(k)^H2 + abs(k + 1)^H2)/2 ############################################# gammak <- result ind <- c(0:(n - 2), (n - 1), (n - 2):1) gk <- gammak[ind + 1] gk <- fft(c(gk), inverse = T) z <- rnorm(2 * n) zr <- z[c(1:n)] zi <- z[c((n + 1):(2 * n))] zic <- zi zi[1] <- 0 zr[1] <- zr[1] * sqrt(2) zi[n] <- 0 zr[n] <- zr[n] * sqrt(2) zr <- c(zr[c(1:n)], zr[c((n - 1):2)]) zi <- c(zi[c(1:n)], zic[c((n - 1):2)]) z <- complex(real = zr, imaginary = zi) #cat("n=",n,"h=",H) gksqrt <- Re(gk) if(all(gksqrt > 0)) { gksqrt <- sqrt(gksqrt) z <- z * gksqrt z <- fft(z, inverse = T) z <- 0.5 * (n - 1)^(-0.5) * z z <- Re(z[c(1:n)]) } else { gksqrt <- 0 * gksqrt cat("Re(gk)-vector not positive") } list(z = z) } ############################################################################################################################# ############################################################################################################################# haar<-function(knots = 1000, level = 1, shift = 0) { #this is HAAR, level=0 gives father anf > 1 gives mothers z <- seq(from = 0, to = 1, l = knots) r <- (z + 1)/(z + 1) if(level == 0) { f <- (z >= 0 * r) * (z <= r) } else { f <- 2^((level - 1)/2) * haar1(2^(level - 1) * z - shift) } f } ############################################################################################################################# ############################################################################################################################# haar1<-function(z = NA) { #function HAAR1 calculates the mother Haar r <- rep(1, length(z)) f <- (z >= 0 * r) * (z < 0.5 * r) - (z > 0.5 * r) * (z <= r) f } ############################################################################################################################# ############################################################################################################################# haararp<-function(f = NA, z = NA, level = 1) { #this is a function HAARAPR in ../book1fig #approx and computes Fourier coeffic for Haar basis on [0,1] for(j in (0:level)) { if(j == 0) { bas <- haar(knots = length(z), level = 0, shift = 0) bas <- matrix(bas, ncol = 1) } else for(k in (0:(2^(j - 1) - 1))) { bas <- cbind(bas, matrix(haar(knots = length(z), level = j, shift = k), ncol = 1)) } } fourc <- matrix(f[2:(length(f) - 1)], nrow = 1) %*% bas[2:(length(f) - 1), ] fourc <- fourc + (f[1] * bas[1, ] + f[length(f)] * bas[length(f), ])/2 fourc <- fourc/(length(f) - 1) hapr <- bas %*% matrix(fourc, ncol = 1) list(fcoef = fourc, apr = hapr) } ############################################################################################################################# ############################################################################################################################# #last.dump<-$"": #[1] "No Frame Available" #$".C(NAME = \"S_api_get_message\",": #[1] "No Frame Available" #$".Sapi.build.output(txt = \"illp.heat1fcgh\\n\", hints = c(\"SapiOutput\", \"SapiErrorText\", \"SapiWarningText\", \"SapiEnd\"))": #[1] "No Frame Available" #$"eval(expr, local = F)": #[1] "No Frame Available" #attr(, "message"): #[1] "Error: Object \"illp.heat1fcgh\" not found\n" ############################################################################################################################# ############################################################################################################################# #last.warning<- #$"replacement values not all in levels(x): NA's generated": #"[<-.factor"(xj, iseq, value = vjj) ############################################################################################################################# ############################################################################################################################# legapr<-function(f = NA, z = NA, level = 1) { #this is a function LEGAPR in ../book1graf #approx and computes Fourier coeffic for Legandre basis on [0,1] z1 <- seq(0, 1, len = length(f)) z2 <- legpol(z = z1, level = level) fourc <- matrix(f[2:(length(f) - 1)], nrow = 1) %*% z2[2:(length(f) - 1), ] fourc <- fourc + (f[1] * z2[1, ] + f[length(f)] * z2[length(f), ])/2 fourc <- fourc/(length(z1) - 1) z3 <- legpol(z = z, level = level) legrapr <- z3 %*% matrix(fourc, ncol = 1) list(fcoef = fourc, apr = legrapr) } ############################################################################################################################# ############################################################################################################################# legpol<-function(z = NA, level = 2) { #function LEGPOL in book1fig # this function gives 1+ level first orthonormal on [0,1] #Legendre polynomilas calculated at points z #I use the recurrence formula from Sansone p. 178 (3.1.13) for #Lagrange polynomials supported on [-1,1], #P_n (z) = n^{-1}[(2n-1) z P_{n-1}(z) - (n-1) P_{n-2}(z)] # and I calculated that my first LF_0(z) = 1 and LF_1(z) = 2z-1 zz <- 2 * matrix(z, ncol = 1) - 1 R1 <- matrix(rep(1, length(z)), ncol = 1) R2 <- zz for(i in (0:level)) { if(i == 0) { LF <- R1 } else if(i == 1) { LF <- cbind(R1, sqrt(3) * R2) } else { R3 <- ((2 * i - 1) * (zz * R2) - (i - 1) * R1)/i R1 <- R2 R2 <- R3 LF <- cbind(LF, sqrt(2 * i + 1) * R3) } } LF } ############################################################################################################################# ############################################################################################################################# lenb.gen<-function(i = 1, n = 50, a = 0.1, b = 0.9, CFUN = list(NA, NA)) { #this is lenb.gen in book1fig to generate length-biased data # for g=a+bx and returns g(Y) flag <- 1 Y <- 0 g.z <- a + b * seq(0, 1, len = 100) mu <- mean(dcornerf(c = i, knots = 100, CFUN = CFUN) * g.z) C <- max(1, max(g.z/mu)) while(flag == 1) { U <- runif(2 * n) X <- rcornerf(corn = i, n = 2 * n, CFUN = CFUN) Y1 <- X[U <= (a + b * X)/(C * mu)] Y <- c(Y, Y1) if(length(Y) >= n + 1) { Y <- Y[2:(n + 1)] flag <- 0 } } gv <- a + b * Y list(Y = Y, gv = gv) } ############################################################################################################################# ############################################################################################################################# loclin<-function(X = NA, Y = NA, h = NA, knots = 100, kernel = "g") { #this is loclin in book1fig that calculates local linear regr # according to Wand and Jones p.119 # kernel is "g" gaussuian or "r" rectangular Z <- seq(0, 1, len = knots) n <- length(X) matX <- matrix(X, ncol = n, nrow = knots, byrow = T) matZ <- matrix(Z, ncol = n, nrow = knots, byrow = F) XminZ <- matX - matZ vXZ <- matrix(XminZ, nrow = 1) if(kernel == "g") { K.h <- dnorm(vXZ, sd = h) } else { K.h <- dunif(vXZ, min = - h, max = h) } K.h <- matrix(K.h, ncol = n, nrow = knots, byrow = F) s0 <- apply(K.h, 1, mean) s1 <- apply(K.h * XminZ, 1, mean) s2 <- apply(K.h * (XminZ^2), 1, mean) mat.s2 <- matrix(s2, ncol = n, nrow = knots, byrow = F) mat.s1 <- matrix(s1, ncol = n, nrow = knots, byrow = F) v <- apply(matrix(Y, ncol = n, nrow = knots, byrow = T) * K.h * (mat.s2 - mat.s1 * XminZ), 1, mean) f <- v/(s2 * s0 - s1^2) f } ############################################################################################################################# ############################################################################################################################# monot<-function(f = NA, del = 0.0001) { #this is monot in book1fig with makes projection on monotonic increasing i <- 1 Y <- f while(i < length(Y)) { if(Y[i + 1] < Y[i] - del) { Y[i:(i + 1)] <- (Y[i] + Y[i + 1])/2 j <- i while(j > 1) { if(Y[j] < Y[j - 1] - del) { Y[(j - 1):(j + 1)] <- (Y[j - 1] + Y[j] + Y[j + 1])/3 j <- j - 1 } else { i <- j j <- 1 } } } else { i <- i + 1 } mm <- rbind(matrix(f, nrow = 1), matrix(Y, nrow = 1)) } Y } ############################################################################################################################# ############################################################################################################################# negden<-function(f = NA, delta = 0.01, FLAGBUMP = 1, cB = 2) { #this is negden in book1fig that finds nonnegative projection #FLAGBUM =1 then the program removes bumps whose int f^2 dx # less than cof*\int (f - f.neg)^2 dx flag <- 0 f1 <- f k <- length(f) AREA <- (k/(k - 1)) * mean(f) - (f[1] + f[k])/(2 * (k - 1)) if(all(f >= 0)) { flag <- 1 } if(all(f <= 2 * delta) | (AREA <= 2 * delta)) { flag <- 2 } while(flag == 0) { f <- f - delta f[f < 0] <- 0 int <- (k/(k - 1)) * mean(f) - (f[1] + f[k])/(2 * (k - 1)) if(int <= AREA) { if(int > (10 * delta)) { f <- f * (AREA/int) } flag <- 1 } } if(FLAGBUMP == 1) { AREASQ <- mean((f - f1)^2) f <- rem.bump1(f = f, AREASQ = AREASQ, coef = cB) } if(flag == 1) { if(mean(f) > (10 * delta)) { f <- f * (AREA/mean(f)) } } f[f < 0] <- 0 f } ############################################################################################################################# ############################################################################################################################# rcornerf<-function(cornerf = 2, n = 1000, CFUN = list(NA, NA)) { #this is a function RCORNERF in ../book1fig that returns #n random variables of the corner function # number "cornerf" at "knots" points between 0 and 1 # 1 - Uniform, 2 - Normal, 3 - Bimodal, 4 - Strata # 5 - Delta, 6 - Angle, 7 - Monotone, 8 - Steps, # 10 - Custom flag <- 1 flag1 <- 1 sampl <- NA sampl1 <- NA if(!is.na(CFUN[[1]]) && !is.na(CFUN[[2]]) && cornerf == CFUN[[1]]) { cornerf <- 10 } if(cornerf == 1) { sampl <- runif(n, 0, 1) } else if(cornerf == 2) { while(flag == 1) { s <- rnorm(n + 1, mean = 0.5, sd = 0.15) sampl <- c(s[(s >= 0) & (s <= 1)], sampl) if(length(sampl) > n) { flag <- 0 sampl <- sampl[1:n] } } } else if(cornerf == 3) { while(flag == 1) { u <- sample(2, prob = c(0.5, 0.5), size = n + 1, replace = T) - 1 s <- u * rnorm(n + 1, 0.4, 0.12) + (1 - u) * rnorm(n + 1, 0.7, 0.08) sampl <- c(s[(s >= 0) & (s <= 1)], sampl) if(length(sampl) > n) { flag <- 0 sampl <- sampl[1:n] } } } else if(cornerf == 4) { while(flag == 1) { u <- sample(2, prob = c(0.5, 0.5), size = n + 1, replace = T) - 1 s <- u * rnorm(n + 1, 0.2, 0.06) + (1 - u) * rnorm(n + 1, 0.75, 0.08) sampl <- c(s[(s >= 0) & (s <= 1)], sampl) if(length(sampl) > n) { flag <- 0 sampl <- sampl[1:n] } } } else if(cornerf == 5) { sampl <- rnorm(n, 0.5, 0.02) } else if(cornerf == 6) { while(flag == 1) { s <- rnorm(n + 1, mean = 1, sd = 0.7) sampl <- c(s[(s >= 0) & (s <= 0.5)], sampl) if(length(sampl) > n) { flag <- 0 sampl <- sampl[1:n] } } while(flag1 == 1) { s <- rnorm(n + 1, mean = 0, sd = 0.7) sampl1 <- c(s[(s >= 0.5) & (s <= 1)], sampl1) if(length(sampl1) > n) { flag1 <- 0 sampl1 <- sampl1[1:n] } } u <- sample(2, prob = c(0.5, 0.5), size = n, replace = T) - 1 sampl <- u * sampl + (1 - u) * sampl1 } else if(cornerf == 7) { while(flag == 1) { s <- rnorm(n + 1, mean = 2, sd = 0.8) sampl <- c(s[(s >= 0) & (s <= 1)], sampl) if(length(sampl) > n) { flag <- 0 sampl <- sampl[1:n] } } } else if(cornerf == 8) { u <- sample(3, prob = c(0.2, 0.9 * (3/4 - 1/3), (204/120)/4), size = n, replace = T) l1 <- length(u[u == 1]) l2 <- length(u[u == 2]) l3 <- n - l1 - l2 sampl <- c(runif(l1, 0, 1/3), runif(l2, 1/3, 3/4), runif(l3, 3/4, 1)) } else if(cornerf == 10) { sampl <- rgen(n, CFUN[[2]]) } sampl } ############################################################################################################################# ############################################################################################################################# rgen<-function(n = NA, den = NA) { #rgen which generates n RV with density p(x)=den(x) m <- n + 100 x <- (1:m)/m eval(parse(text = paste("p <- ", den))) p[p < 0] <- 0 if(max(p) == 0) { stop("Custom density is negative") } p <- p/mean(p) cdf <- cumsum(p)/m U <- runif(n) # U <- sort(U) X <- outer(cdf, U, "<") X <- apply(X, 2, sum) X <- X/m X } ############################################################################################################################# ############################################################################################################################# testnonp<-function(n = NA, test = NA, cJ0 = NA, cJ1 = NA, m = NA) { #this is testnonp in book1fign which calculates p-value for #\sum_{j=1}^JMAX \theta_j^2 test JMAX <- ceiling(cJ0 + cJ1 * log(n + 3)) ll <- matrix(rep(1, n), nrow = 1)/n t <- 0 for(i in 1:m) { U <- runif(n) mat <- outer(pi * U, 1:JMAX) mat <- 2^(1/2) * cos(mat) tt <- ll %*% mat tt <- sum(tt^2) if(tt >= test) { t <- t + 1 } } pval <- t/m pval } ############################################################################################################################# ############################################################################################################################# tests<-function(X = NA, l = 10, m = 10, cJ0 = 4, cJ1 = 0.5) { #this is tests in book1fign which calculates p-values for test # Kolmogorov, Moran, Chi-squared and Nonparametric # X should be on [0,1] #l - number of bins for Chi-Squared #m - number of repeated simulat for Nonparametric #######Kolmogorov############### X <- sort(X) n <- length(X) sqn <- n^(1/2) DK <- sqn * max(abs((1:n)/n - X)) ll <- 1:30 pvalK <- 2 * sum((-1)^(ll + 1) * exp(-2 * ll^2 * DK^2)) ################Moran ################## MM <- sum((c(X, 1) - c(0, X))^2) MM <- sqn * ((n * MM)/2 - 1) pvalM <- 1 - pnorm(MM) ########Chi-Squared############# chsq <- sum((table(cut(X, l)) - n/l)^2)/(n/l) pvalC <- 1 - pchisq(chsq, df = l - 1) #######Nonparametric ################## JMAX <- ceiling(cJ0 + cJ1 * log(n + 3)) ll <- matrix(rep(1, n), nrow = 1)/n mat <- outer(pi * X, 1:JMAX) mat <- 2^(1/2) * cos(mat) tt <- ll %*% mat test <- sum(tt^2) t <- 0 for(i in 1:m) { U <- runif(n) mat <- outer(pi * U, 1:JMAX) mat <- 2^(1/2) * cos(mat) tt <- ll %*% mat t <- c(t, sum(tt^2)) } pvalN <- length(t[t >= test])/m c(pvalK, pvalM, pvalC, pvalN) } ############################################################################################################################# ############################################################################################################################# trigcapr<-function(f = NA, level = 3, xsq = 0, a = 0.55, knots = 50, bound = c(0.1, 0.9)) { #this is a function TRIGCAPR in ../book1graf #approx and computes Fourier coeffic for cos bases 1, 2^{1/2} cos(\pijx) #here only for xsq=0 I made a possibility to use different knots for appr # If xsq=1 then I add the term x^2 via Gram-Schmidt # Id xsq =2 I add both linear x and x^2 # If xsq=3 I add a jump basis function at x=a # If xsq=4 I add a flexiblae jump function at x=b where $b$ #corresponds to the largest Fourier coefficient # plot(z, f) b <- -10 z <- seq(0, 1, len = length(f)) z1 <- outer(z, pi * (1:level)) if(xsq == 1) { phisq <- matrix(z^2 - (1/3), ncol = 1, byrow = F) for(s in (1:level)) { phisq <- phisq - (4/(s * pi)^2) * cos(s * pi) * cos(s * pi * matrix(z, ncol = 1, byrow = F)) } phisq <- phisq/(mean(phisq^2))^(1/2) z2 <- cbind(1, sqrt(2) * cos(z1), phisq) } else if(xsq == 2) { phi <- matrix(z - 1/2, ncol = 1, byrow = F) for(s in (1:level)) { phi <- phi - (2/(pi * s)^2) * (cos(pi * s) - 1) * cos(s * pi * matrix(z, ncol = 1, byrow = F)) } phi <- phi/(mean(phi^2))^(1/2) #####just calculate the inner product d <- matrix(seq(0, 1, len = 100000), ncol = 1, byrow = F) phid <- d - 1/2 for(s in (1:level)) { phid <- phid - (2/(pi * s)^2) * (cos(pi * s) - 1) * cos(s * pi * matrix(d, ncol = 1, byrow = F)) } phid <- phid/(mean(phid^2))^(1/2) zz <- matrix(z^2, ncol = 1, byrow = F) phisq <- zz - (1/3) - mean(d^2 * phid) * phi for(s in (1:level)) { phisq <- phisq - (4/(s * pi)^2) * cos(s * pi) * cos(s * pi * matrix(z, ncol = 1, byrow = F)) } phisq <- phisq/(mean(phisq^2))^(1/2) # browser() z2 <- cbind(1, sqrt(2) * cos(z1), phi, phisq) } else if(xsq == 3) { dd <- matrix(seq(from = 0, by = 0, len = length(z)), ncol = 1, byrow = F) dd[1:min(length(z), max(1, (a * length(z)))), ] <- 1 phi <- dd - a for(s in (1:level)) { phi <- phi - 2 * (pi * s)^(-1) * sin(pi * s * a) * cos(s * pi * matrix(z, ncol = 1, byrow = F)) } phi <- phi/(mean(phi^2))^(1/2) z2 <- cbind(1, sqrt(2) * cos(z1), phi) } else if(xsq == 4) { # fff <- matrix(f, nrow = 1) # fff <- matrix(dcornerf(c = 8, knots = length(z)), nrow = 1) # plot(z, fff) for(b in seq(bound[1], bound[2], len = knotslen)) { dd <- matrix(seq(from = 0, by = 0, len = length(z)), ncol = 1, byrow = F) dd[1:min(length(z), max(1, (b * length(z)))), ] <- 1 phi <- dd - b for(s in (1:level)) { phi <- phi - 2 * (pi * s)^(-1) * sin(pi * s * b) * cos(s * pi * matrix(z, ncol = 1, byrow = F)) } phi <- phi/(mean(phi^2))^(1/2) thetas <- (fff %*% phi/length(z))^2 if(b == bound[1]) { thetav <- thetas } else { thetav <- c(thetav, thetas) } } b <- rev(order(thetav))[1]/knotslen #############compute the Four coef for such b dd <- matrix(seq(from = 0, by = 0, len = length(z)), ncol = 1, byrow = F) dd[1:min(length(z), max(1, (b * length(z)))), ] <- 1 phi <- dd - b for(s in (1:level)) { phi <- phi - 2 * (pi * s)^(-1) * sin(pi * s * b) * cos(s * pi * matrix(z, ncol = 1, byrow = F)) } phi <- phi/(mean(phi^2))^(1/2) #############I have to elliminate highly correlated function######### if(b <= 0.05 | b >= 0.95) { phi <- 0 * phi } z2 <- cbind(1, sqrt(2) * cos(z1), phi) } else { z2 <- cbind(1, sqrt(2) * cos(z1)) } fourc <- matrix(f[2:(length(f) - 1)], nrow = 1) %*% z2[2:(length(f) - 1), ] fourc <- fourc + (f[1] * z2[1, ] + f[length(f)] * z2[length(f), ])/2 fourc <- fourc/(length(z) - 1) trapr <- z2 %*% matrix(fourc, ncol = 1) ###########here I make different knots############# if(xsq == 0) { zz <- seq(0, 1, len = knots) zz1 <- outer(zz, pi * (1:level)) zz2 <- cbind(1, sqrt(2) * cos(zz1)) trapr <- zz2 %*% matrix(fourc, ncol = 1) } list(fcoef = fourc, apr = trapr) # plot(z, phi) # list(mat = t(z2) %*% z2/length(z), b = b) } ############################################################################################################################# ############################################################################################################################# trigscapr<-function(f = NA, z = seq(0, 1, len = 300), level = 3, xsq = 1) { #this is a function TRIGSCAPR in ../book1graf #approx and computes Fourier coeffic for sin-cos bases 1, 2^{1/2} cos(2\pij x) #2^{1/2} sin(2 \pi jx) on [0,1] for j \leq level # If xsq =0 then just sin and cos # If xsq=1 then I add the term x via Gram-Schmidt # Id xsq =2 I add both linear x and x^2 z1 <- outer(z, 2 * pi * (1:level)) z <- matrix(z, ncol = 1, byrow = F) z2 <- cbind(1, sqrt(2) * cos(z1), sqrt(2) * sin(z1)) jj <- matrix(seq(from = 1, by = 1, len = level), ncol = 1, byrow = F) phis <- z - 0.5 + (1/(sqrt(2) * pi)) * sqrt(2) * sin(z1) %*% jj^(-1) norms <- (1/12 - (1/(2 * pi^2)) * sum(jj^(-2)))^(1/2) phis <- phis/norms phic <- z^2 - (1/3) - (1/(sqrt(2) * pi^2)) * sqrt(2) * cos(z1) %*% jj^(-2) + (1/(sqrt(2) * pi)) * sqrt(2) * sin(z1) %*% jj^(-1) - norms * phis normc <- (4/45 - (1/(2 * pi^4)) * sum(jj^(-4)) - (1/(2 * pi^2)) * sum(jj^(-2)) - norms^2)^(1/2) phic <- phic/normc if(xsq == 1) { z2 <- cbind(z2, phis) } else if(xsq == 2) { z2 <- cbind(z2, phis, phic) } fourc <- matrix(f[2:(length(f) - 1)], nrow = 1) %*% z2[2:(length(f) - 1), ] fourc <- fourc + (f[1] * z2[1, ] + f[length(f)] * z2[length(f), ])/2 fourc <- fourc/(length(z) - 1) trapr <- z2 %*% matrix(fourc, ncol = 1) list(fcoef = fourc, apr = trapr) } ############################################################################################################################# ############################################################################################################################# updiag<-function(J = 2) { #this is Updiag in book1fig that returnes matrix J*J with 1 on and #above duig and zeros below m <- matrix(1, nrow = J, ncol = J) m[row(m) > col(m)] <- 0 m } ############################################################################################################################# ############################################################################################################################# zalpha<-function(a = 0.05, J = 10, knots = 300, m = 1000) { # this is zalpha in book1fig that calculates quantiles for Section 7.9 # P(max_t \sum_{j=1}^J X_j \varphi > z_{a}(J)) = a; \varphi # is the trigonometric basis # a = alpha/2 # J is even J1 <- J + 1 rep <- ceiling(1/a) for(i in 1:rep) { Z <- rnorm(J1 * m) ZMAT <- matrix(Z, nrow = m, ncol = J1) cn <- cos(outer(0:(J/2), 2 * pi * seq(0, 1, len = knots))) sn <- sin(outer(1:(J/2), 2 * pi * seq(0, 1, len = knots))) matcs <- rbind(cn, sn) mat <- J1^{-1/2} * ZMAT %*% matcs supvec <- apply(mat, 1, max) if(i == 1) { vec <- supvec } else { vec <- c(vec, supvec) } } quantile(vec, 1 - a) } ############################################################################################################################# ############################################################################################################################# estcden.2dim <- function(X1 = NA, X2 = NA, cJ0 = NA, cJ1 = NA, cJM = NA, cT = NA, knots = 5., delta = 0.05, reg = 0., cB = 0.5) { #estcden.2dim n <- length(X1) J <- floor(cJM * (cJ0 + cJ1 * logb(n + 3.))) bas1 <- cbind(matrix(rep(1., n), ncol = 1.), 2.^(1./2.) * cos(outer( X1, pi * (1.:J)))) bas <- bas1 for(j in 1.:J) { bas <- cbind(bas, bas1 * (2.^(1./2.) * cos(X2 * pi * j))) } theta <- apply(bas, 2., mean) theta[theta^2. < (cT * logb(n + 3.))/n] <- 0. theta <- matrix(theta, ncol = 1.) if(reg == 1.) { den.est <- bas %*% theta } else { n <- knots X1 <- seq(0., 1., len = n) X2 <- X1 bas1 <- cbind(matrix(rep(1., n), ncol = 1.), 2.^(1./2.) * cos( outer(X1, pi * (1.:J)))) for(l in 1.:n) { bas <- bas1 for(j in 1.:J) { bas <- cbind(bas, bas1 * (2.^(1./2.) * cos( X2[l] * pi * j))) } est <- bas %*% theta if(l == 1.) { den.est <- est } else { den.est <- cbind(den.est, est) } } if(reg == 0.) { den1.est <- den.est flag <- 1. if(all(den.est > 0.)) { flag <- 0. } while(flag == 1.) { den.est <- den.est - delta den.est[den.est < 0.] <- 0. if(mean(apply(den.est, 2., mean)) <= 1.) { flag <- 0. } } AREA <- mean(apply((den.est - den1.est)^2., 2., mean)) den.est <- rembump2d(f = den.est, AREASQ = AREA, coef = cB) den.est <- rembump2d(f = t(den.est), AREASQ = AREA, coef = cB) den.est <- t(den.est) } den.est <- den.est/mean(apply(den.est, 2., mean)) } den.est } ######################################################################################## ######################################################################################### estcden.cond<-function(X = NA, Y = NA, cJ0 = 4., cJ1 = 0.5, cJM = NA, cT = NA, knots = 5., s0 = 0.5, s1 = 0.5, delta = 0.05, reg = 0., cB = 0.5, level = 0.3) { ######estcden.cond m <- length(X) A <- X > 0. & X < 1. & Y > 0. & Y < 1. X <- X[A] Y <- Y[A] n <- length(X) J <- floor(cJM * (cJ0 + cJ1 * logb(n + 3.))) Z <- matrix(c(X, Y), ncol = 2., nrow = n, byrow = F) Z <- Z[order(Z[, 1.]), ] X <- Z[, 1.] Y <- Z[, 2.] s <- ceiling(s0 + s1 * logb(logb(n + 20.))) X1 <- c(2. * X[1.] - X[(1. + s):2.], X[1.:(n - s)]) X2 <- c(X[(1. + s):n], 2. * X[n] - X[(n - 1.):(n - s)]) hinv <- (n * (X2 - X1))/(2. * s) bas1 <- cbind(matrix(rep(1., n), ncol = 1.), 2.^(1./2.) * matrix(hinv, ncol = J, nrow = n, byrow = F) * cos(outer(X, pi * (1.:J)))) bas <- bas1 for(j in 1.:J) { bas <- cbind(bas, bas1 * (2.^(1./2.) * cos(Y * pi * j))) } theta <- apply(bas, 2., sum)/m theta[theta^2. < (cT * logb(n + 3.))/n] <- 0. theta <- matrix(theta, ncol = 1.) if(reg == 0.) { X <- seq(0., 1., len = knots) Y <- X n <- knots } bas1 <- cbind(matrix(rep(1., n), ncol = 1.), 2.^(1./2.) * cos(outer( X, pi * (1.:J)))) for(l in 1.:n) { bas <- bas1 for(j in 1.:J) { bas <- cbind(bas, bas1 * (2.^(1./2.) * cos(Y[l] * pi * j))) } est <- bas %*% theta if(l == 1.) { den.est <- est } else { den.est <- cbind(den.est, est) } } if(reg == 0.) { den1.est <- den.est flag <- 1. if(all(den.est > 0.)) { flag <- 0. } while(flag == 1.) { den.est <- den.est - delta den.est[den.est < 0.] <- 0. if(mean(apply(den.est, 2., mean)) <= 1.) { flag <- 0. } } AREA <- mean(apply((den.est - den1.est)^2., 2., mean)) den.est <- rembump2d(f = den.est, AREASQ = AREA, coef = cB) den.est <- rembump2d(f = t(den.est), AREASQ = AREA, coef = cB) den.est <- t(den.est) } den.est <- den.est/mean(apply(den.est, 2., mean)) den.est } ################################################################################### ###################################################################################### estcden.meser<-function(Y = NA, knots = NA, sigma = NA, cb = NA, d0 = NA, d1 = NA, d2 = NA, cH = NA, cB = NA) { #####estcden.meser n <- length(Y) b.n <- 1./(cb * logb(logb(n + 20.))) J <- d0 + ceiling(d1 * (logb(n + 20.))^(1./(d2 * b.n))) h.eps <- exp( - ((pi * (1.:J)^2. * (sigma^2.))/2.)) bas <- (2.^(1./2.)) * cos(outer(Y, pi * (1.:J))) fcY <- apply(bas, 2., mean) fcsqY <- fcY^2. - 1./n fcsqY[fcsqY < 0.] <- 0. w <- fcsqY/(fcsqY + 1./n) fcX <- fcsqY/(fcsqY + 1./n) fcX[abs(h.eps) < rep(cH * n^(-1./2. + b.n), J)] <- 0. bas <- (2.^(1./2.)) * cos(outer(seq(0., 1., len = knots), pi * (1.: J))) est.den <- 1. + bas %*% matrix(fcY * w, ncol = 1.) negden(est.den, FLAGBUMP = 1., cB = cB) } ########################################################################### ########################################################################### estcdens.2dim<-function(X1 = NA, X2 = NA, cJ0 = NA, cJ1 = NA, cJM = NA, cT = NA, knots = 5., delta = 0.05, reg = 0., cB = NA) { #####estcdens.2dim if(cJM < 1.) { cJM <- 1. } n <- length(X1) JMAX <- ceiling(cJ0 + cJ1 * logb(n + 3.)) JMM <- floor(cJM * JMAX) bas1 <- cbind(matrix(rep(1., n), ncol = 1.), 2.^(1./2.) * cos(outer( X2, pi * (1.:JMM)))) theta.mat <- matrix(apply(bas1[, 1.:(JMAX + 1.)], 2., mean), nrow = 1.) error <- (2/n - theta.mat^2) %*% Updiag(1. + JMAX) J2 <- order(error)[1.] mat.err <- matrix(c(J2, error[J2]), nrow = 1.) bas <- bas1 for(j in 1.:JMAX) { bas2 <- 2.^(1./2.) * cos(X1 * pi * j) bas <- cbind(bas, bas1 * bas2) theta.mat <- rbind(theta.mat, matrix(apply(bas1[, 1.:(JMAX + 1.)] * bas2, 2., mean), nrow = 1.)) error <- (2/n - theta.mat^2) %*% Updiag(1. + JMAX) error <- apply(error, 2., sum) J2 <- order(error)[1.] mat.err <- rbind(mat.err, matrix(c(J2, error[J2]), nrow = 1.)) } J1 <- order(mat.err[, 2.])[1.] J2 <- mat.err[J1, 1.] if(JMM > JMAX) { for(j in ((1. + JMAX):JMM)) { bas2 <- 2.^(1./2.) * cos(X1 * pi * j) bas <- cbind(bas, bas1 * bas2) } } theta <- apply(bas, 2., mean) theta.mat <- matrix(theta, ncol = (JMM + 1.), nrow = (JMM + 1.), byrow = T) thetasq.mat <- theta.mat^2. - 1./n thetasq.mat[thetasq.mat < 0.] <- 0. subtheta <- theta.mat[1.:J1, 1.:J2] subthetasq <- thetasq.mat[1.:J1, 1.:J2] if(J1 == 1. | J2 == 1.) { subtheta <- matrix(subtheta, nrow = J1, ncol = J2) subthetasq <- matrix(subthetasq, nrow = J1, ncol = J2) } subtheta <- (subtheta * subthetasq)/(subthetasq + 1./n) thetabot <- theta.mat[(J1 + 1.):(JMM + 1.), ] if(J1 == JMM) { thetabot <- matrix(thetabot, nrow = (JMM + 1. - J1), ncol = JMM + 1.) } thetabot[thetabot^2. < (cT * logb(n + 3.))/n] <- 0. thetaright <- theta.mat[1.:J1, (J2 + 1.):(JMM + 1.)] if(J1 == 1. | J2 == JMM) { thetaright <- matrix(thetaright, nrow = J1, ncol = (JMM + 1. - J2)) } thetaright[thetaright^2. < (cT * logb(n + 3.))/n] <- 0. theta.mat <- cbind(subtheta, thetaright) theta.mat <- rbind(theta.mat, thetabot) theta <- matrix(theta.mat, ncol = 1.) if(reg == 0.) { X1 <- seq(0., 1., len = knots) X2 <- X1 n <- knots } bas1 <- cbind(matrix(rep(1., n), ncol = 1.), 2.^(1./2.) * cos(outer( X1, pi * (1.:JMM)))) for(l in 1.:n) { bas <- bas1 for(j in 1.:JMM) { bas <- cbind(bas, bas1 * (2.^(1./2.) * cos(X2[l] * pi * j))) } est <- bas %*% theta if(l == 1.) { den.est <- est } else { den.est <- cbind(den.est, est) } } if(reg == 0.) { den1.est <- den.est flag <- 1. if(all(den.est > 0.)) { flag <- 0. } while(flag == 1.) { den.est <- den.est - delta den.est[den.est < 0.] <- 0. if(mean(apply(den.est, 2., mean)) <= 1.) { flag <- 0. } } AREA <- mean(apply((den.est - den1.est)^2., 2., mean)) den.est <- rembump2d(f = den.est, AREASQ = AREA, coef = cB) den.est <- rembump2d(f = t(den.est), AREASQ = AREA, coef = cB) den.est <- t(den.est) } den.est <- den.est/mean(apply(den.est, 2., mean)) den.est } ########################################################### ########################################################### estcreg.2dim<-function(Y = NA, X1 = NA, X2 = NA, knots = 5., delta = 0.05, posit = 1., cJ0 = NA, cJ1 = NA, cJM = NA, cT = NA, cB = NA, cD = NA) { #######estcreg.2dim n <- length(X1) J <- ceiling(cJ0 + cJ1 * logb(n + 3.)) den.est <- estcden.2dim(X1 = X1, X2 = X2, reg = 1., cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) den.est <- as.vector(den.est) den.est[den.est < cD/logb(n + 3.)] <- cD/logb(n + 3.) bas1 <- cbind(matrix(rep(1., n), ncol = 1.), 2.^(1./2.) * cos(outer( X1, pi * (1.:J)))) * matrix(Y/den.est, nrow = n, ncol = (1. + J), byrow = F) bas <- bas1 for(j in 1.:J) { bas <- cbind(bas, bas1 * (2.^(1./2.) * cos(X2 * pi * j))) } theta <- apply(bas, 2., mean) theta[theta^2. < (cT * var(as.vector(matrix(Y, ncol = 1.))) * logb( n + 3.))/n] <- 0. theta <- matrix(theta, ncol = 1.) X1 <- seq(0., 1., len = knots) X2 <- X1 n <- knots bas1 <- cbind(matrix(rep(1., n), ncol = 1.), 2.^(1./2.) * cos(outer( X1, pi * (1.:J)))) for(l in 1.:n) { bas <- bas1 for(j in 1.:J) { bas <- cbind(bas, bas1 * (2.^(1./2.) * cos(X2[l] * pi * j))) } est <- bas %*% theta if(l == 1.) { reg.est <- est } else { reg.est <- cbind(reg.est, est) } } if(posit == 1.) { flag <- 1. if(all(reg.est >= 0.)) { flag <- 0. } if(flag == 1.) { reg.est <- reg.est - delta reg.est[reg.est < 0.] <- 0. if(mean(apply(reg.est, 2., mean)) <= 1.) { flag <- 0. } } } reg.est } ##################################################################### ##################################################################### estcreg.adbiv<-function(Y = NA, X1 = NA, X2 = NA, k.set = NA, knots = 50., cJ0 = NA, cJ1 = NA, cJM = NA, cT = NA, cB = NA, cD = NA) { #####estcreg.adbiv n <- length(Y) J <- ceiling(cJM * (cJ0 + cJ1 * logb(n + 3.))) z <- seq(0., 1., len = knots) den <- estcden.2dim(X1 = X1, X2 = X2, delta = 0.05, reg = 1., cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) den <- diag(den) den[den < cD/logb(n + 3.)] <- cD/logb(n + 3.) beta <- mean(Y/den) f.mat <- matrix(beta, ncol = 1., nrow = knots) X <- X1 for(k in 1.:2.) { if(k == 2.) { X <- X2 } bas <- 2.^(1./2.) * cos(outer(X, pi * (1.:J))) theta <- (1./n) * matrix(Y/den, nrow = 1., byrow = T) %*% bas theta[theta^2. < (cT * logb(n + 3.) * var(Y))/n] <- 0. arg <- outer(z, pi * (1.:J)) bas <- 2.^(1./2.) * cos(arg) f <- bas %*% t(theta) f.mat <- cbind(f.mat, f) } f.mat } ################################################################## ################################################################## estcreg.admul<-function(Y = NA, X.mat = NA, k.set = NA, knots = 50., cJ0 = NA, cJ1 = NA, cJM = NA, cT = NA) { #####estcreg.admul n <- length(Y) J <- ceiling(cJM * (cJ0 + cJ1 * logb(n + 3.))) z <- seq(0., 1., len = knots) for(k in 1.:length(k.set)) { X <- as.vector(X.mat[, k]) bas <- 2.^(1./2.) * cos(outer(X, pi * (1.:J))) theta <- (1./n) * matrix(Y, nrow = 1., byrow = T) %*% bas theta[theta^2. < (cT * logb(n + 3.) * var(Y))/n] <- 0. arg <- outer(z, pi * (1.:J)) bas <- 2.^(1./2.) * cos(arg) f <- bas %*% t(theta) if(k == 1.) { f.mat <- f } else { f.mat <- cbind(f.mat, f) } } f.mat } ################################################################# ################################################################# estcreg.erpred<-function(Y = NA, X = NA, knots = knots, cb = 8., d0 = 2., d1 = 0.5, d2 = 10., sigma.xi = 0.02, cH = 1.) { ########estcreg.erpred n <- length(Y) b.n <- 1./(cb * logb(logb(n + 20.))) J <- d0 + floor(d1 * (logb(n + 20.))^(1./(d2 * b.n))) h.eps <- exp( - (pi * (1.:J))^2. * (sigma.xi^2./2.)) theta0 <- mean(Y) sigma <- mad(Y - theta0) est <- estcregfc(Y = Y - theta0, X = X, method = 2., JMAX = (J + 1.)) estfc <- est$theta[-1.] estfc[abs(h.eps) < cH * sigma * n^(-1./2. + b.n)] <- 0. fcsq <- estfc^2. - (sigma^2.)/n fcsq[fcsq < 0.] <- 0. estfc <- estfc/h.eps arg <- outer(seq(0., 1., len = knots), pi * (1.:J)) bas <- 2.^(1./2.) * cos(arg) fcw <- (estfc * fcsq)/(fcsq + sigma^2./n) est.reg <- theta0 + bas %*% matrix(fcw, ncol = 1.) est.reg } ################################################################### ################################################################### estcreg.jump<-function(X = NA, Y = NA, cJ0 = 4., cJ1 = 1./2., cT = 4., knots = 100., bbounds = c(0.05, 0.95), bknots = 20., flagX = 0, method = 2) { ########estcreg.jump n <- length(X) JMAX <- ceiling(cJ0 + cJ1 * logb(n + 3.)) sigmasq <- mean((Y[2.:n] - Y[1.:(n - 1.)])^2.) for(j in 0.:JMAX) { fc <- estcregfc.jump(X = X, Y = Y, J = j, bbounds = bbounds, bknots = bknots) errc <- (2. * (j + 2.) * sigmasq)/n - sum(fc^2.) if(j == 0.) { err <- errc } else { err <- c(err, errc) } } J <- order(err)[1.] - 1. est <- estcregfc.jump(X = X, Y = Y, J = J, sigmasq = sigmasq, knots = knots, bbounds = bbounds, bknots = bknots, flag = 1., flagX = flagX) A <- (est$theta[J + 2.]^2. <= sigmasq * n^(-1.) * cT * logb(n)) if(A) { sss <- estcregm(X = X, Y = Y, cJ0 = cJ0, cJ1 = cJ1, cJM = 2., cT = cT, knots = knots, method = method, flagX = flagX) } else { sss <- est$fS } sss } ################################################################### ################################################################### estcregcat<-function(X = NA, Y = NA, a = 0.01, b = 0.995, bound.set = c(-50., -1., 1., 3., 50.), m.bound = 3., fpilot.bound = c(0., 10.), s0 = NA, s1 = NA, cJ0 = NA, cJ1 = NA, cJM = NA, cT = NA, cB = NA, r = NA, method = NA, knots = NA) { ########estcregcat n <- length(X) JMAX <- ceiling(5. + 2. * logb(n + 3.)) m <- length(bound.set) - 1. Y1 <- Y Y1[Y >= m.bound] <- 1. Y1[Y < m.bound] <- 0. est.prob <- estcregm(X = X, Y = Y1, flagX = 1., knots = knots, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, method = method) est.prob <- negden(est.prob, FLAGBUMP = 1., cB = cB) est.prob[est.prob < a] <- a est.prob[est.prob > b] <- b est.pilot <- bound.set[m.bound] - qnorm(1. - est.prob) est.pilot[est.pilot < fpilot.bound[1.]] <- fpilot.bound[1.] est.pilot[est.pilot > fpilot.bound[2.]] <- fpilot.bound[2.] est.prob1 <- estcregm(X = X, Y = Y1, knots = knots, flagX = 0., s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, method = method) est.prob1 <- negden(est.prob1, FLAGBUMP = 1., cB = cB) est.prob1[est.prob1 < a] <- a est.prob1[est.prob1 > b] <- b est.pilot1 <- bound.set[m.bound] - qnorm(1. - est.prob1) est.pilot1[est.pilot1 < fpilot.bound[1.]] <- fpilot.bound[1.] est.pilot1[est.pilot1 > fpilot.bound[2.]] <- fpilot.bound[2.] list(f.pilot1 = est.pilot1, est.prob = est.prob1) } #################################################################### #################################################################### estcregfc<-function(X = NA, Y = NA, method = NA, JMAX = NA, s0 = 0.5, s1 = 0.5, r = 3.) { ######estcregfc n <- length(X) bas <- (2.^(1./2.)) * cos(outer(X, pi * (1.:JMAX))) mat <- matrix(Y, nrow = n, ncol = JMAX, byrow = F) Ybas <- mat * bas fc1 <- apply(Ybas, 2., mean) fc <- c(mean(Y), fc1) X12 <- 1./n if(method == 4.) { s <- ceiling(s0 + s1 * logb(logb(n + 20.))) Z <- cbind(matrix(X, ncol = 1.), matrix(Y, ncol = 1.)) Z <- Z[order(Z[, 1.]), ] X <- Z[, 1.] Y <- Z[, 2.] X1 <- c(rep(0., s), X[1.:(n - s)]) X2 <- c(X[(s + 1.):n], rep(1., s)) X12 <- (X2 - X1)/(2. * s) mmat <- matrix((2.^(1./2.)) * (pi * (1.:JMAX))^(-1.), nrow = n, ncol = JMAX, byrow = T) bas1 <- mmat * sin(outer(X1, pi * (1.:JMAX))) bas2 <- mmat * sin(outer(X2, pi * (1.:JMAX))) mat <- matrix(Y, nrow = n, ncol = JMAX, byrow = F) fc1 <- apply(mat * bas1, 2., sum) fc2 <- apply(mat * bas2, 2., sum) fc <- (fc2 - fc1)/(2. * s) fc0 <- sum((Y * (X2 - X1))/(2. * s)) fc <- c(fc0, fc) } flag <- 0. Jsig <- 0. while(flag == 0.) { if(Jsig == 0.) { fSS <- fc[1.] } else { bas <- 2.^(1./2.) * cos(outer(X, pi * (1.:Jsig))) fSS <- fc[1.] + bas %*% fc[2.:(Jsig + 1.)] } Z <- Y - fSS sigsq <- mean(Z^2.) sigsqM <- (1.48 * median(abs(Z)))^2. Jsig <- Jsig + 1. + 3. * floor(Jsig/4.) + 2. * floor(Jsig/ 3.) if((sigsq < r * sigsqM) | (Jsig >= JMAX)) { flag <- 1. if(method == 4.) { sigsq <- n^2. * mean((Z * X12)^2.) } } } fcsq <- fc^2. - sigsq/n fcsq[fcsq < 0.] <- 0. list(theta = fc[1.:JMAX], thetasq = fcsq[1.:JMAX], sigsq = sigsq, X12 = X12, X = X, Y = Y) } #################################################################### #################################################################### estcregfc.jump<-function(X = NA, Y = NA, J = NA, knots = 30., sigmasq = NA, bbounds = NA, bknots = 20., flag = 0., flagX = 0) { #####estcregfc.jump n <- length(X) b.set <- seq(bbounds[1.], bbounds[2.], length = bknots) for(b in b.set) { phi <- matrix(rep(0., n), ncol = 1.) phi[1.:min(n, max(1., b * n))] <- 1. phi <- phi - b if(J > 0.) { s1 <- (2. * sin(pi * b * (1.:J)))/(pi * (1.:J)) mm <- matrix(s1, nrow = n, ncol = J, byrow = T) mat1 <- cos(outer(X, pi * (1.:J))) phi <- phi - apply(mm * mat1, 1., sum) phi <- phi/(mean(phi^2.))^(1./2.) bas <- cbind(1., sqrt(2.) * mat1, phi) } else { bas <- cbind(1., phi/(mean(phi^2.))^(1./2.)) } bas <- matrix(Y, ncol = J + 2., nrow = n, byrow = F) * bas theta <- apply(bas, 2., mean) sumth <- sum(theta^2.) if(b == b.set[1.]) { sumv <- sumth thetalist <- list(theta) } else { sumv <- c(sumv, sumth) thetalist <- c(thetalist, list(theta)) } } or <- order(sumv)[bknots] b <- b.set[or] theta <- thetalist[[or]] if(flag == 0.) { ll <- theta } else { z <- seq(0., 1., len = knots) if(flagX == 1) { z <- X } phi <- matrix(rep(0., knots), ncol = 1.) phi[1.:min(knots, max(1., b * knots))] <- 1. phi <- phi - b if(J > 0.) { mat <- matrix((2./(pi * (1.:J))) * sin(pi * b * (1.: J)), nrow = knots, ncol = J, byrow = T) mat1 <- cos(outer(z, pi * (1.:J))) phi <- phi - apply(mat * mat1, 1., sum) phi <- phi/(mean(phi^2.))^(1./2.) bas <- cbind(1., sqrt(2.) * mat1, phi) } else { bas <- cbind(1., phi/(mean(phi^2.))^(1./2.)) } thetasq <- theta^2. - sigmasq/n thetasq[thetasq < 0.] <- 0. theta <- (theta * thetasq)/theta^2. bbb <- t(bas) %*% bas fS <- bas %*% matrix(theta, ncol = 1.) ll <- list(b = b, fS = fS, theta = theta) } ll } #################################################################### #################################################################### estcregmed<-function(X = NA, Y = NA, knots = 100., alpha = 0.5, m0 = 2., m1 = 0.3, m2 = 6., s0 = 0.5, s1 = 0.5, cJ0 = 4., cJ1 = 0.5, cJM = 6., cT = 4., r = 2., method = NA, FLAGH = 0., scale = NA, param = NA) { ######estcregmed n <- length(Y) s <- floor(m0 + m2 * abs(alpha - 0.5) + m1 * logb(logb(n + 3.))) matr <- matrix(0., ncol = n, nrow = n) matr[row(matr) >= col(matr) & row(matr) <= col(matr) + 2. * s] <- 1. matr <- matrix(Y, ncol = n, nrow = n, byrow = F) * matr vect <- matr[row(matr) >= col(matr) & row(matr) <= col(matr) + 2. * s] matr <- matrix(vect[1.:((2. * s + 1.) * (n - 2. * s))], ncol = n - 2. * s, nrow = 2. * s + 1., byrow = F) if(FLAGH == 0.) { locmed <- apply(matr, 2., quantile, probs = alpha) } else { almd<-apply(matr,2.,huber) locmed<-matrix(NA,1,(n - 2. * s)) for(i in 1:(n - 2. * s)){ locmed[i]<-almd[[i]]$mu } #####locmed <- apply(matr, 2., location.m, psi.fun = "huber", ####parameter = param) } locmed <- c(rep(locmed[1.], s), locmed[1.:(n - 2. * s)], rep(locmed[ n - 2. * s], s)) estcregm(X = X, Y = locmed, method = method, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, r = r, knots = knots) } ###################################################################### ###################################################################### estcrospden<-function(X = NA, Y = NA, knots = 100., cJ0 = NA, cJ1 = NA, cJM = NA, cT = NA, cB = NA) { ####estcrospden n <- length(X) JMAX <- ceiling(cJ0 + cJ1 * logb(n + 3.)) cJM <- max(c(1., cJM)) JMM <- cJM * JMAX XY <- matrix(c(X, Y), ncol = 2., nrow = n, byrow = F) theta1 <- acf(XY, lag.max = JMM + 1., type = "covariance", plot = F)$ acf[, 1., 2.] theta2 <- acf(XY, lag.max = JMM + 1., type = "covariance", plot = F)$ acf[, 2., 1.] theta2 <- theta2[-1.] aa <- acf(XY, lag.max = JMAX, type = "covariance", plot = F)$acf[, 1., 1.] bb <- acf(XY, lag.max = JMAX, type = "covariance", plot = F)$acf[, 2., 2.] d <- aa[1.] * bb[1.] + sum(aa[-1.] * bb[-1.]) theta11 <- theta1[1.:JMAX] theta11sq <- theta11^2. - d/n theta11sq[theta11sq < 0.] <- 0. error <- matrix(d/n - theta11sq, nrow = 1.) %*% Updiag(JMAX) J1 <- order(error)[1.] theta21 <- theta2[1.:JMAX] theta21sq <- theta21^2. - d/n theta21sq[theta21sq < 0.] <- 0. error <- matrix(d/n - theta21sq, nrow = 1.) %*% Updiag(JMAX) J2 <- order(error)[1.] theta <- c(rev(theta2[1.:J2]), theta1[1.:J1]) thetasq <- theta^2. - d/n thetasq[thetasq < 0.] <- 0. arg <- outer(seq(0., pi, len = knots), ( - J2:(J1 - 1.))) bas1 <- cos(arg)/(2. * pi) bas2 <- sin(arg)/(2. * pi) theta <- (theta * thetasq)/(thetasq + (d/n)) fR <- bas1 %*% theta fIm <- (-1.) * bas2 %*% theta f1 <- estspden(X = X, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) f2 <- estspden(X = Y, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) aaa <- fR^2. + fIm^2. bbb <- f1 * f2 + 1./n^2. aaa[aaa > bbb] <- bbb[aaa > bbb] Koh <- (aaa/bbb)^(1./2.) fR[fR == 0.] <- 1./n phase <- atan(fIm/fR) phase[fR < 0. & fIm > 0.] <- pi + phase[fR < 0. & fIm > 0.] phase[fR < 0. & fIm < 0.] <- - pi + phase[fR < 0. & fIm < 0.] list(Koh = Koh, phase = phase, f1 = f1, f2 = f2, abs = aaa) } ####################################################################### ####################################################################### illp.heat1expb<-function(knots = 50., NN = 30., JMAX = 20., basis = 1., time = 0.05, del.J = 0., J.MAX = 6., J.sigma = 10., sigma = 0.2, coef.MISE = 6., err.max = 1., Jf = 8.) { ########illp.heat1expb noise.sd <- sigma/sqrt(knots) z <- seq(from = 0., to = 1., len = knots) f <- 10. * z * (z - 1.) * (z - 0.3) gh <- illp.heat1fcgh(f = f, NN = NN, JMAX = JMAX, basis = basis, time = time, knots = knots) coef.g <- gh$coef.g mat.h <- gh$mat.h coef.g <- coef.g + rnorm(JMAX) * noise.sd noise.h <- matrix(noise.sd * rnorm(JMAX^2.), ncol = JMAX) mat.h <- mat.h + noise.h mat.h <- (mat.h + t(mat.h))/2. f.estall <- illp.estf(knots = knots, coef.g = coef.g, mat.h = mat.h, del.J = del.J, J.MAX = J.MAX, J.sigma = J.sigma, coef.MISE = coef.MISE, err.max = err.max, basis = basis) f.est <- f.estall$f.est if(basis == 0.) { e.zJf <- cbind(1., 2.^(1./2.) * cos(pi * outer(z, 1.:(Jf - 1.)) )) } else { e.zJf <- 2.^(1./2.) * sin(pi * outer(z, 1.:Jf)) } f.realcoef <- (1./knots) * matrix(f, nrow = 1.) %*% e.zJf par(mfrow = c(2., 4.)) plot(z, f, main = "(a) Initial Temperature", xlab = "Length", ylab = "Temperature", ylim = c(-1., 0.3), type = "l") plot(z, gh$g, main = "(b) Current Temperature", xlab = "Length", ylab = "Temperature", type = "l", ylim = c(-1., 0.3)) plot(z, gh$g + sqrt(knots) * noise.sd * rnorm(knots), main = "(c) Measurements of \n Current Temperature", xlab = "Length", ylab = "Temperature") plot(z, f.est, main = "(d) Estimated \n Initial Temperature", xlab = "Length", ylab = "Temperature", type = "l", ylim = c(-1., 0.3)) for(s in 1.:2.) { f <- 2.^(1./2.) * sin(pi * s * z) gh <- illp.heat1fcgh(f = f, NN = NN, JMAX = JMAX, basis = basis, time = time, knots = knots) if(s == 1.) { plot(z, f, main = "(e) Initial Temperature = e1", xlab = "Length", ylab = "Temperature", type = "l", ylim = c(-1.5, 1.5)) plot(z, gh$g + sqrt(knots) * noise.sd * rnorm(knots), ylim = c(-1.5, 1.5), main = "(f) Measurements of \n Current Temperature", xlab = "Length", ylab = "Temperature") } else { plot(z, f, main = "(g) Initial Temperature = e2", xlab = "Length", ylab = "Temperature", type = "l") plot(z, gh$g + sqrt(knots) * noise.sd * rnorm(knots), ylim = c(-1.5, 1.5), main = "(h) Measurements of \n Current Temperature", xlab = "Length", ylab = "Temperature") } } } ################################################################################### ################################################################################### lenb.estdenc<-function(Y = NA, g = NA, knots = NA, cJ0 = NA, cJ1 = NA, cJM = NA, cT = NA, cB = NA, FLAGX = 0) { #### lenb.estdenc n <- length(Y) JMAX <- ceiling(cJ0 + cJ1 * logb(n + 3.)) JMAX1 <- floor(JMAX * cJM) bas <- (2.^(1./2.)) * cos(outer(Y, pi * (1.:JMAX1))) mat.g <- matrix(g^(-1.), byrow = F, ncol = JMAX1, nrow = length(g)) mu <- 1./mean(g^(-1.)) fc <- mu * apply(bas * mat.g, 2., mean) sigsq <- n^(-1.) * mu^2. * mean(g^(-2.)) fcsq <- fc^2. - sigsq fcsq[fcsq < 0.] <- 0. theta <- fc[1.:JMAX] thetasq <- fcsq[1.:JMAX] error <- matrix(sigsq - thetasq, nrow = 1.) %*% Updiag(JMAX) J <- order(error)[1.] theta <- theta[1.:J] if((J == 1.) & (sigsq - thetasq[1.] >= 0.)) { theta <- 0. } thetasq <- thetasq[1.:J] arg <- outer(seq(0., 1., len = knots), pi * (1.:JMAX1)) if(FLAGX == 1) { arg <- outer(Y, pi * (1.:JMAX1)) } bas <- (2.^(1./2.)) * cos(arg) theta <- (theta * thetasq)/(thetasq + sigsq) if(cJM <= 1.) { if(JMAX > J) { theta <- c(theta, rep(0., JMAX1 - J)) } } else { rest.theta <- fc[(J + 1.):JMAX1] rest.theta[rest.theta^2. < (cT * sigsq * logb(n + 3.))] <- 0. theta <- c(theta, rest.theta) } fS <- 1. + bas %*% theta negden(fS, FLAGBUMP = 1., cB = cB) } #################################################################################### #################################################################################### meser.conv<-function(f = NA, J = 10., sigm = NA) { ###meser.conv n <- length(f) z <- seq(0., 1., len = n) z1 <- outer(z, 2. * pi * (1.:J)) z2 <- cbind(1., sqrt(2.) * cos(z1)) fourc <- matrix(f[2.:(n - 1.)], nrow = 1.) %*% z2[2.:(n - 1.), ] fourc <- fourc + (f[1.] * z2[1., ] + f[n] * z2[n, ])/2. fourc <- fourc/(n - 1.) h.eps <- exp( - (2. * pi * (0.:J))^2. * (sigm^2./2.)) fourc.conv <- fourc * h.eps trapr <- z2 %*% matrix(fourc.conv, ncol = 1.) z2 <- sqrt(2.) * sin(z1) fourc <- matrix(f[2.:(n - 1.)], nrow = 1.) %*% z2[2.:(n - 1.), ] fourc <- fourc + (f[1.] * z2[1., ] + f[n] * z2[n, ])/2. fourc <- fourc/(n - 1.) h.eps <- exp( - (2. * pi * (1.:J))^2. * (sigm^2./2.)) fourc.conv <- fourc * h.eps trapr <- trapr + z2 %*% matrix(fourc.conv, ncol = 1.) list(fcoef = fourc.conv, apr = trapr) } ################################################################################# ################################################################################### meser.estcurd<-function(Y = NA, knots = 100., sigm = NA, cb = NA, d0 = NA, d1 = NA, d2 = NA, cH = NA, cB = 2.) { ####meser.estcurd n <- length(Y) b.n <- 1./(cb * logb(logb(n + 20.))) J <- d0 + ceiling(d1 * (logb(n + 20.))^(1./(d2 * b.n))) h.eps <- exp( - (2. * pi * (1.:J))^2. * (sigm^2./2.)) bas <- (2.^(1./2.)) * cos(outer(Y, 2. * pi * (1.:J))) l <- matrix(rep(1., n), nrow = 1.) fc <- (l/n) %*% bas fcsq <- (n/(n - 1.)) * fc^2. - (l %*% bas^2.)/(n * (n - 1.)) fc[fcsq < rep(1./n, J)] <- 0. fc[abs(h.eps) < rep(cH * n^(-1./2. + b.n), J)] <- 0. bas <- (2.^(1./2.)) * sin(outer(Y, 2. * pi * (1.:J))) l <- matrix(rep(1., n), nrow = 1.) fs <- (l/n) %*% bas fssq <- (n/(n - 1.)) * fc^2. - (l %*% bas^2.)/(n * (n - 1.)) fs[fssq < rep(1./n, J)] <- 0. fs[abs(h.eps) < rep(cH * n^(-1./2. + b.n), J)] <- 0. coefc <- fc/h.eps coefs <- fs/h.eps arg <- outer(seq(0., 1., len = knots), 2. * pi * (1.:J)) bas <- (2.^(1./2.)) * cos(arg) est.den <- 1. + bas %*% t(fc * (fcsq/(fcsq + (1./n)))) bas <- (2.^(1./2.)) * sin(arg) est.den <- est.den + bas %*% t(fs * (fssq/(fssq + (1./n)))) negden(est.den, FLAGBUMP = 1., cB = cB) } ###################################################################################### ################################################################################ patrec.2dim<-function(X1 = NA, X2 = NA, Y1 = NA, Y2 = NA, knots = 20., q = NA, thr = NA, cJ0 = NA, cJ1 = NA, cJM = NA, cT = NA, cB = NA, estimate = NA) { ###patrec.2dim if(estimate == "u") { f1 <- estcdens.2dim(X1 = X1, X2 = X2, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) f2 <- estcdens.2dim(X1 = Y1, X2 = Y2, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) } else { f1 <- estcden.2dim(X1 = X1, X2 = X2, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) f2 <- estcden.2dim(X1 = Y1, X2 = Y2, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB) } p <- matrix(2., ncol = knots, nrow = knots) p[f1 < q * f2] <- 0. n <- min(length(X1), length(Y1)) thrlev <- thr * (logb(n + 3.)/n)^(1./2.) p[f1 < thrlev & f2 < thrlev] <- 1. p } ####################################################################################### ####################################################################################### rembump2d<-function(f = NA, AREASQ = NA, coef = 1.) { ####rembump2d n <- nrow(f) f.mat <- f f.mat[f.mat <= 0.] <- 0. f.mat[f.mat > 0.] <- 1. for(j in 1.:n) { vec <- ab.vec(f.mat[j, ]) if(length(vec) > 2.) { vec <- vec[ - c(1., 2.)] for(s in 1.:(length(vec)/2.)) { a <- vec[2. * s - 1.] b <- vec[2. * s] f1.mat <- matrix(1., nrow = n, ncol = n) f1.mat[j, a:b] <- 0. area <- sum((f[j, a:b])^2.)/(n^2.) if(j == n & (any(f.mat[n, a:b] > 0.))) { f[n, a:b] <- 0. } f.mat[j, a:b] <- 0. k <- j + 1. while(k <= n) { vec1 <- ab.vec(f.mat[k, ]) flag <- 0. if(length(vec1) > 2.) { vec1 <- vec1[ - c(1., 2.)] for(t in 1.:(length(vec1)/ 2.)) { if(vec1[2. * t - 1.] < b & vec1[2. * t] > a) { a <- vec1[ 2. * t - 1.] b <- vec1[ 2. * t] area <- area + sum( (f[ k, a: b])^ 2.)/ (n^ 2.) flag <- 1. f.mat[k, a: b] <- 0. f1.mat[k, a: b] <- 0. } } } if(flag == 0. | k == n) { if(area <= coef * AREASQ) { f <- f * f1.mat } k <- n + 1. } else { k <- k + 1. } } } } } f } ############################################################################## ############################################################################## spden.arma<-function(ar = 0., ma = 0., sigma = 1., knots = 100.) { ####spden.arma z <- seq(from = 0., to = pi, len = knots) zp <- complex(arg = outer(seq(from = 0., to = length(ar), by = 1.), - z)) zq <- complex(arg = outer(seq(from = 0., to = length(ma), by = 1.), - z)) f <- (matrix(c(1., ma), nrow = 1.) %*% zq)/(matrix(c(1., (-1.) * ar), nrow = 1.) %*% zp) f <- (Mod(f))^2. * (sigma^2./(2. * pi)) f } ############################################################################ ############################################################################### surv.estdenc<-function(Y = NA, D = NA, a = 0., b = 1., knots = 300., delJ = 0., cJ0 = 4., cJ1 = 0.5, cJM = 6., cT = 4., cB = 2.) { ####surv.estdenc n <- length(Y) Y <- matrix(Y, ncol = 1.) D <- matrix(D, ncol = 1.) Z <- cbind(Y, D) Z <- Z[order(Z[, 1.]), ] G <- 1. for(i in 2.:n) { G1 <- G[i - 1.] * ((n - i)/(n - i + 1.))^(1. - Z[i, 2.]) G <- c(G, G1) } Z1 <- cbind(Z, matrix(G, ncol = 1.)) Z <- Z1[(Z[, 2.] == 1.), c(1., 3.)] Z <- Z[(Z[, 1.] > a) & (Z[, 1.] < a + b), ] Y.scal <- (Z[, 1.] - a)/b G <- pmax(Z[, 2.], 1./logb(n + 100.)) JMAX <- ceiling(cJ0 + cJ1 * logb(n + 3.)) JMAX1 <- floor(JMAX * cJM) bas <- (2.^(1./2.)) * cos(outer(Y.scal, pi * (1.:JMAX1))) bas <- cbind(1., bas) fc1 <- ((1./n) * (1./G)) %*% bas ### sigma <- sum(G^(-2.))/n sigma <<- sum(G^(-2.))/n fcsq1 <- fc1^2. - sigma/n fcsq1[fcsq1 < 0.] <- 0. error <- matrix((sigma/n) - fcsq1[1.:(JMAX + 1.)], nrow = 1.) %*% Updiag(JMAX + 1.) J <- order(error)[1.] + delJ theta <- fc1[1.:(J + 1.)] thetasq <- fcsq1[1.:(J + 1.)] theta[J + 1.] <- 0. thetasq[J + 1.] <- 0. arg <- outer(seq(from = 0., to = 1., len = knots), pi * (1.:J)) bas <- (1./b) * cbind(1., (2.^(1./2.)) * cos(arg)) JM <- JMAX1 + 1. arg <- outer(seq(from = 0., to = 1., len = knots), pi * (1.:JMAX1)) bas <- (1./b) * cbind(1., (2.^(1./2.)) * cos(arg)) theta <- (fc1 * fcsq1)/(fcsq1 + sigma/n) if(cJM <= 1.) { if(JMAX > J) { theta[(J + 2.):JM] <- 0. } } else { rest.theta <- fc1[(J + 2.):JM] rest.theta[rest.theta^2. < (cT * sigma * logb(n + 3.))/n] <- 0. theta <- c(theta[1.:(J + 1.)], rest.theta) } fS <- bas %*% theta fS <- negden(fS, FLAGBUMP = 1., cB = cB) fS } ############################################################################### ############################################################################### illp.heat1fcgh<-function(f = NA, NN = 30., JMAX = 20., basis = 0., time = 1., knots = 300.) { ### illp.heat1fcgh if(basis == 0.) { bas <- cbind(matrix(1., nrow = knots, ncol = 1.), (2.^(1./ 2.)) * cos(outer(seq(from = 0., to = 1., len = knots), pi * (1.:(JMAX - 1.))))) } else { bas <- (2.^(1./2.)) * sin(outer(seq(from = 0., to = 1., len = knots), pi * (1.:JMAX))) } bassN <- (2.^(1./2.)) * sin(outer(seq(from = 0., to = 1., len = knots), pi * (1.:NN))) for(i in (0.:JMAX)) { if(i >= 1.) { ff <- bas[, i] } else { ff <- f } theta <- illp.heat1fc(f = ff, JMAX = NN, basis = 1.)$fc g <- bassN %*% (matrix(theta, nrow = NN, ncol = 1.) * matrix( exp((-1.) * (pi^2.) * time * (1./2.) * (1.:NN)^2.), nrow = NN, ncol = 1.)) if(i == 0.) { gg <- g } coef.g <- illp.heat1fc(f = g, JMAX = JMAX, basis = basis)$ fc coef.g <- matrix(coef.g, nrow = JMAX, ncol = 1.) if(i == 0.) { mat <- coef.g } else { mat <- cbind(mat, coef.g) } } list(coef.g = mat[, 1.], mat.h = mat[, -1.], g = gg) } ####################################################################################### ####################################################################################### illp.heat1fc<-function(f = NA, basis = 0, JMAX = 20) { # illp.heat1fc in book1fig estimates JMAX Fourier coef # basis = 0 - cosine basis, basis = 1 - sine basis on [0,1] n <- length(f) X <- seq(from = 0, to = 1, len = n) if(basis == 0) { bas <- (2^(1/2)) * cos(outer(X, pi * (1:(JMAX - 1)))) bas <- cbind(matrix(1, nrow = n, ncol = 1), bas) } else { bas <- (2^(1/2)) * sin(outer(X, pi * (1:JMAX))) } fc <- (matrix(f, nrow = 1)/n) %*% bas list(fc = fc) } ####################################################################################### ####################################################################################### illp.estf<-function(knots = 100., coef.g = NA, mat.h = NA, del.J = 0., J.MAX = 5., J.sigma = 10., coef.MISE = 2., err.max = 1., basis = 0.) { #####illp.estf sig.sq <- var(coef.g[(length(coef.g) - J.sigma):length(coef.g)]) err <- 0. l <- 1. theta.mat <- matrix(1., nrow = J.MAX, ncol = 1.) normGS.mat <- 0. while(l <= J.MAX) { mat <- solve(mat.h[1.:l, 1.:l]) eig <- eigen(mat)$values normGS <- sum(eig^2.) normGS.mat <- cbind(normGS.mat, coef.MISE * sig.sq * normGS) theta <- solve(mat.h[1.:l, 1.:l], matrix(coef.g[1.:l], ncol = 1.)) err <- c(err, (coef.MISE * sig.sq * normGS - sum(theta^2.))) ccc <- theta if(l < J.MAX) { ccc <- c(ccc, rep(0., J.MAX - l)) } theta.mat <- cbind(theta.mat, ccc) if((l > 1.) & (normGS.mat[l + 1.] > err.max)) { err <- err[ - (l + 1.)] l <- J.MAX } l <- l + 1. } J.est <- order(err[-1.])[1.] J.est <- J.est + del.J zz <- seq(from = 0., to = 1., len = knots) if(basis == 0.) { if(J.est == 1.) { e.zJ <- matrix(1., nrow = knots, ncol = 1.) } else { e.zJ <- cbind(1., 2.^(1./2.) * cos(pi * outer(zz, 1.: (J.est - 1.)))) } } else { e.zJ <- 2.^(1./2.) * sin(pi * outer(zz, (1.:J.est))) } theta.est <- solve(mat.h[1.:J.est, 1.:J.est], matrix(coef.g[1.:J.est], ncol = 1.)) f.est <- e.zJ %*% matrix(theta.est, ncol = 1.) list(f.est = f.est, theta.est = theta.est, sig.sq = sig.sq, theta.mat = theta.mat[, -1.], normGS = normGS.mat[-1.]) } ################################################################################# ################################################################################ lottery.number<-c(810,156,140,542,507,972,431,981,865,499,20,123,356,15,11,160,507,779,286,268,698,640,136,854,69,199,413,192,602,987,112,245,174,913,828,539,434,357,178,198,406,79,34, 89,257,662,524,809,527,257,8,446,440,781,615,231,580,987,391,267,808,258,479,516,964,742,537,275,112,230,310,335,238,294,854,309,26,960,200,604,841,659,735,105,254,117, 751,781,937,20,348,653,410,468,77,921,314,683,0,963,122,18,827,661,918,110,767,761,305,485,8,808,648,508,684,879,67,282,928,733,518,441,661,219,310,771,906,235,396, 223,695,499,42,230,623,300,380,646,553,182,158,744,894,689,978,314,337,226,106,299,947,896,863,239,180,764,849,87,975,92,701,402,1,884,750,236,395,999,744,714,253,711, 863,496,214,430,107,781,954,941,416,243,480,111,47,691,616,253,477,11,114,133,293,812,197,358,7,996,842,255,374,693,383,99,474,333,467,515,357,694,919,424,274,913,919, 245,964,472,935,434,170,300,476,528,403,677,559,187,652,319,582,541,16,981,158,945,72,167,77,185,209,893,346,515,555,858,434,541,411,109,761,767,597,479) ############################################################################################################################# ############################################################################################################################# rain.nyc1<-c(43.6,37.8,49.2,40.3,45.5,44.2,38.6,40.6,38.7,46,37.1,34.7,35,43,34.4,49.7,33.5,38.3,41.7,51,54.4,43.7,37.6,34.1,46.6,39.3,33.7,40.1,42.4,46.2,36.8,39.4,47,50.3, 55.5,39.5,35.5,39.4,43.8,39.4,39.9,32.7,46.5,44.2,56.1,38.5,43.1,36.7,39.6,36.9,50.8,53.2,37.8,44.7,40.6,41.7,41.4,47.8,56.1,45.6,40.4,39,36.1,43.9,53.5,49.8,33.8,49.8, 53,48.5,38.6,45.1,39,48.5,36.7,45,45,38.4,40.8,46.9,36.2,36.9,44.4,41.5,45.2,35.6,39.9,36.2,36.5) names(rain.nyc1)<-1869:1957; ############################################################################################################################# ############################################################################################################################# chernoff2<-c(320, 105, 57, 50, 1, 1, 1, 60, 20, 250, 210, 370, 280, 150, 40, 50, 1, 1, 1, 60, 40, 210, 130, 420, 260, 165, 33, 50, 1, 1, 1, 60, 10, 250, 90, 440, 305, 110, 44, 40, 1, 1, 1, 50, 50, 260, 140, 250, 290, 160, 35, 35, 1, 1, 1, 50, 20, 210, 60, 510, 275, 130, 47, 35, 1, 1, 1, 50, 20, 230, 90, 570, 280, 155, 35, 35, 1, 1, 1, 80, 20, 270, 170, 400, 300, 115, 50, 60, 1, 1, 1, 120, 10, 280, 190, 300, 250, 130, 41, 30, 5, 1, 1, 70, 30, 250, 110, 330, 285, 120, 47, 40, 1, 1, 1, 70, 10, 240, 170, 280, 280, 105, 47, 70, 1, 1, 1, 60, 20, 370, 70, 300, 300, 135, 50, 40, 1, 1, 1, 120, 60, 250, 160, 200, 280, 110, 56, 50, 1, 1, 1, 150, 10, 280, 270, 280, 305, 80, 65, 80, 5, 1, 1, 130, 10, 300, 260, 260, 230, 175, 29, 35, 1, 1, 1, 270, 30, 250, 140, 240, 325, 60, 52, 90, 1, 1, 1, 160, 10, 280, 260, 170, 270, 170, 25, 40, 1, 1, 1, 160, 10, 290, 70, 330, 250, 185, 31, 25, 1, 1, 1, 120, 1, 260, 80, 330, 260, 185, 30, 15, 1, 1, 1, 270, 80, 480, 10, 330, 270, 185, 32, 10, 5, 1, 1, 180, 40, 450, 20, 220, 325, 45, 53, 5, 20, 1, 1, 600, 80, 660, 20, 250, 315, 90, 47, 5, 20, 1, 1, 410, 200, 600, 60, 260, 335, 100, 47, 10, 40, 1, 1, 360, 80, 590, 110, 170, 310, 10, 49, 5, 80, 18, 1, 640, 240, 630, 60, 190, 410, 1, 49, 1, 75, 32, 1, 760, 440, 800, 1, 1, 360, 1, 48, 1, 80, 55, 1, 770, 260, 770, 10, 10, 310, 15, 51, 1, 105, 36, 1, 660, 380, 640, 1, 10, 420, 5, 49, 1, 95, 56, 1, 620, 520, 680, 1, 1, 415, 20, 49, 5, 25, 36, 1, 370, 220, 340, 1, 1, 420, 5, 41, 1, 70, 60, 1, 630, 510, 580, 1, 1, 450, 5, 40, 1, 90, 70, 1, 690, 570, 630, 1, 1, 395, 1, 25, 15, 100, 71, 1, 580, 530, 560, 1, 10, 380, 10, 27, 25, 35, 39, 1, 350, 320, 400, 1, 270, 430, 10, 25, 30, 30, 25, 1, 340, 340, 360, 1, 200, 410, 75, 22, 10, 5, 15, 1, 170, 170, 170, 1, 60, 520, 55, 24, 40, 5, 1, 1, 210, 190, 190, 1, 180, 385, 135, 18, 10, 5, 8, 1, 140, 200, 260, 1, 20, 535, 65, 10, 20, 1, 1, 1, 110, 230, 270, 1, 70, 550, 95, 1, 10, 1, 1, 1, 50, 230, 270, 1, 30, 510, 100, 1, 1, 1, 1, 1, 190, 150, 230, 1, 110, 510, 95, 1, 40, 1, 1, 1, 140, 100, 150, 1, 40, 385, 180, 10, 1, 1, 1, 1, 50, 50, 300, 1, 50, 505, 125, 1, 1, 1, 1, 1, 1, 200, 130, 1, 30, 470, 90, 1, 20, 1, 1, 1, 160, 300, 380, 1, 60, 465, 110, 1, 35, 1, 1, 1, 260, 440, 500, 1, 60, 400, 140, 1, 15, 1, 23, 1, 330, 400, 390, 1, 40, 415, 105, 15, 25, 40, 32, 1, 220, 190, 270, 1, 10, 435, 75, 10, 15, 1, 69, 1, 370, 360, 500, 1, 10, 370, 145, 10, 10, 5, 12, 40, 130, 80, 330, 1, 30, 380, 210, 1, 1, 1, 1, 20, 70, 1, 50, 1, 30, 430, 65, 1, 5, 20, 1, 75, 130, 70, 300, 1, 20, 420, 80, 30, 1, 5, 26, 1, 50, 100, 350, 1, 50, 425, 60, 35, 5, 1, 1, 30, 100, 10, 340, 1, 10) chernoff2<-matrix(chernoff2,53,12,byrow=T) ######################################################################### ######################################################################### switzerland<-c( 5000, 5000, 5000, 5000, 6000, 5000, 5000, 6000, 8000, 9000, 7000, 7000, 5000, 5000, 5000, 5000, 5000, 4000, 5000, 6000, 7000, 7000, 7000, 7000, 4000, 4000, 4000, 5000, 4000, 7000, 4000, 5000, 7000, 7000, 7000, 6000, 4000, 4000, 5000, 5000, 3000, 9000, 6000, 5000, 6000, 7000, 6000, 7000, 6000, 5000, 4000, 3000, 2000, 7000, 6000, 3000, 6000, 6000, 6000, 6000, 7000, 7000, 5000, 4000, 1000, 1000, 1000, 1000, 6000, 6000, 6000, 6000, 8000, 7000, 4000, 8000, 3000, 5000, 6000, 1000, 6000, 7000, 8000, 9000, 7000, 7000, 5000, 4000, 5000, 7000, 7000, 1000, 5000, 5000, 5000, 5000, 7000, 6000, 4000, 4000, 5000, 8000, 7000, 1000, 6000, 7000, 8000, 9000, 7000, 6000, 4000, 4000, 8000, 6000, 7000, 1000, 6000, 7000, 7000, 7000, 6000, 6000, 6000, 6000, 7000, 6000, 7000, 5000, 6000, 7000, 6000, 9000, 6000, 6000, 6000, 7000, 8000, 7000, 7000, 5000, 5000, 6000, 6000, 7000) switzerland<-matrix(switzerland,12,12,byrow=T) ############################################################################################################################# ############################################################################################################################ auto.stats<-c( 4099, 22, 3, 2, 2.5, 27.5, 11, 2930, 186, 40, 121, 3.58, 4749, 17, 3, 1, 3.0, 25.5, 11, 3350, 173, 40, 258, 2.53, 3799, 22, NA, NA, 3.0, 18.5, 12, 2640, 168, 35, 121, 3.08, 9690, 17, 5, 2, 3.0, 27.0, 15, 2830, 189, 37, 131, 3.20, 6295, 23, 3, 3, 2.5, 28.0, 11, 2070, 174, 36, 97, 3.70, 9735, 25, 4, 4, 2.5, 26.0, 12, 2650, 177, 34, 121, 3.64, 4816, 20, 3, 3, 4.5, 29.0, 16, 3250, 196, 40, 196, 2.93, 7827, 15, 4, 4, 4.0, 31.5, 20, 4080, 222, 43, 350, 2.41, 5788, 18, 3, 4, 4.0, 30.5, 21, 3670, 218, 43, 231, 2.73, 4453, 26, NA, NA, 3.0, 24.0, 10, 2230, 170, 34, 111, 2.87, 5189, 20, 3, 3, 2.0, 28.5, 16, 3280, 200, 42, 196, 2.93, 10372, 16, 3, 4, 3.5, 30.0, 17, 3880, 207, 43, 231, 2.93, 4082, 19, 3, 3, 3.5, 27.0, 13, 3400, 200, 42, 231, 3.08, 11385, 14, 3, 3, 4.0, 31.5, 20, 4330, 221, 44, 425, 2.28, 14500, 14, 2, 2, 3.5, 30.0, 16, 3900, 204, 43, 350, 2.19, 15906, 21, 3, 3, 3.0, 30.0, 13, 4290, 204, 45, 350, 2.24, 3299, 29, 3, 3, 2.5, 26.0, 9, 2110, 163, 34, 98, 2.93, 5705, 16, 4, 4, 4.0, 29.5, 20, 3690, 212, 43, 250, 2.56, 4504, 22, 3, 3, 3.5, 28.5, 17, 3180, 193, 41, 200, 2.73, 5104, 22, 2, 3, 2.0, 28.5, 16, 3220, 200, 41, 200, 2.73, 3667, 24, 2, 2, 2.0, 25.0, 7, 2750, 179, 40, 151, 2.73, 3955, 19, 3, 3, 3.5, 27.0, 13, 3430, 197, 43, 250, 2.56, 6229, 23, 4, 3, 1.5, 21.0, 6, 2370, 170, 35, 119, 3.89, 4589, 35, 5, 5, 2.0, 23.5, 8, 2020, 165, 32, 85, 3.70, 5079, 24, 4, 4, 2.5, 22.0, 8, 2280, 170, 34, 119, 3.54, 8129, 21, 4, 4, 2.5, 27.0, 8, 2750, 184, 38, 146, 3.55, 3984, 30, 5, 4, 2.0, 24.0, 8, 2120, 163, 35, 98, 3.54, 5010, 18, 2, 2, 4.0, 29.0, 17, 3600, 206, 46, 318, 2.47, 5886, 16, 2, 2, 3.5, 26.0, 16, 3870, 216, 48, 318, 2.71, 6342, 17, 2, 2, 4.5, 28.0, 21, 3740, 220, 46, 225, 2.94, 4296, 21, 3, 1, 2.5, 26.5, 16, 2130, 161, 36, 105, 3.37, 4389, 28, 4, NA, 1.5, 26.0, 9, 1800, 147, 33, 98, 3.15, 4187, 21, 3, 3, 2.0, 23.0, 10, 2650, 179, 42, 140, 3.08, 5799, 25, 5, 5, 3.0, 25.5, 10, 2240, 172, 36, 107, 3.05, 4499, 28, 4, 4, 2.5, 23.5, 5, 1760, 149, 34, 91, 3.30, 11497, 12, 3, 4, 3.5, 30.5, 22, 4840, 233, 51, 400, 2.47, 13594, 12, 3, 4, 2.5, 28.5, 18, 4720, 230, 48, 400, 2.47, 13466, 14, 3, 3, 3.5, 27.0, 15, 3830, 201, 41, 302, 2.47, 3995, 30, 4, 4, 3.5, 25.5, 11, 1980, 154, 33, 86, 3.73, 3829, 22, 4, 3, 3.0, 25.5, 9, 2580, 169, 39, 140, 2.73, 5379, 14, 4, 3, 3.5, 29.5, 16, 4060, 221, 48, 302, 2.75, 6303, 14, 4, 4, 3.0, 25.0, 16, 4130, 217, 45, 302, 2.75, 6165, 15, 3, 2, 3.5, 30.5, 23, 3720, 212, 44, 302, 2.26, 4516, 18, 3, NA, 3.0, 27.0, 15, 3370, 198, 41, 250, 2.43, 3291, 20, 3, 3, 3.5, 29.0, 17, 2830, 195, 43, 140, 3.08, 8814, 21, 4, 4, 4.0, 31.5, 20, 4060, 220, 43, 350, 2.41, 4733, 19, 3, 3, 4.5, 28.0, 16, 3300, 198, 42, 231, 2.93, 5172, 19, 3, 4, 2.0, 28.0, 16, 3310, 198, 42, 231, 2.93, 5890, 18, 4, 4, 4.0, 29.0, 20, 3690, 218, 42, 231, 2.73, 4181, 19, 3, 3, 4.5, 27.0, 14, 3370, 200, 43, 231, 3.08, 4195, 24, 1, 1, 2.0, 25.5, 10, 2720, 180, 40, 151, 2.73, 10371, 16, 3, 3, 3.5, 30.0, 17, 4030, 206, 43, 350, 2.41, 12990, 14, NA, NA, 3.5, 30.5, 14, 3420, 192, 38, 163, 3.58, 4647, 28, 3, 3, 2.0, 21.5, 11, 2360, 170, 37, 156, 3.05, 4425, 34, 5, 4, 2.5, 23.0, 11, 1800, 157, 37, 86, 2.97, 4482, 25, 3, NA, 4.0, 25.0, 17, 2200, 165, 36, 105, 3.37, 6486, 26, NA, NA, 1.5, 22.0, 8, 2520, 182, 38, 119, 3.54, 4060, 18, 2, 2, 5.0, 31.0, 16, 3330, 201, 44, 225, 3.23, 5798, 18, 4, 4, 4.0, 29.0, 20, 3700, 214, 42, 231, 2.73, 4934, 18, 1, 2, 1.5, 23.5, 7, 3470, 198, 42, 231, 3.08, 5222, 19, 3, 3, 2.0, 28.5, 16, 3210, 201, 45, 231, 2.93, 4723, 19, 3, 3, 3.5, 28.0, 17, 3200, 199, 40, 231, 2.93, 4424, 19, NA, NA, 3.5, 27.0, 13, 3420, 203, 43, 231, 3.08, 4172, 24, 2, 2, 2.0, 25.0, 7, 2690, 179, 41, 151, 2.73, 3895, 26, 3, 3, 3.0, 23.0, 10, 1830, 142, 34, 79, 3.72, 3798, 35, 5, 4, 2.5, 25.5, 11, 2050, 164, 36, 97, 3.81, 5899, 18, 5, 5, 2.5, 22.0, 14, 2410, 174, 36, 134, 3.06, 3748, 31, 5, 5, 3.0, 24.5, 9, 2200, 165, 35, 97, 3.21, 5719, 18, 5, 5, 2.0, 23.0, 11, 2670, 175, 36, 134, 3.05, 4697, 25, 4, 3, 3.0, 25.5, 15, 1930, 155, 35, 89, 3.78, 5397, 41, 5, 4, 3.0, 25.5, 15, 2040, 155, 35, 90, 3.78, 6850, 25, 4, 3, 2.0, 23.5, 16, 1990, 156, 36, 97, 3.78, 7140, 23, 4, 3, 2.5, 37.5, 12, 2160, 172, 36, 97, 3.74, 11995, 17, 5, 3, 2.5, 29.5, 14, 3170, 193, 37, 163, 2.98) auto.stats<-matrix(auto.stats,74,12,byrow=T) colnames(auto.stats)<-c("Price", "Miles per gallon", "Repair (1978)", "Repair (1977)", "Headroom", "Rear Seat", "Trunk", "Weight", "Length", "Turning Circle", "Displacement", "Gear Ratio") ############################################################################################################################# ############################################################################################################################# hstart<-c(81.9, 79.0, 122.4, 143.0, 133.9, 123.5, 100.0, 103.7, 91.9, 79.1, 75.1, 62.3, 61.7, 63.2, 92.9, 115.9, 134.2, 131.6, 126.1, 130.2, 125.8, 137.0, 120.2, 83.1, 82.7, 87.2, 128.6, 164.9, 144.5, 142.5, 142.3, 141.0, 139.5, 143.3, 129.5, 99.3, 105.8, 94.6, 135.6, 159.9, 157.7, 150.5, 126.5, 127.5, 132.9, 125.8, 97.4, 85.3, 69.2, 77.2, 117.8, 130.6, 127.3, 141.9, 143.5, 131.5, 133.8, 143.8, 128.3, 124.1, 114.8, 104.6, 169.3, 203.6, 203.5, 196.8, 197.0, 205.9, 175.6, 181.7, 176.4, 155.3, 150.9, 153.6, 205.8, 213.2, 227.9, 226.2, 207.5, 231.0, 204.4, 218.2, 187.1, 152.7, 147.3, 139.5, 201.1, 205.4, 234.2, 203.4, 203.2, 199.9, 148.9, 149.5, 134.6, 90.6, 86.2, 109.6, 127.2, 160.9, 149.9, 149.5, 127.2, 114.0, 99.6, 97.2, 75.1, 54.9) ###hstart<-matrix(hstart,9,12,byrow=T) ###colnames(hstart)<-c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec") ############################################################################################################################# ############################################################################################################################# saving.x<-LifeCycleSavings ############################################################################################################################# ############################################################################################################################# wt.filter<-function (filter = "la8", modwt = FALSE, level = 1) { if (is.na(match(class(filter), c("numeric", "character", "integer")))) stop("Invalid argument: 'filter' must be of class 'character', 'numeric', or 'integer'") if ((class(filter) == "numeric") | (class(filter) == "integer")) { if (round(length(filter)/2) != length(filter)/2) stop("Invalid argument: filter length must be even.") if (modwt) transform <- "modwt" else transform <- "dwt" wt.filter <- new("wt.filter", L = length(filter), h = filter, g = wt.filter.qmf(filter), wt.class = "none", wt.name = "none", transform = transform) } else { haar.filter <- function(mod = F) { class <- "Daubechies" name <- "haar" L <- as.integer(2) g <- c(0.707106781186547, 0.707106781186547) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } d4.filter <- function(mod = F) { class <- "Daubechies" name <- "d4" L <- as.integer(4) g <- c(0.482962913144534, 0.836516303737808, 0.224143868042013, -0.129409522551260) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } d6.filter <- function(mod = F) { class <- "Daubechies" name <- "d6" L <- as.integer(6) g <- c(0.332670552950083, 0.806891509311093, 0.459877502118491, -0.135011020010255, -0.0854412738820267, 0.0352262918857096) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } d8.filter <- function(mod = F) { class <- "Daubechies" name <- "d8" L <- as.integer(8) g <- c(0.230377813307443, 0.714846570548406, 0.630880767935879, -0.0279837694166834, -0.187034811717913, 0.0308413818353661, 0.0328830116666778, -0.0105974017850021) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } d10.filter <- function(mod = F) { class <- "Daubechies" name <- "d10" L <- as.integer(10) g <- c(0.160102397974193, 0.60382926979719, 0.724308528437773, 0.138428145901320, -0.242294887066382, -0.0322448695846381, 0.0775714938400459, -0.0062414902127983, -0.012580751999082, 0.0033357252854738) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } d12.filter <- function(mod = F) { class <- "Daubechies" name <- "d12" L <- as.integer(12) g <- c(0.111540743350109, 0.494623890398453, 0.751133908021095, 0.315250351709198, -0.22626469396544, -0.129766867567262, 0.0975016055873224, 0.0275228655303053, -0.0315820393174862, 0.0005538422011614, 0.0047772575109455, -0.0010773010853085) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } d14.filter <- function(mod = F) { class <- "Daubechies" name <- "d14" L <- as.integer(14) g <- c(0.0778520540850081, 0.396539319481914, 0.729132090846237, 0.469782287405215, -0.143906003928529, -0.224036184993854, 0.0713092192668312, 0.080612609151082, -0.0380299369350125, -0.0165745416306664, 0.0125509985560993, 0.0004295779729214, -0.0018016407040474, 0.0003537137999745) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } d16.filter <- function(mod = F) { class <- "Daubechies" name <- "d16" L <- as.integer(16) g <- c(0.0544158422431049, 0.312871590914303, 0.67563073629729, 0.585354683654191, -0.0158291052563816, -0.284015542961570, 0.0004724845739124, 0.128747426620484, -0.0173693010018083, -0.0440882539307952, 0.0139810279173995, 0.0087460940474061, -0.0048703529934518, -0.000391740373377, 0.0006754494064506, -0.0001174767841248) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } d18.filter <- function(mod = F) { class <- "Daubechies" name <- "d18" L <- as.integer(18) g <- c(0.0380779473638791, 0.243834674612594, 0.604823123690116, 0.657288078051296, 0.133197385824993, -0.293273783279176, -0.0968407832229524, 0.148540749338131, 0.0307256814793395, -0.0676328290613302, 0.000250947114834, 0.0223616621236805, -0.004723204757752, -0.0042815036824636, 0.0018476468830564, 0.0002303857635232, -0.0002519631889427, 3.93473203163e-05) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } d20.filter <- function(mod = F) { class <- "Daubechies" name <- "d20" L <- as.integer(20) g <- c(0.0266700579005546, 0.188176800077686, 0.52720118893172, 0.688459039453625, 0.281172343660649, -0.249846424327228, -0.19594627437734, 0.127369340335789, 0.0930573646035802, -0.0713941471663697, -0.029457536821848, 0.0332126740593703, 0.003606553566988, -0.0107331754833036, 0.0013953517470692, 0.001992405295193, -0.0006858566949566, -0.0001164668551285, 9.35886703202e-05, -1.32642028945e-05) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } la8.filter <- function(mod = F) { class <- "Least Asymmetric" name <- "la8" L <- as.integer(8) g <- c(-0.0757657147893407, -0.0296355276459541, 0.497618667632458, 0.803738751805216, 0.297857795605542, -0.0992195435769354, -0.0126039672622612, 0.0322231006040713) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } la10.filter <- function(mod = F) { class <- "Least Asymmetric" name <- "la10" L <- as.integer(10) g <- c(0.0195388827353869, -0.0211018340249298, -0.175328089908107, 0.0166021057644243, 0.633978963456949, 0.723407690403808, 0.199397533976996, -0.0391342493025834, 0.0295194909260734, 0.0273330683451645) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } la12.filter <- function(mod = F) { class <- "Least Asymmetric" name <- "la12" L <- as.integer(12) g <- c(0.0154041093273377, 0.0034907120843304, -0.117990111148411, -0.0483117425859981, 0.49105594192764, 0.787641141028794, 0.33792942172824, -0.0726375227866, -0.0210602925126954, 0.0447249017707482, 0.0017677118643983, -0.007800708324765) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } la14.filter <- function(mod = F) { class <- "Least Asymmetric" name <- "la14" L <- as.integer(14) g <- c(0.0102681767084968, 0.0040102448717033, -0.107808237703617, -0.140047240442703, 0.288629631750983, 0.767764317004571, 0.536101917090772, 0.0174412550871099, -0.049552834937041, 0.0678926935015971, 0.0305155131659062, -0.0126363034031526, -0.0010473848889657, 0.0026818145681164) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } la16.filter <- function(mod = F) { class <- "Least Asymmetric" name <- "la16" L <- as.integer(16) g <- c(-0.0033824159513594, -0.0005421323316355, 0.0316950878103452, 0.0076074873252848, -0.143294238351054, -0.0612733590679088, 0.481359651259201, 0.777185751699748, 0.364441894835956, -0.0519458381078751, -0.0272190299168137, 0.0491371796734768, 0.0038087520140601, -0.0149522583367926, -0.0003029205145516, 0.0018899503329007) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } la18.filter <- function(mod = F) { class <- "Least Asymmetric" name <- "la18" L <- as.integer(18) g <- c(0.0010694900326538, -0.0004731544985879, -0.0102640640276849, 0.0088592674935117, 0.0620777893027638, -0.0182337707798257, -0.191550831296487, 0.0352724880359345, 0.617338449141352, 0.717897082764226, 0.238760914607418, -0.0545689584305765, 0.0005834627463312, 0.0302248788579895, -0.0115282102079848, -0.0132719677815332, 0.0006197808890549, 0.0014009155255716) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } la20.filter <- function(mod = F) { class <- "Least Asymmetric" name <- "la20" L <- as.integer(20) g <- c(0.000770159809103, 9.56326707837e-05, -0.0086412992759401, -0.0014653825833465, 0.0459272392237649, 0.0116098939129724, -0.159494278857531, -0.0708805358108615, 0.471690666842659, 0.769510037014339, 0.383826761225382, -0.0355367403054689, -0.0319900568281631, 0.049994972079156, 0.0057649120455518, -0.020354939803946, -0.000804358934537, 0.0045931735836703, 5.7036084339e-05, -0.0004593294205481) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } bl14.filter <- function(mod = F) { class <- "Best Localized" name <- "bl14" L <- as.integer(14) g <- c(0.0120154192834842, 0.0172133762994439, -0.0649080035533744, -0.064131289818917, 0.360218460898555, 0.781921593296555, 0.483610915693782, -0.0568044768822707, -0.101010920866413, 0.0447423494687405, 0.0204642075778225, -0.0181266051311065, -0.0032832978473081, 0.0022918339541009) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } bl18.filter <- function(mod = F) { class <- "Best Localized" name <- "bl18" L <- as.integer(18) g <- c(0.0002594576266544, -0.0006273974067728, -0.0019161070047557, 0.0059845525181721, 0.0040676562965785, -0.0295361433733604, -0.0002189514157348, 0.0856124017265279, -0.0211480310688774, -0.143292975939652, 0.233778290022498, 0.737470761993369, 0.592655137443396, 0.0805670008868546, -0.114334306961931, -0.0348460237698368, 0.0139636362487191, 0.0057746045512475) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } bl20.filter <- function(mod = F) { class <- "Best Localized" name <- "bl20" L <- as.integer(20) g <- c(0.0008625782242896, 0.0007154205305517, -0.0070567640909701, 0.0005956827305406, 0.0496861265075979, 0.0262403647054251, -0.121552106157816, -0.0150192395413644, 0.513709872833405, 0.766954836501085, 0.340216013511079, -0.0878787107378667, -0.0670899071680668, 0.0338423550064691, -0.0008687519578684, -0.0230054612862905, -0.0011404297773324, 0.0050716491945793, 0.0003401492622332, -0.0004101159165852) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } c6.filter <- function(mod = F) { class <- "Coiflet" name <- "c6" L <- as.integer(6) g <- c(-0.0156557285289848, -0.0727326213410511, 0.384864856538113, 0.85257204164239, 0.337897670951159, -0.0727322757411889) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } c12.filter <- function(mod = F) { class <- "Coiflet" name <- "c12" L <- as.integer(12) g <- c(-0.0007205494453679, -0.0018232088707116, 0.0056114348194211, 0.0236801719464464, -0.0594344186467388, -0.0764885990786692, 0.417005184423671, 0.812723635449398, 0.386110066822994, -0.0673725547222826, -0.0414649367819558, 0.0163873364635998) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } c18.filter <- function(mod = F) { class <- "Coiflet" name <- "c18" L <- as.integer(18) g <- c(-3.45997728362e-05, -7.09833031381e-05, 0.0004662169601129, 0.0011175187708906, -0.0025745176887502, -0.0090079761366615, 0.0158805448636158, 0.0345550275730615, -0.0823019271068856, -0.0717998216193117, 0.428483476377617, 0.793777222625617, 0.405176902409615, -0.0611233900026726, -0.0657719112818552, 0.0234526961418362, 0.0077825964273254, -0.003793512864491) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } c24.filter <- function(mod = F) { class <- "Coiflet" name <- "c24" L <- as.integer(24) g <- c(-1.7849850031e-06, -3.2596802369e-06, 3.12298758654e-05, 6.2339034461e-05, -0.0002599745524878, -0.0005890207562444, 0.0012665619292991, 0.003751436157279, -0.0056582866866115, -0.0152117315279485, 0.0250822618448678, 0.0393344271233433, -0.096220442034002, -0.0666274742634348, 0.434386056491532, 0.782238930920613, 0.415308407030491, -0.056077313316763, -0.0812666996808907, 0.026682300156057, 0.0160689439647787, -0.0073461663276432, -0.001629492012602, 0.0008923136685824) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } c30.filter <- function(mod = F) { class <- "Coiflet" name <- "c30" L <- as.integer(30) g <- c(-9.51765727e-08, -1.674428858e-07, 2.0637618516e-06, 3.7346551755e-06, -2.13150268122e-05, -4.13404322768e-05, 0.0001405411497166, 0.0003022595818445, -0.0006381313431115, -0.001662863702186, 0.0024333732129107, 0.0067641854487565, -0.0091642311634348, -0.0197617789446276, 0.0326835742705106, 0.0412892087544753, -0.105574208714317, -0.0620359639693546, 0.437991626217383, 0.774289603733474, 0.42156620673469, -0.0520431631816557, -0.0919200105692549, 0.0281680289738655, 0.0234081567882734, -0.0101311175209033, -0.0041593587818186, 0.0021782363583355, 0.000358589687933, -0.0002120808398259) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } s4.filter <- function(mod = F) { class <- "Symmlet" name <- "s4" L <- as.integer(8) g <- c(-.107148901418, -.041910965125, .703739068656, 1.136658243408, .421234534204, -.140317624179, -.017824701442, .045570345896) g<-g/sqrt(sum(g^2)) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } s5.filter <- function(mod = F) { class <- "Symmlet" name <- "s5" L <- as.integer(10) g <- c(.038654795955, .041746864422, -.055344186117, .281990696854, 1.023052966894, .896581648380, .023478923136, -.247951362613, -.029842499869, .027632152958) g<-g/sqrt(sum(g^2)) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } s6.filter <- function(mod = F) { class <- "Symmlet" name <- "s6" L <- as.integer(12) g <- c(.021784700327, .004936612372, -.166863215412, -.068323121587, .694457972958, 1.113892783926, .477904371333, -.102724969862, -.029783751299, .063250562660, .002499922093, -.011031867509) g<-g/sqrt(sum(g^2)) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } s7.filter <- function(mod = F) { class <- "Symmlet" name <- "s7" L <- as.integer(14) g <- c(.003792658534, -.001481225915, -.017870431651, .043155452582, .096014767936, -.070078291222, .024665659489, .758162601964, 1.085782709814, .408183939725, -.198056706807, -.152463871896, .005671342686, .014521394762) g<-g/sqrt(sum(g^2)) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } s8.filter <- function(mod = F) { class <- "Symmlet" name <- "s8" L <- as.integer(16) g <- c(.002672793393, -.000428394300, -.021145686528, .005386388754, .069490465911, -.038493521263, -.073462508761, .515398670374, 1.099106630537, .680745347190, -.086653615406, -.202648655286, .010758611751, .044823623042, -.000766690896, -.004783458512) g<-g/sqrt(sum(g^2)) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } s9.filter <- function(mod = F) { class <- "Symmlet" name <- "s9" L <- as.integer(18) g <- c(.001512487309, -.000669141509, -.014515578553, .012528896242, .087791251554, -.025786445930, -.270893783503, .049882830959, .873048407349, 1.015259790832, .337658923602, -.077172161097, .000825140929, .042744433602, -.016303351226, -.018769396836, .000876502539, .001981193736) g<-g/sqrt(sum(g^2)) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } s10.filter <- function(mod = F) { class <- "Symmlet" name <- "s10" L <- as.integer(20) g <- c(.001089170447, .000135245020, -.012220642630, -.002072363923, .064950924579, .016418869426, -.225558972234, -.100240215031, .667071338154, 1.088251530500, .542813011213, -.050256540092, -.045240772218, .070703567550, .008152816799, -.028786231926, -.001137535314, .006495728375, .000080661204, -.000649589896) g<-g/sqrt(sum(g^2)) if (modwt == TRUE) { g <- g/sqrt(2) transform <- "modwt" } else transform <- "dwt" h <- wt.filter.qmf(g, inverse = TRUE) wt.filter <- new("wt.filter", L = L, h = h, g = g, wt.class = class, wt.name = name, transform = transform) return(wt.filter) } wt.filter <- switch(filter, haar = haar.filter(), d4 = d4.filter(), d6 = d6.filter(), d8 = d8.filter(), d10 = d10.filter(), d12 = d12.filter(), d14 = d14.filter(), d16 = d16.filter(), d18 = d18.filter(), d20 = d20.filter(), la8 = la8.filter(), la10 = la10.filter(), la12 = la12.filter(), la14 = la14.filter(), la16 = la16.filter(), la18 = la18.filter(), la20 = la20.filter(), bl14 = bl14.filter(), bl18 = bl18.filter(), bl20 = bl20.filter(), c6 = c6.filter(), c12 = c12.filter(), c18 = c18.filter(), c24 = c24.filter(), c30 = c30.filter(), s4 = s4.filter(), s5 = s5.filter(), s6 = s6.filter(), s7 = s7.filter(), s8 = s8.filter(), s9 = s9.filter(), s10 = s10.filter()) } if (is.null(wt.filter)) stop("Invalid filter name.") else { if (level > 1) wt.filter <- wt.filter.equivalent(wt.filter, J = level) else wt.filter@level <- as.integer(1) return(wt.filter) } } ##################################################### #################################################### wdenr<-function(wc=NA,J=6,thresh='s',den='visu') { #### 'h' or soft wavelet thresholding for R named <- c("W1", "W2", "W3", "W4", "W5", "W6", "W7", "W8", "W9","W10") sigmae<-mad(wc@W[["W1"]]) if(den=='visu'){ if (thresh=='h'){ for(i in 1:J){ nd=length(wc@W[[named[i]]]) th=sigmae*sqrt(2*log(nd)) wc@W[[named[i]]][abs(wc@W[[named[i]]])<=th]<-0 } } if(thresh=='s'){ for(i in 1:J){ nd=length(wc@W[[named[i]]]) th=sqrt(2*log(nd)) wci=wc@W[[named[i]]]/sigmae rs=(abs(wci)-th); rs=(rs+abs(rs))/2 wc@W[[named[i]]]<-sigmae*(sign(wci)*rs) } } } if (den=='sure'){ if (thresh=='h'){ for (i in 1:J){ x=wc@W[[named[i]]]/sigmae a=sort(abs(x))^2 ; b=cumsum(a); nd=length(x); c=seq(nd-1,0,n=nd); s=b+(c*a); risk= (nd - ( 2 * (1:nd )) + s)/nd; o=order(risk); th=sqrt(a[o[1]]) wc@W[[named[i]]][abs(wc@W[[named[i]]]/sigmae)<=th]<-0 } } if (thresh=='s'){ for (i in 1:J){ x=wc@W[[named[i]]]/sigmae a=sort(abs(x))^2 ; b=cumsum(a); nd=length(x); c=seq(nd-1,0,n=nd); s=b+(c*a); risk= (nd - ( 2 * (1:nd )) + s)/nd; o=order(risk); th=sqrt(a[o[1]]) wci=wc@W[[named[i]]]/sigmae rs=(abs(wci)-th); rs=(rs+abs(rs))/2 wc@W[[named[i]]]<-sigmae*(sign(wci)*rs) } } } if (den=='hs'){ if (thresh=='h'){ for (i in 1:J){ x=wc@W[[named[i]]]/sigmae nd=length(x); Jd=log2(nd) magic=sqrt(2*log(nd)); eta= (sum(x^2) - nd)/nd; crit = Jd^(1.5)/sqrt(nd); if (eta < crit){ wc@W[[named[i]]][abs(wc@W[[named[i]]]/sigmae)<=magic]<-0 } else { a=sort(abs(x))^2 ; b=cumsum(a); c=seq(nd-1,0,n=nd); s=b+(c*a); risk= (nd - ( 2 * (1:nd )) + s)/nd; o=order(risk); th=sqrt(a[o[1]]) T=min(th, magic); wc@W[[named[i]]][abs(wc@W[[named[i]]]/sigmae)<=T]<-0 } } } if (thresh=='s'){ for (i in 1:J){ x=wc@W[[named[i]]]/sigmae nd=length(x); Jd=log2(nd) magic=sqrt(2*log(nd)); eta= (sum(x^2) - nd)/nd; crit = Jd^(1.5)/sqrt(nd); if (eta < crit){ wci=wc@W[[named[i]]]/sigmae rs=(abs(wci)-magic); rs=(rs+abs(rs))/2 wc@W[[named[i]]]<-sigmae*(sign(wci)*rs) } else { a=sort(abs(x))^2 ; b=cumsum(a); nd=length(x); c=seq(nd-1,0,n=nd); s=b+(c*a); risk= (nd - ( 2 * (1:nd )) + s)/nd; o=order(risk); th=sqrt(a[o[1]]) T=min(th, magic); wci=wc@W[[named[i]]]/sigmae rs=(abs(wci)-T); rs=(rs+abs(rs))/2 wc@W[[named[i]]]<-sigmae*(sign(wci)*rs) } } } } wcd<-wc } ################################################################################################## ################################################################################################## plot.wav<-function (x, xlabels,wds=6, main = "Wavelet Decomposition Coefficients", sub = x@filter@wt.name, xlab = "Translate", ylab = "Resolution Level", scaling = "global", rhlab = FALSE, col = par("fg"), lty = par("lty"), lwd = par("lwd"),...) { ctmp <- class(x) if (is.null(ctmp) || all(ctmp != "dwt")) stop("argument `x' is not of class \"dwt\"") named<-c("W1", "W2", "W3", "W4", "W5", "W6", "W7", "W8", "W9" , "W10") det<-c("d1","d2","d3","d4","d5","d6","d7","d8","d9","d10") scal<-c("s1","s2","s3","s4","s5","s6","s7","s8","s9","s10") J=log2(length(x@series)) first.level<-J-wds levels <- J nlevels <- levels - first.level n <- 2^(levels) plot(c(0, 0, n, n), c(0, nlevels + 3, nlevels + 3, 0), type = "n", xlab = xlab, ylab = ylab, main = main, yaxt = "n", xaxt = "n", sub = sub, ...) i.lev <- (levels - 1):first.level lab=det[1:nlevels] lab=c("idwt",lab,scal[wds]) atlab=1:(nlevels+2) atlab[1]=.5 axis(2, at = atlab, labels =rev(lab) ) if (missing(xlabels)) { axx <- 2^(levels) axx <- axx * 0:1 axis(1, at = axx,lab=c(0,1)) } else { axx <- pretty(1:n, n = 3) if (axx[length(axx)] > n) axx[length(axx)] <- n axx[axx == 0] <- 1 axl <- signif(xlabels[axx], dig = 3) axis(1, at = axx, labels = axl) } ix <- 1:n height <- wds+1 y<-x@series #graphing orgininal xplot <- ix ly <- length(y) my <- max(abs(y)) y <- y/my # axr <- c(axr, my) segments(xplot[-ly], height+0.5+y[-ly], xplot[-1], height+0.5 + y[-1], col = col, lty = lty, lwd = lwd) x1 <- ix[seq(1, n - 1, 2)] x2 <- ix[seq(2, n, 2)] ix <- (x1 + x2)/2 if (scaling == "global") { my <- 0 for (i in i.lev) { y<-x@W[[J-i]] my <- max(c(my, abs(y))) } } axr <- numeric(0) for (i in i.lev) { #graphing details n <- 2^i y<-x@W[[J-i]] xplot <- ix ly <- length(y) if (scaling == "by.level") my <- max(abs(y)) y <- (0.5 * y)/my axr <- c(axr, my) segments(xplot, height, xplot, height + y, col = col, lty = lty, lwd = lwd) if (i != first.level) { x1 <- ix[seq(1, n - 1, 2)] x2 <- ix[seq(2, n, 2)] ix <- (x1 + x2)/2 } height <- height - 1 } n <- 2^i #graphing scales y<-x@V[[J-i]] xplot <- ix ly <- length(y) if (scaling == "by.level") my <- max(abs(y)) y <- (0.5 * y)/my axr <- c(axr, my) segments(xplot, height-.5, xplot, height-.5 + y, col = col, lty = lty, lwd = lwd) if (rhlab) axis(4, at = 1:length(axr), labels = signif(axr, 3)) invisible(axr) } ################################################################################################## ################################################################################################## plot.wavr<-function (x, xlabels,wds=6, main = "Wavelet Reconstruction", sub = x@filter@wt.name, xlab = "Translate", ylab = "Resolution Level", scaling = "global", rhlab = FALSE, col = par("fg"), lty = par("lty"), lwd = par("lwd"),...) { ctmp <- class(x) if (is.null(ctmp) || all(ctmp != "mra")) stop("argument `x' is not of class \"mra\"") # named<-c("W1", "W2", "W3", "W4", "W5", "W6", "W7", "W8", "W9" , "W10") # det<-c("d1","d2","d3","d4","d5","d6","d7","d8","d9","d10") scal<-c("s1","s2","s3","s4","s5","s6","s7","s8","s9","s10") J=log2(length(x@series)) first.level<-J-wds levels <- J nlevels <- levels - first.level n <- 2^(levels) plot(c(0, 0, n, n), c(0, nlevels + 2, nlevels + 2, 0), type = "n", xlab = xlab, ylab = ylab, main = main, yaxt = "n", xaxt = "n", sub = sub, ...) i.lev <- (levels - 1):first.level lab=scal[1:nlevels] lab=c("idwt",lab) atlab=1:(nlevels+1) atlab[1]=1 axis(2, at = atlab, labels =rev(lab) ) if (missing(xlabels)) { axx <- 2^(levels) axx <- axx * 0:1 axis(1, at = axx,lab=c(0,1)) } else { axx <- pretty(1:n, n = 3) if (axx[length(axx)] > n) axx[length(axx)] <- n axx[axx == 0] <- 1 axl <- signif(xlabels[axx], dig = 3) axis(1, at = axx, labels = axl) } ix <- 1:n height <- wds+1 y<-x@series #graphing original xplot <- ix ly <- length(y) my <- max(abs(y)) y <- y/my # axr <- c(axr, my) segments(xplot[-ly], height-0.5+y[-ly], xplot[-1], height-0.5 + y[-1], col = col, lty = lty, lwd = lwd) # x1 <- ix[seq(1, n - 1, 2)] # x2 <- ix[seq(2, n, 2)] # ix <- (x1 + x2)/2 # if (scaling == "global") { # my <- 0 # for (i in i.lev) { # y<-x@S[[J-i]] # my <- max(c(my, abs(y))) # } # } height<-height-1 axr <- numeric(0) for (i in i.lev) { #graphing details # n <- 2^i y<-x@S[[J-i]] xplot <- ix ly <- length(y) # if (scaling == "by.level") # my <- max(abs(y)) y <- y/my axr <- c(axr, my) segments(xplot[-ly], height-.5+y[-ly], xplot[-1], height-.5 + y[-1], col = col, lty = lty, lwd = lwd) # if (i != first.level) { # x1 <- ix[seq(1, n - 1, 2)] # x2 <- ix[seq(2, n, 2)] # ix <- (x1 + x2)/2 # } height <- height - 1 } # n <- 2^i #graphing scales # y<-x@V[[J-i]] # xplot <- ix # ly <- length(y) # if (scaling == "by.level") # my <- max(abs(y)) # y <- (0.5 * y)/my # axr <- c(axr, my) # segments(xplot, height-.5, xplot, height-.5 + y, col = col, # lty = lty, lwd = lwd) if (rhlab) axis(4, at = 1:length(axr), labels = signif(axr, 3)) invisible(axr) }