##THIS IS SOFTWARE FOR BOOK2 "Missing and Modified Data in Nonparametric Curve Estimation"
## By Sam Efromovich
##
##Note: This software is created and should be used solely for simulation figures in the book.
#############################################
library(MASS)
library(mvtnorm)
library(survival)
library(scatterplot3d)
#############################################################################################################################
#############################################################################################################################
estcdenGEN <-function(X = NA, V=NA, H=NA,Z=NA, Zconf=NA, alpha=0.05, nn=NA, NSimConfInt=50,
d=1, reg=0, theta0=0,FLAGBUMP=1,FLAGNEG=1, cJ0 = NA, cJ1 = NA, cB = NA,cTH=NA) {
if(is.na(V[1])){V <- 1}
if(is.na(H[1])){H <- 1}
nM <- length(X)
if(is.na(nn)){nn <- nM}
JMAX <- ceiling(cJ0 + cJ1 * log(nM+ 20))
BASC <- cbind(matrix(1,ncol=1,nrow=nM),
(2^(1/2)) * cos(outer(X, pi * (1:JMAX))))
BASCV <-BASC*as.vector(V)
thetaC <- (nM/nn)*apply(BASCV[,1:JMAX],2,mean)/H
varC <-(nM/nn)*apply(BASCV[,1:JMAX],2,var)/H^2
errC <- -cumsum(thetaC^2-2*varC/nn)
J <- order(errC)[1]
theta1 <- thetaC[1:J]
theta <- theta1
theta[theta^2 < cTH*varC[1:J]/nn] <- 0
if(theta0==1){theta[1] <- 1}
if(J==1){Basis <- matrix(1,ncol=1,nrow=length(Z))}
else{
Basis <-cbind(matrix(1,ncol=1,nrow=length(Z)),
(2^(1/2)) * cos(outer(Z, pi * (1:(J-1)))))}
fest <- Basis%*%theta
if(FLAGNEG==1){fest <- negden(fest,FLAGBUMP=FLAGBUMP,cB=cB)}
if((mean(fest) < 0.8)&(theta0==1)){fest <- Z/Z}
Margin <- 0
MarginSim <- 0
if(!is.na(Zconf[1])){
Ind <- rep(TRUE,J)
Ind[theta==0] <- FALSE
Ind[varC[1:J][Ind]==0] <- FALSE
if(sum(Ind) <=1){Margin <- rep(varC[1]^(1/2),length(Zconf))
MarginSim <- Margin}
else{
BasCV <- BASCV[,1:J]
BasCV <- BasCV[,Ind]
BasisConf <- Basis[,Ind]
covB <- cov(BasCV)
Margin <- rep(1000,length(Zconf))
for(k in 1:length(Zconf)){
vec <- BasisConf[k,]
Margin[k] <- (sum(covB*outer(vec,vec)))^(1/2)
}
Margin <- qnorm(1-alpha/2)*nn^(-1/2)*Margin
FLAG <- 3
if(FLAG ==1){
U <- chol(covB)
XM <- matrix(rnorm(NSimConfInt*sum(Ind)),nrow=NSimConfInt, ncol=sum(Ind))
XMCorr <- XM%*%U
MM <- XMCorr%*%t(BasisConf)
MarginSim <- apply(abs(MM),2,quantile,prob=1-alpha,names=F)
MarginSim <- nn^(-1/2)*MarginSim
c }
if(FLAG==2){
A <- qnorm(1-alpha/(2*sum(Ind)))*sqrt(varC[1:J][Ind]/nn)
MarginSim2 <- abs(BasisConf)%*%A}
AC <- qmvnorm(1-alpha,tail="both.tails",mean=0, corr=cor(BasCV))$quantile
AN <- AC* sqrt(varC[1:J][Ind]/nn)
MarginSim <- abs(BasisConf)%*%AN
}
}
list(fest=fest,theta=theta,thetaC=thetaC,Margin=Margin,MarginSim =MarginSim)
}
estc2dimGEN <-function(X1 = NA, X2 = NA, H=NA,nn=NA,
cJ0 = NA, cJ1 = NA, cTH = NA,
knots = 5.,delta = 0.05, reg = 0., cB = 0.5)
{
if((length(X1)!=length(X2))|(length(X1)!=length(H)))
{stop("Different lengths")}
n <- length(X1)
if(is.na(nn)){nn <- n}
J <- floor(cJ0 + cJ1 * log(n + 20))
bas <- basisc2dim(X1=X1,X2=X2,J1=J,J2=J)
theta1 <- (n/nn)*apply(bas/as.vector(H), 2., mean)
theta <- theta1
varr <- (n/nn)*apply(bas/as.vector(H),2,var)
errv <- 2*varr/n - theta^2
err <- matrix(errv,nrow=J+1,ncol=J+1)
errm <- t(apply(apply(err,2,cumsum),1,cumsum))
JJ <- order(errm)[1]
J2 <- ceiling(JJ/(J+1))
J1 <- JJ%%(J+1)
if(JJ/(J+1)==J2){J1 <- J+1}
theta[theta^2 < cTH*varr/n] <- 0
thetaM1 <- matrix(theta,ncol=J+1,nrow=J+1)
thetaM2 <- thetaM1[1:J1,1:J2]
thetaC <- matrix(thetaM2,ncol=1)
if(reg == 1.) {
basr <- basisc2dim(X1=X1,X2=X2,J1=J1,J2=J2)
den.est <- basr %*% thetaC
}
else {
Z1 <- rep(seq(0., 1., len = knots),knots)
Z2 <- rep(seq(0,1,len=knots), each=knots)
basisF <- basisc2dim(X1=Z1,X2=Z2,J1=J1-1,J2=J2-1)
den.est <- basisF%*%thetaC
den.est <- matrix(den.est, ncol=knots,nrow=knots,byrow=F)
den.est
}
}
basisc2dim <- function(X1=NA,X2=NA,J1=NA,J2=NA){
if(length(X1)!=length(X2))
{stop("lenghts of X1 and X2 are different")}
if(J1==0){bas <- matrix(rep(1., length(X1)),ncol=1)
bas1 <- bas}
else{
bas1 <- cbind(matrix(rep(1., length(X1)),
ncol = 1.), 2.^(1./2.)*cos(outer(X1, pi * (1.:J1))))
bas <- bas1
}
if(J2>0){
for(j in 1.:J2) {
bas <- cbind(bas, bas1 * (2.^(1./2.) * cos(X2 * pi * j)))
}
}
bas
}
estcden2dimN <-function(X1 = NA, X2 = NA, cJ0 = NA, cJ1 = NA, cTH = NA,
knots = 5.,delta = 0.05, reg = 0., cB = 0.5)
{
n <- length(X1)
J <- floor(cJ0 + cJ1 * log(n + 20))
bas <- basisc2dim(X1=X1,X2=X2,J1=J,J2=J)
theta1 <- apply(bas, 2., mean)
theta <- theta1
varr <- apply(bas,2,var)
errv <- 2*varr/n - theta^2
err <- matrix(errv,nrow=J+1,ncol=J+1)
errm <- t(apply(apply(err,2,cumsum),1,cumsum))
JJ <- order(errm)[1]
J2 <- ceiling(JJ/(J+1))
J1 <- JJ%%(J+1)
if(JJ/(J+1)==J2){J1 <- J+1}
theta[theta^2 < cTH*varr/n] <- 0
thetaM1 <- matrix(theta,ncol=J+1,nrow=J+1)
thetaM2 <- thetaM1[1:J1,1:J2]
thetaC <- matrix(thetaM2,ncol=1)
if(reg == 1.) {
basr <- basisc2dim(X1=X1,X2=X2,J1=J1,J2=J2)
den.est <- basr %*% thetaC
}
else {
Z1 <- rep(seq(0., 1., len = knots),knots)
Z2 <- rep(seq(0,1,len=knots), each=knots)
basisF <- basisc2dim(X1=Z1,X2=Z2,J1=J1-1,J2=J2-1)
den.est <- basisF%*%thetaC
den.est <- matrix(den.est, ncol=knots,nrow=knots,byrow=F)
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
}
rgenN <-function(n = NA, den = NA,d=NA,denAct =NA){
m <- n + 100
x <- (1:m)/m
eval(parse(text = paste("p <- ", den)))
if(!is.na(denAct[1])){p <- denAct}
p[p < d] <- d
if(max(p) == d) {
stop(paste("Custom function is smaller than ",d,""))
}
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
}
readw2dim <-function(fun=NA,Z1=NA,Z2=NA,dL=0,dU=1,FLAGD=0){
if(FLAGD ==0){
if(dL <0){stop("dL is negative")}
if(dU > 1){stop("dU is larger 1")}}
if((min(c(Z1,Z2) < 0)) |(max(c(Z1,Z2) > 1))){
stop("The support is beyond [0,1]")}
x1 <- Z1
x2 <-Z2
eval(parse(text=paste("f <- ", fun)))
if(is.na(f[2])){stop("the function must depend on x or y")}
if(FLAGD ==0){
f[f
dU] <-dU }
f
}
readw <-function(fun=NA,z=NA,dL=0,dU=1,NN=10000,FLAGD=0){
if(FLAGD ==0){
if(dL <0){stop("dL is negative")}
if(dU > 1){stop("dU is larger 1")}}
if((min(z) < 0) |(max(z) > 1)){
stop("The support is beyond [0,1]")}
x <- seq(0,1,len=NN)
y <-x; v <- x; u <- x
eval(parse(text=paste("f <- ", fun)))
if(is.na(f[2])){stop("the function must depend on x or y or v")}
if(FLAGD ==0){
f[fdU] <-dU }
ZZ <- floor(z*NN)
ZZ[ZZ==0] <- 1
fout <- f[ZZ]
fout
}
readwN <-function(fun=NA,Z=NA,dL=0,dU=1,NN=10000,FLAGP=0){
if(FLAGP ==0){
if(dL <0){stop("dL is negative")}
if(dU > 1){stop("dU is larger 1")}}
x <- Z; y <-x; v <- x; z <- Z; u <- x
eval(parse(text=paste("f <- ", fun)))
if(is.na(f[2])){stop("the function must depend on x or y or v")}
if(FLAGP ==0){
f[fdU] <-dU }
f
}
readf <-function(fun=NA,z=NA,d=0,NN=10000){
if((min(z) < 0) |(max(z) > 1)){
stop("The support is beyond [0,1]")}
x <- seq(0,1,len=NN)
y <- x
eval(parse(text=paste("f <- ", fun)))
if(is.na(f[2])){stop("the function must depend on x or y")}
f[f 1){stop("dU is larger 1")}}
x <- Z1
y <-Z2
eval(parse(text=paste("f <- ", fun)))
if(is.na(f[2])){stop("the function must depend on x or y")}
if(FLAGD ==0){
f[fdU] <-dU }
f
}
estcregNGen <-function(X=NA, Y = NA,Z=NA, p=NA, H = 1,Density=F, Subsample=T, nT=NA,
cJ0 = NA, cJ1 = NA, cB = NA,cTH=NA,FLAGNEG=0) {
if(length(X) !=length(Y)){
stop("Lengths of X and Y are different")}
if(!is.na(p[1])){if(length(p)!=length(X)){stop("Lengths of X and p are different") } }
nn <- length(X)
if(is.na(nT)){nT <- nn}
Y <- as.vector(Y)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))
if(is.na(p[1])){
p <-estcdenN(X = X, Z=X,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest}
p <-as.vector(p)
p[p < 1/log(nn+20)] <- 1/log(nn+20)
if(Density){theta0<- 1; vartheta0=0}
else{theta0 <- (nn/nT)*mean(Y/p);vartheta0 <- (nn/nT)*var(Y/p) }
BASC <- cbind(matrix(1,ncol=1,nrow=nn),
(2^(1/2)) * cos(outer(X, pi * (1:JMAX))))
if(Subsample){BASCYp <- Y*BASC/p}
else{BASCYp <- (Y-theta0)*BASC/p}
thetaC <- (nn/nT)*apply(BASCYp[,1:JMAX],2,mean)/H
thetaC[1] <- theta0
varC <- (nn/nT)*apply(BASCYp[,1:JMAX],2,var)/H^2
varC[1] <- vartheta0
errC <- -cumsum(thetaC^2-2*varC/nn)
J <- order(errC)[1]
theta1 <- thetaC[1:J]
theta <- theta1
theta[theta^2 < cTH*varC[1:J]/nn] <- 0
if(J==1){Basis <- matrix(1,ncol=1,nrow=length(Z))}
else{
Basis <-cbind(matrix(1,ncol=1,nrow=length(Z)),
(2^(1/2)) * cos(outer(Z, pi * (1:(J-1)))))}
fest <- Basis%*%theta
if(FLAGNEG==1){fest <- negden(fest,FLAGBUMP=1,cB=cB)}
list(fest=fest,theta=theta,thetaC=thetaC)
}
estcregN <-function(X=NA, Y = NA,V=NA,p=NA,H=1,Z=NA,FLAGSUBTR=1, c=1,
cJ0 = NA, cJ1 = NA, cB = 2,cTH=NA,FLAGNEG=0) {
if(length(X) !=length(Y)){
stop("Lengths of X and Y are different")}
nn <- length(X)
if(is.na(V[1])){V <- 1}
V <- as.vector(V)
Y <- as.vector(Y)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))
if(is.na(p[1])){
p <-estcdenN(X = X,Z=X,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB = cB,
cTH=cTH)$fest
p <- as.vector(p)
p[p < c/log(nn+20)] <- c/log(nn+20)}
p <-as.vector(p)
theta0 <- mean(Y*V/p)
vartheta0 <- var(Y*V/p)
BASC <- cbind(matrix(1,ncol=1,nrow=nn),
(2^(1/2)) * cos(outer(X, pi * (1:JMAX))))
BASCYp <- as.vector(Y-FLAGSUBTR*theta0)*BASC*V/p
thetaC <- apply(BASCYp[,1:JMAX],2,mean)/H
thetaC[1] <- theta0
varC <- apply(BASCYp[,1:JMAX],2,var)/H^2
varC[1] <- vartheta0
errC <- -cumsum(thetaC^2-2*varC/nn)
J <- order(errC)[1]
theta1 <- thetaC[1:J]
theta <- theta1
theta[theta^2 < cTH*varC[1:J]/nn] <- 0
if(J==1){Basis <- matrix(1,ncol=1,nrow=length(Z))}
else{
Basis <-cbind(matrix(1,ncol=1,nrow=length(Z)),
(2^(1/2)) * cos(outer(Z, pi * (1:(J-1)))))}
fest <- Basis%*%theta
if(FLAGNEG==1){fest <- negden(fest,FLAGBUMP=1,cB=cB)}
list(fest=fest,theta=theta,thetaC=thetaC)
}
estcdenBIASED <-function(Y = NA, h=NA,Z=NA,
FLAGNEG=1, cJ0 = NA, cJ1 = NA, cB = NA,cTH=NA) {
nn <- length(Y)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))
BASC <- cbind(matrix(1,ncol=1,nrow=nn),
(2^(1/2)) * cos(outer(Y, pi * (1:JMAX))))
BASCH <- BASC/h
p <- 1/mean(1/h)
thetaCH <- p*apply(BASCH[,1:JMAX],2,mean)
varCH <- p^2*apply(BASCH[,1:JMAX],2,var)
errCH <- -cumsum(thetaCH^2-2*varCH/nn)
J <- order(errCH)[1]
theta1 <- thetaCH[1:J]
theta <- theta1
theta[theta^2 < cTH*varCH[1:J]/nn] <- 0
theta[1] <- 1
if(J==1){Basis <- matrix(1,ncol=1,nrow=length(Z))}
else{
Basis <-cbind(matrix(1,ncol=1,nrow=length(Z)),
(2^(1/2)) * cos(outer(Z, pi * (1:(J-1)))))}
fest <- Basis%*%theta
if(FLAGNEG==1){fest <- negden(fest,FLAGBUMP=1,cB=cB)}
list(fest=fest,theta=theta,thetaCH=thetaCH)
}
estimfcdN <- function(X=NA,J=NA){
BASC <- cbind(matrix(1,ncol=1,nrow=nn), (2^(1/2)) * cos(outer(X, pi * (1:J))))
thetaC <- apply(BASC[,1:JMAX],2,mean)
varC <- apply(BASC[,1:JMAX],2,var)
list(theta=thetaC,varC=varC)
}
estcdenN<-function(X = NA,Z=NA,FLAGNEG=1, cJ0 = NA, cJ1 = NA, cB = 2,cTH=NA) {
nn <- length(X)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))
BASC <- cbind(matrix(1,ncol=1,nrow=nn),
(2^(1/2)) * cos(outer(X, pi * (1:JMAX))))
thetaC <- apply(BASC[,1:JMAX],2,mean)
varC <- apply(BASC[,1:JMAX],2,var)
errC <- -cumsum(thetaC^2-2*varC/nn)
J <- order(errC)[1]
theta1 <- thetaC[1:J]
theta <- theta1
theta[theta^2 < cTH*varC[1:J]/nn] <- 0
theta[1] <- 1
if(J==1){Basis <- matrix(1,ncol=1,nrow=length(Z))}
else{
Basis <-cbind(matrix(1,ncol=1,nrow=length(Z)),
(2^(1/2)) * cos(outer(Z, pi * (1:(J-1)))))}
fest <- Basis%*%theta
if(FLAGNEG==1){fest <- negden(fest,FLAGBUMP=1,cB=cB)}
list(fest=fest,theta=theta,thetaC=thetaC)
}
hGcornerf <- function(cornerf = 2, Z= NA)
{
if(cornerf == 1) {
f <- dunif(Z)
G <- 1-punif(Z)
}
if(cornerf == 2) {
f <- dnorm(Z, mean = 0.5, sd = 0.15)/(1-2*pnorm(0,mean=0.5,sd=0.15))
G <- 1-(pnorm(Z, mean = 0.5, sd = 0.15)-pnorm(0,mean=0.5,sd=0.15))/
(1-2*pnorm(0,mean=0.5,sd=0.15))
}
if(cornerf == 3) {
f <- 0.5 * dnorm(Z, 0.4, 0.12)/(pnorm(1,mean=.4,.12)-pnorm(0,mean=0.4,.12)) +
0.5 * dnorm(Z, 0.7, 0.08)/(pnorm(1,0.7,0.08)-pnorm(0,mean=0.7,.08))
G <- 1- 0.5*(pnorm(Z,.4,.12)-pnorm(0,.4,.12))/(pnorm(1,mean=.4,.12)-pnorm(0,mean=0.4,.12)) -0.5*(pnorm(Z,.7,.08)-pnorm(0,.7,.08))/(pnorm(1,mean=.7,.08)-pnorm(0,mean=0.7,.08))
}
if(cornerf == 4) {
f <- 0.5 * dnorm(Z, 0.2, 0.06) + 0.5 * dnorm(Z, 0.75, 0.08)
G <- 1- 0.5*(pnorm(Z,.2,.06)-pnorm(0,.2,.06))/(pnorm(1,mean=.2,.06)-pnorm(0,mean=0.2,.06)) -0.5*(pnorm(Z,.75,.08)-pnorm(0,.75,.08))/(pnorm(1,mean=.75,.08)-pnorm(0,mean=0.75,.08))
}
h <- f/G
list(h=h,G=G)
}
hGcornerfOld<-function(cornerf = 2, Z= NA)
{
if(cornerf == 1) {
f <- dunif(Z)
G <- 1-punif(Z)
}
else if(cornerf == 2) {
f <- dnorm(Z, mean = 0.5, sd = 0.15)
G <- 1-pnorm(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)
G <- 1- (0.5 * pnorm(Z, 0.4, 0.12) + 0.5 * pnorm(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)
G <- 1- (0.5 * pnorm(Z, 0.2, 0.06) + 0.5 * pnorm(Z, 0.75, 0.08))
}
h <- f/G
list(h=h,G=G)
}
lenb.genN<-function(i = 1, n = 50, Z=NA,a = 0.1, b = 0.9, CFUN = list(NA, NA))
{
flag <- 1
Y <- 0
g.z <- a + b * Z
mu <- mean(dcornerf(c = i, Z=Z, 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)
}
lenbCOND.genN <- function(X=NA, mX=NA,a1=NA,a2=NA,a3=NA,sigma=NA)
{
nn <- length(X)
V <- rep(-10,nn)
BXY <- V
for(i in 1:nn){
flag <- 1
C <- (a1 + a2*X[i] + a3*(mX[i] + 4*sigma))/(a1+a2*X[i]+a3*mX[i])
while(flag == 1) {
U <- runif(30)
Y <-mX[i]+ sigma*rnorm(30)
CCC <- (a1+a2*X[i]+ a3*Y)/((a1+a2*X[i]+a3*mX[i])*C)
FF <- (U <= CCC)
if(sum(FF) > 0){ Y <- Y[FF]; V[i] <- Y[1]}
flag <- 0}
}
list(V=V,BXY=(a1+a2*X + a3*V)/(a1+a2*X + a3*mX))
}
#############################################################################################################################
negden<-function(f = NA, delta = 0.01, FLAGBUMP = 1, cB = 2)
{
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)
{
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
}
estcdenCURSTAT<-function(X = NA,Delta=NA,fX=NA,Z=NA,theta0=NA,FLAGM=NA,
FLAGNEG=1, cJ0 = NA, cJ1 = NA, cB = NA,cTH=NA) {
nn <- length(X)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))
if(FLAGM==0){
BASS <- (2^(1/2)) * sin(outer(Delta*X, pi * (1:JMAX)))
BASSfX <-as.vector(Delta)*BASS/as.vector(fX)
thetaCC <- apply(BASSfX,2,mean)*(pi*(1:JMAX))
thetaC <- c(1,2^(1/2)*cos(pi*(1:JMAX))+thetaCC)
varC <-c(1,apply(BASSfX,2,var)*(pi*(1:JMAX))^2)
}
if(FLAGM==1){
BASS <- (2^(1/2)) * sin(outer((1-Delta)*X, pi * (1:JMAX)))
BASSfX <-as.vector(1-Delta)*BASS/as.vector(fX)
thetaCC <- apply(BASSfX,2,mean)*(pi*(1:JMAX))
thetaC <- c(1,2^(1/2)-thetaCC)
varC <-c(1,apply(BASSfX,2,var)*(pi*(1:JMAX))^2)
}
if(FLAGM==2){
fX.est<-estcdenN(X =X,Z=X,FLAGNEG=1, cJ0 =cJ0, cJ1 =cJ1, cB =cB,cTH=cTH)$fest
fX.est[fX.est < 1/log(nn)] <- 1/log(nn)
BASS <- (2^(1/2)) * sin(outer(Delta*X, pi * (1:JMAX)))
BASSfX <-as.vector(Delta)*BASS/as.vector(fX.est)
thetaCC <- apply(BASSfX,2,mean)*(pi*(1:JMAX))
thetaC0 <- c(1,2^(1/2)*cos(pi*(1:JMAX))+thetaCC)
varC0 <-c(1,apply(BASSfX,2,var)*(pi*(1:JMAX))^2)
BASS <- (2^(1/2)) * sin(outer((1-Delta)*X, pi * (1:JMAX)))
BASSfX <-as.vector(1-Delta)*BASS/as.vector(fX)
thetaCC <- apply(BASSfX,2,mean)*(pi*(1:JMAX))
thetaC1 <- c(1,2^(1/2)-thetaCC)
varC1 <-c(1,apply(BASSfX,2,var)*(pi*(1:JMAX))^2)
thetaC <- (thetaC0*varC1+thetaC1*varC0)/(varC0+varC1)
varC <- varC0*varC1/(varC0 + varC1)
}
errC <- -cumsum(thetaC^2-2*varC/nn)
J <- order(errC)[1]
theta1 <- thetaC[1:J]
theta <- theta1
theta[theta^2 < cTH*varC[1:J]/nn] <- 0
theta[1] <- theta0
if(J==1){Basis <- matrix(1,ncol=1,nrow=length(Z))}
else{
Basis <-cbind(matrix(1,ncol=1,nrow=length(Z)),
(2^(1/2)) * cos(outer(Z, pi * (1:(J-1)))))}
fest <- Basis%*%theta
fest[fest < 0] <- 0
fest <- fest/mean(fest)
list(fest=fest,theta=theta,thetaC=thetaC)
}
estcdenCURSTATGEN<-function(X = NA,Delta=NA,fX=NA,fXZ=NA,Z=NA,FLAGM=NA,
FLAGNEG=1, cJ0 = NA, cJ1 = NA, cB = NA,cTH=NA) {
nn <- length(X)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))
if(FLAGM==0){
a <- min(X[Delta==1]); b <- max(X[Delta==1]) - a
XSC <- (X-a)/b; XASC <- (X[Delta==1]-a)/b; ZSC <- (Z-a)/b
fXD.est <- estcdenGEN(X =XASC, V=NA, H=NA,Z=XASC,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
fXD.est[fXD.est < 0] <- 0
fXD.est <- fXD.est*sum(Delta)/(nn * b)
F.est <- fXD.est/fX[Delta==1];
F.est <- monot(F.est,del=0.01)
Fa.est <- min(F.est); Fab.est <-max(F.est)
if(Fab.est <= Fa.est){Fab.est <- Fa.est +sum(Delta)/nn;ccc <- Fab.est-1
if(ccc > 0){Fa.est<- Fa.est - ccc; Fab.est <- 1}
}
ffXD.est <- estcdenGEN(X =XASC, V=NA, H=NA,Z=ZSC,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
ffXD.est <- ffXD.est*sum(Delta)/(nn * b)
FZ.est <- ffXD.est/fXZ; FZ.est <- monot(FZ.est,del=0.01)
BASS <- (2/b)^(1/2) * sin(outer(Delta*XSC, pi * (1:JMAX)))
BASSfX <-as.vector(Delta)*BASS/as.vector(fX)
thetaCC <- apply(BASSfX,2,mean)*(pi*(1:JMAX)/b)
thetaCCC <- (2/b)^(1/2)*(cos(pi*(1:JMAX))*Fab.est - Fa.est)+thetaCC
thetaC <- c(b^(-1/2)*(Fab.est-Fa.est),thetaCCC)
varC <-c(1,apply(BASSfX,2,var)*(pi*(1:JMAX))^2)
}
errC <- -cumsum(thetaC^2-2*varC/nn)
J <- order(errC)[1]
theta1 <- thetaC[1:J]
theta <- theta1
theta[theta^2 < cTH*varC[1:J]/nn] <- 0
theta <- c(max(FZ.est) -min(FZ.est), theta)
Basis <-cbind(matrix(b^(-1/2),ncol=1,nrow=length(Z)),
((2/b)^(1/2)) * cos(outer(ZSC, pi *(1:J))))
fest <- Basis%*%theta
fest[fest < 0] <- 0
list(fest=fest,theta=theta,thetaC=thetaC,Fest=FZ.est)
}
Mshiftprod <- function(X=NA,J=NA){
nn <- length(X)
M <- matrix(-100,nrow=nn,ncol=1+J)
for(i in 1:(J+1)){
M[i:nn,i] <-X[1:(nn-i+1)]*X[i:nn] # V[1:(nn-i+1),i]*V[i:nn,i]
}
M
}
amplmodul <- function(nn=NA, alpha=NA, beta=NA, lambda=NA, batch=NA){
if(batch){NN <- rpois(n=nn,lambda=lambda)
A <- 1; k<- 1;v <- 1
while(k <= nn){
if(NN[v] > 0){A <- c(A,rep(0,NN[v])); k <- k+NN[v];v <- v+1}
else{A <- c(A,1); k <- k+1; v <- v+1}
}
A <- A[2:(nn+1)]
}
else{ #batch=FALSE
B0 <- rbinom(n=nn, size=1,prob=1-alpha); B1 <- rbinom(n=nn, size=1,prob=beta); A <- B0
for(i in (2:nn)){
if(A[i-1]==1){A[i] <- B1[i]}
}
A
}
}
estspecden.mis <- function(Y=NA,A=NA,Z=NA,FLAGNEG=0, cJ0 =NA, cJ1 = NA, cB = NA,cTH=NA) {
nn <- length(Y)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))
MY <-Mshiftprod(X=Y,J=JMAX)
MA <-Mshiftprod(X=A,J=JMAX)
AAA <- (abs(A)>0)*1;MAAA <-Mshiftprod(X=AAA,J=JMAX)
thetaC <- rep(-100,JMAX+1) ;NJ <- rep(-100,JMAX+1)
varC <-thetaC
for(i in 1:(JMAX+1)){aa <- mean(MA[i:nn,i]);yy <- MY[i:nn,i]/aa
thetaC[i] <- mean(yy); varC[i] <- var(yy)
NJ[i] <- sum(MAAA[i:nn,i])
}
errC <- -cumsum(thetaC^2-2*varC/nn)
J <- order(errC)[1]
theta1 <- thetaC[1:J]
theta <- theta1
theta[theta^2 < cTH*varC[1:J]/nn] <- 0
theta[1] <- theta[1]/2
if(J==1){Basis <- matrix(1/pi,ncol=1,nrow=length(Z))}
else{
Basis <-cbind(matrix(1,ncol=1,nrow=length(Z)),
cos(outer(Z, (1:(J-1)))))}
fest <- Basis%*%theta/pi
if(FLAGNEG==1){fest <- negden(fest,FLAGBUMP=1,cB=cB)}else{fest[fest < 0] <- 0}
list(fest=fest,theta=theta,thetaC=thetaC,NJ = NJ)
}
fractgn<- function(n = 10, alpha = 0.5)
{
H <- 1 - alpha/2
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)
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")
}
z
}
estfiltN<-function(hat.theta = NA, knots = 100, cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, cB = 2, kk = 30)
{
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
}
trigcaprN<-function(f = NA, level = 3, xsq = 0, a = 0.55, knots = 50, bound = c(0.1, 0.9))
{
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)
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) {
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
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)
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)
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)
}
dynamarma <- function(n=NA,a0=NA,b0=NA,a1=NA,b1=NA,sigma=NA){
nn <- n; X <- rep(-1000,nn); X[1] <- -.3; W <- rnorm(nn+1)
a <- seq(a0,a1,len=nn); b <- seq(b0,b1,len=nn)
for(i in 2:nn){X[i] <- a[i]*X[i-1] + sigma*(W[i]+b[i]*W[i-1]) }
X
}
basiscp<-function(Z=NA, JMAX=NA)
{
nn <- length(Z)
BASC <- cbind(matrix(1,ncol=1,nrow=nn), (2^(1/2)) * cos(outer(Z, pi * (1:JMAX))))
BASP <- matrix(-99,nrow=nn,ncol=2*JMAX+2)
for(J in 0:JMAX){
if(J == 0) {
BASP[,1] <- (Z - 0.5)/sqrt(1/12)
BASP[,2] <- (Z^2 - 1/3 - (Z - 0.5))/sqrt(4/45 - 1/12)
}
else {
bas <- (2^(1/2)) * cos(outer(Z, pi * (1:J)))
vec <- 1:J
psi1 <- matrix(Z - 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)
psi2 <- matrix(Z^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)
BASP[,2*J+1] <- psi1
BASP[,2*J+2] <- psi2
}
}
BASP <- BASP/ matrix( sqrt( apply(BASP^2,2,mean)),nrow=nn,ncol=2*JMAX+2,byrow=T)
list(BASC = BASC, BASP = BASP)
}
esthazardCP <-function(X = NA, V=NA, Z=NA, nn=NA,
FLAGNEG=1, cJ0 = NA, cJ1 = NA, cB = NA,cTH=NA,cTP =NA) {
if(is.na(V[1])){V <- 1}
nM <- length(X)
if(is.na(nn)){nn <- nM}
JMAX <- ceiling(cJ0 + cJ1 * log(nM+ 20))
BASS <- basiscp(Z=X, JMAX=JMAX)
errM <- NULL
for(j in 1:JMAX){
BASCP <- cbind(BASS$BASC[,1:j],BASS$BASP[,(2*j-1):(2*j)])
BASCPV <- BASCP*as.vector(V)
thetaC <- (nM/nn)*apply(BASCPV,2,mean)
varC <-(nM/nn)*apply(BASCPV,2,var)
errC <- -sum(thetaC^2-2*varC/nn)
errM <- c(errM,errC)
}
J <- order(errM)[1]
if(J==JMAX){J<- J-1}
browser()
BASTHETA <- cbind(BASS$BASC[,1:J],BASS$BASP[,(2*J-1):(2*J)])*as.vector(V)
theta1 <- (nM/nn)*apply(BASTHETA,2,mean)
theta <- theta1
vartheta <- (nM/nn)*apply(BASTHETA,2,var)
cTV <- c(rep(cTH,J),c(cTP,cTP))
theta[theta^2 < cTV*vartheta/nn] <- 0
browser()
BASSZ <- basiscp(Z=Z, JMAX=J)
Basis<- cbind(BASSZ$BASC[,1:J],BASSZ$BASP[,(2*J-1):(2*J)])
fest <- Basis%*%theta
if(FLAGNEG==1){fest <- negden(fest,FLAGBUMP=1,cB=cB)}
fest
}
HGLT.est <- function(X=NA,T=NA,Z=NA, alpha=NA){
r <- order(X); X <- X[r]; T<- T[r]
nn <- length(X); knots<- length(Z); q <- qnorm(alpha/2,lower.tail=F)
MTF <- matrix(T,ncol=nn,nrow=nn, byrow=TRUE); MT <- MTF; MT[row(MT) > col(MT)] <- max(X) + 100
MTL <- (MT <= X)
gX.est <- apply(MTL,1,mean)
Ind <-matrix(X,ncol=knots,nrow=nn)<=matrix(Z,ncol=knots,nrow=nn,byrow=TRUE)
Hz.est <- apply(Ind/matrix(gX.est,ncol=knots,nrow=nn),2,mean)
Gz.est <- exp(-Hz.est)
Gz.est[Z >=max(X)] <- 0
TMAX <- max(T); G.TMAX <- exp(-mean((X <= TMAX)/gX.est)); p.est <- G.TMAX/mean((TMAX <= X))
VarH <- (1/n)* (apply(Ind/matrix((gX.est)^2,ncol=knots,nrow=nn),2,mean) - (Hz.est)^2)
VarG <- (Gz.est)^2*VarH
Uband <- Gz.est + q*(VarG)^(1/2);Lband <- Gz.est - q*(VarG)^(1/2)
list(Gz.est=Gz.est,Hz.est =Hz.est, Uband=Uband,Lband=Lband,p.est =p.est)
}
################################################################
#FRONTCOVER
##################################################################
ch0<-function(fig = NA,w=NA, set.corn=NA,corn=NA, NCLAS=10,
set.n=NA,n=NA, k=NA,v=.6,
SIM=1,WRITE=FALSE, COL=2, COLF=3,set.c =NA,
sigmaN=.5, cS=4,c=NA,setw.cJ0=NA,setw.cJ1=NA,set.beta=NA,
a=NA,b=NA, #a=0.2,b=0.8,
dscale=0,sigma=NA, set.dfyL =NA,
mx="2*x",
scalefun="3-(x-0.5)^2",
desden=NA,
dden=0.2,
dwL=NA,dwU=NA,
knots=100,
CFUN = list(NA, NA),cJ0 = 3, cJ1 = 0.8, cTH = NA,
cB = 2,
c11=1,c12=2,c21=2,c22=3,knots1=20,knots4 =30)
{
if(fig == 1) {
if(is.na(corn)){corn <- 3}
if(is.na(n)){n <- 100}
if(is.na(w)){w <- "1-.7*x"}
if(is.na(dwL)){dwL <- .3}
if(is.na(dwU)){dwU <- .9}
par(mfcol = c(1, 2))
z <- seq(0, 1, l = knots)
wz <- readw(fun=w,z=z,dL=dwL,dU=dwU,NN=10000,FLAGD=0)
DDATA <- "Data0.1"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,nrow=n,ncol=2)
X <- rcornerf(cornerf = corn, n =n,CFUN = CFUN)
wX <- readw(fun=w,z=X,dL=dwL,dU=dwU,NN=10000,FLAGD=0)
A <-rbinom(n,1,wX)
DATA <- cbind(X,A)
if(WRITE){write(t(DATA),file=DDATA,ncol=2)}
}
X <- DATA[,1]; A <- DATA[,2]; AX <- X[A==1]
f <- dcornerf(c = corn, Z=z, CFUN = CFUN)
mmm <- hist(X, plot = F, nclass = NCLAS)$density
mmm <- max(c(mmm, f))
hist(X, freq=F, nclass = NCLAS, xlab = "X",
main = paste("Hidden Data", paste("n = ",length(X),sep=""),sep=", "),
xlim = c(0, 1), ylim = c(0, mmm),col=COL)
lines(z, f, type = "l",col=1+COLF,lwd=3)
mmm <- hist(AX, plot = F, nclass = NCLAS)$density
mmm <- max(c(mmm, f))
hist(AX, freq=F, nclass =NCLAS, col=COL, xlab = "X[A==1]",
main = paste("Missing Data", paste("N = ",length(AX),sep=""),sep=", "),
xlim = c(0, 1), ylim = c(0, mmm))
lines(z, f, type = "l",col=1+COLF,lty=1,lwd=3)
}
}
##############################
# CHAPTER 1
############################################
#############################################
ch1<-function(fig = 1,SIM=1,a=NA,b=NA, c= NA,d=NA,v=NA,n=400,
dscale=0,dden =0.2,lbden =NA, sigma=NA, COL=1,
set.B = NA,set.corn =NA, bound.set =NA,scalefun =2,
muzeta=NA,sdzeta=NA,muxi=NA,sdxi=NA,#scalefun="3-(x-0.5)^2",
set.k=NA,setw.cJ0=NA,setw.cJ1=NA,set.c=NA,
desden="1+0.5*x", w = NA,alpha = 0.05,WRITE=FALSE,
set.n = NA, knots=50,
h = NA,c11=1,c12=2,c21=2,c22=3,knots1=20,
CFUN = list(NA, NA),cJ0 = 3, cJ1 = 0.8, cTH = 4,
cB = 2)
{
if((fig==1)|(fig==2)){
if(is.na(a)){a <-0};if(is.na(b)){b <-.7}
par(mfrow = c(4, 1))
knots <- 100; z <- seq(0,1,len=knots); f <- dcornerf(c=2,Z=z)
nn <- n
if(fig==1){DDATA <- "Data1.1"}
if(fig==2){DDATA <- "Data1.2"}
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 2,nrow=nn)
DATA[,1] <- rcornerf(c=2,n=nn)
pp <- a+b*DATA[,1]; pp[pp < 0] <- 0; pp[pp > 1] <- 1
A <- rbinom(n=nn,size=1,prob=pp)
DATA[,2] <- A*DATA[,1]
if(WRITE){write(t(DATA), file=DDATA, ncol=2)}
}
hist(DATA[,1], freq=F, nclass = floor(nn/10),xlim=c(0,1),
xlab=expression(X^"*"),
main=paste("Histogram of Direct Observations, n = ", n))
hist(DATA[,1], freq=F, nclass = floor(nn/10),xlim=c(0,1),
xlab=expression(X^"*"),
main=paste("Histogram of Direct Observations and Underlying Density"))
lines(z,f,lwd=2)
ZZ <- DATA[,2];AZ <- ZZ[ZZ > 0]; N <- length(AZ)
hist(AZ, freq=F, nclass = floor(nn/10),xlim=c(0,1),
main=paste(
paste("Histogram of Biased Observations, a = ", a),
paste(paste(" b = ", b),paste(", N = ", N), sep=""),sep=","),
xlab="X")
hist(AZ, freq=F, nclass = floor(nn/10),xlim=c(0,1),xlab="X",
main=paste("Histogram of Biased Observations and Underlying Density"))
lines(z,f,lwd=2)
}
if(fig==3){
par(mfrow = c(3, 1))
knots <- 100; z <- seq(0,1,len=knots); f <- dcornerf(c=1,Z=z)
nn <- n
DDATA <- "Data1.3"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 3,nrow=nn)
DATA[,1] <- rcornerf(c=1,n=nn)
DATA[,2] <- rcornerf(c=2,n=nn)
DATA[,3] <- rcornerf(c=2,n=nn)
if(WRITE){write(t(DATA), file=DDATA, ncol=3)}
}
X <- DATA[,1];D <- DATA[,2]; L <- DATA[,3]
hist(X, freq=F, nclass = floor(nn/10),xlim=c(0,1), xlab=expression(X^"*"),
main=paste("Histogram of Hidden Losses and the Underlying Density, n = ", n))
lines(z,f,lwd=2)
TF <- X >= D
hist(X[TF], freq=F, nclass = floor(nn/10),xlim=c(0,1), xlab="X",
main=paste("Histogram of Truncated Losses and Underlying Densities, N = ", sum(TF)))
lines(z,f,lwd=2)
lines(z,dcornerf(c=2,Z=z),lty=2,lwd=2)
V <- pmin(X,L); DeltaL <- X <= L; DeltaN <- 1*DeltaL
plot(V,DeltaN, type="p",xlab="V",ylab=expression(Delta),ylim=c(-.1,1.1),
yaxp=c(0,1,1),xaxp=c(0,1,5),xlim=c(0,1),
main=paste("Censored Losses, M = ",sum(DeltaN)))
}
if(fig==4){
hstart <- t(read.table("hstart"))
par(mfrow=c(3,1))
JMAX<- 6
Y <- as.vector(hstart)
nn <- length(Y)
fest <- estcregm(X=seq(0,1,len=nn),Y=Y,knots=nn,method=2,JJMAX=JMAX)
plot(1:nn,Y,xlab="Month",ylab="Housing Starts",main="Monthly Housing Starts")
lines(1:nn,fest,type="l",lty=2,lwd=2)
abline(lsfit(1:nn,Y),lwd=2)
DATA <- read.table("dataInsClaims.txt", sep=",",head=TRUE)
XXX <- DATA[,4] #age of drivers
YYY <- DATA[,5] #claims
XX <- XXX[(YYY < 40000)&(YYY>10000)]
YY <- YYY[(YYY < 40000)&(YYY>10000)]
aa <- min(XX)
bb <- max(XX)
X <- (XX-aa)/(bb-aa)
Y <- YY
nnn <- length(XX)
z <- seq(0,1,len=knots)
estXY <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH,cB = cB)$fest
plot(XX,YY, ylab="Amount", xlab="Age",
main="Auto Insurance Claims")
abline(lsfit(XX,YY),lwd=2)
lines(seq(aa,bb,len=knots),estXY, type="l",lty=2, lwd=2)
WAGE <- read.table("Data1.4")
Y <- WAGE[,1] #This is logwage of data "cps71" from package "np"
X <- WAGE[,2] #This is age of data "cps71" from package "np"
model.par <- lm(Y ~ X + I(X^2))
aa <- min(X);bb <- max(X); Xsc <- (X-aa)/(bb-aa)
est <- estcregN(X = Xsc, Y = Y, Z=z, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH,cB = cB)$fest
plot(X, Y, xlab = "Age", ylab = "log(wage)", main="Wages")
lines(X, fitted(model.par), type="l", lty = 3, lwd=2)
lines(seq(aa,bb,len=knots),est, type="l",lty=2, lwd=2)
abline(lsfit(X,Y),lty=1,lwd=2)
}
if(fig==6){
if(is.na(a)){a <-0}
if(is.na(b)){b <-.005}
if(is.na(c)){c<-60}
if(is.na(d)){d <-50}
if(is.na(v)){v<-20}
par(mfrow = c(3, 1))
knots <- 100; z <- seq(0,1,len=knots); f <- dcornerf(c=2,Z=z)
nn <- n
DDATA <- "Data1.6"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 3,nrow=nn)
DATA[,1] <- rcornerf(c=2,n=nn)
DATA[,2] <- c + d*DATA[,1] + v*(runif(nn)-0.5)
pp <- a+b*DATA[,2]; pp[pp < 0] <- 0; pp[pp > 1] <- 1
A <- rbinom(n=nn,size=1,prob=pp)
DATA[,3] <- A
if(WRITE){write(t(DATA), file=DDATA, ncol=3)}
}
X <- DATA[,1];S <- DATA[,2]; A <- DATA[,3]
plot(A*X,S,main=
paste("Missing Data Scattergram of Speed Versus Ratio of Alcohol, n = ",n,
", N = ",sum(A)),
xlab="AX",ylab="S", sub=paste("a = ",a,", b = ",b,", c = ",c,", d = ",d,
", v = ", v))
plot(S,A*X,main="Missing Data Scattergram of Ratio of Alcohol Versus Speed",
ylab="AX",xlab="S")
plot(S,A,main="Scattergram of Availability Versus Speed",
ylab="A",xlab="S")
}
}
#####################################################################################
#####################################################################################
ch2<-function(fig = 1,SIM=1,a=0.2,b=0.8, dscale=0,dden =0.2,lbden =1,
sigma=1, COL=1,c=1,
scalefun="3-(x-0.5)^2",set.k=NA,seth.cJ0=NA,seth.cJ1=NA,set.c=NA,
n = NA, alpha = 0.05,WRITE=FALSE,
set.n = NA, knots=100,
CFUN = list(NA, NA),cJ0 = 3, cJ1 = 0.8, cTH = 4,cB = 2,
desden="1+0.5*x", h = NA,c11=1,c12=2,c21=2,c22=3,knots1=20)
{
ttle <- c("1. Uniform", "2. Normal", "3. Bimodal",
"4. Strata")
ttleN <- c("Uniform", "Normal", "Bimodal",
"Strata")
if((set.n[1]== -99.9) |(length(set.n) != 3)) {
set.n <- c(100,200,300)
}
if(!is.na(CFUN[[2]])) {
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
else if(is.na(CFUN[[1]]) & is.na(CFUN[[2]]) & fig == 3) {
CFUN <- list(1, "2 - 2*x -sin(8*x)")
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
if(!is.na(CFUN[[2]])) {
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
##############################################
####################################
if(fig == 1) {
par(mfrow = c(1, 4))
z <- seq(0, 1, len = 100)
for(i in 1:4) {
plot(z, dcornerf(c = i,Z=z,CFUN = CFUN),
type = "l", lwd=2,xlab = "", ylab = "", main = ttle[i])
}
}
else if(fig == 2) {
par(mfrow = c(2,4))
for(i in 0:7) {
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", lwd=2,xlab = "", ylab = "", main = paste("j = ", i, sep = ""))
}
}
else if(fig == 3) {
par(mfrow = c(2, 4))
z <- seq(0,1,len=knots)
for(jj in c(0,4)){
for(i in (1:4)) {
ff <-dcornerf(c = i, Z=z, CFUN = CFUN)
for(JJ in jj+(1:4)) {
f1 <- trigcapr(f = dcornerf(c = i,Z=seq(0,1,len=300), CFUN = CFUN),
knots = knots, level = JJ, xsq = 0)
if(JJ == jj+1) {
f <- f1$apr
}
else {
f <- cbind(f, f1$apr)
}
}
f <- cbind(ff, f)
matplot(z, f, type = "l", xlab = "", ylab = "", main = ttle[i], lty = 1:5,col=1+COL*(0:4),lwd=2)
}
}
}
else if(fig == 4) {
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,vec+4)
matplot(z, mat, type = "l", lty = 1:5,col=1+COL*(0:4),xlab="",ylab="",lwd=3)
}
else if(fig ==5) {
##################
##################
knots<- 100
if(SIM==0){DATA1 <- read.table("Data2.5"); DATA <- as.vector(DATA1);DATA <-DATA[,1]}
setnn <- c(1,101,301);setnnn <- c(100,300,600)
par(mfrow = c(1, 4))
z <- seq(0,1,len=knots)
for(i in 1:4) {
for(j in (1:3)) {
if(SIM==1){X <- rcornerf(cornerf = i, n = set.n[j], CFUN = CFUN)}
else{X <-DATA[(600*(i-1)+setnn[j]):(600*(i-1)+setnnn[j])]}
if(j == 1) {
ff <- estcdenN(X = X,Z=z,cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
}
else {
ff <- cbind(ff, estcdenN(X = X, Z=z, cJ0 = cJ0,
cJ1 = cJ1, cTH = cTH, cB = cB)$fest)
}
}
f <- dcornerf(c = i, Z=z, CFUN = CFUN)
ISE <- apply((ff-f)^2,2,mean)
ISE <- signif(ISE,2)
fff <- cbind(f,ff)
subtitle <- paste(paste(paste("",ISE[1]), paste("",ISE[2]), sep=","), paste("",ISE[3]),sep=",")
matplot(seq(0,1,len=knots), fff, type = "l",
lty = 1:(length(set.n) + 1),col=1+COL*(0:length(set.n)),
xlab = "x", ylab = " ",lwd=2,
main = paste(ttle[i], subtitle,sep="\n"))
}
}#end figure 5
else if(fig == 6) {
if(is.na(n)){n <- 100}
knots <- 200
z <- seq(0,1,len=knots)
if(SIM==0){DATA <- read.table("Data2.6")}
else{DATA <- matrix(-10,ncol=4,nrow=n)}
par(mfrow = c(1, 4))
for(i in 1:4) {
if(SIM==1){X <- rcornerf(cornerf = i, n = n, CFUN = CFUN)
DATA[,i] <- X}
else{X <- DATA[,i]}
fest <- estcdenN(X = X, Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH, cB = cB)$fest
mmm <- hist(X, plot = F, nclass = floor(n/4))$density
f <- dcornerf(c = i, Z=z, CFUN = CFUN)
mmm <- max(c(mmm, fest, f))
hist(X, freq=F, nclass = floor(n/5), xlab = "X",
main = ttle[i], xlim = c(0, 1), ylim = c(0, mmm))
lines(z, fest, type = "l", lty = 2, col = 1+COL,lwd=2)
lines(z, f, type = "l",col=1,lwd=2)
}
if(WRITE){write(t(DATA), file="Data2.6",ncol=4)}
}
else if(fig == 7) {
if(is.na(n)) {n <- 100}
if(is.na(c)) {c <- 1}
nn <- n
par(mfrow = c(1, 4))
z <- seq(0, 1, l = knots)
if(SIM==0){DATA <- read.table("Data2.7")}
else{DATA <- matrix(-10,ncol=8,nrow=n)}
for(i in 1:4) {jj <- 2*(i-1)
if(SIM==1){X <-rgenN(n=n,den=desden,d=dden)
scale <- readf(fun=scalefun,z=X,d=dscale)
f <- dcornerf(c = i, Z = X, CFUN = CFUN)
Y <- f + sigma*scale* rnorm(nn)
if(WRITE){DATA[,c(jj+1,jj+2)] <- cbind(X,Y)}}
else{X <- DATA[,jj+1];Y <-DATA[,jj+2]}
fest <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,c = c)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
f <- dcornerf(c=i,Z=z,CFUN=CFUN)
fM <- cbind(f,fest)
ISE <- signif(mean((f-fest)^2),2)
llim <- range(fM)
llim <- range(c(llim, range(Y)))
matplot(z, fM, type = "l", lty = 1:2,col=c(1,1+COL),
xlab ="X",
ylab = "Y",
main = paste(ttleN[i],paste("ISE = ", ISE), sep=", "),
ylim = llim,lwd=2)
lines(X, Y, type = "p", pch = 1)
}
if(WRITE){write(t(DATA), file="Data2.7",ncol=8)}
}
else if(fig == 8) {
if(is.na(n)) {n <- 100}
if(is.na(c)) {c <- 1}
par(mfrow = c(4, 1))
z <- seq(0, 1, len = knots)
if(SIM==0){DATA <- read.table("Data2.8")}
else{DATA <- matrix(-10,ncol=8,nrow=n)}
for(i in 1:4){jj <- 2*(i-1)
f <- dcornerf(c = i, Z=z, CFUN = CFUN)
f <- f/max(f);if(i==1){f <- rep(3/4,knots)}
if(SIM==1){ X <-rgenN(n=n,den=desden,d=dden)
ff <- dcornerf(c = i, Z = X, CFUN = CFUN)
ff <- ff/max(f)
if(i == 1) {ff <- ((3/4) * ff)/ff}
U <- runif(n)
Y <- rep(1, n)
Y[U > ff] <- 0
if(WRITE){DATA[,c(jj+1,jj+2)] <- cbind(X,Y)}}
else{X <- DATA[,jj+1];Y <-DATA[,jj+2]}
fest <- estcregN(X = X, Y = Y, Z=z,cJ0 = cJ0, cJ1=cJ1,cTH = cTH,cB = cB,c=1)$fest
fest[fest > 1] <- 1
fest[fest < 0] <- 0
fM <- cbind(f,fest)
ISE <- signif(mean((f-fest)^2),2)
llim=c(-.05,1.05)
matplot(z, fM, type = "l", lty = 1:2,col=c(1,1+COL),
xlab = "X", ylab = "A",
main = paste(ttle[i]," Bernoulli Regression, ISE = ",ISE),
ylim = llim, lwd=2)
lines(X, Y, type = "p", pch = 1)
}
if(WRITE){write(t(DATA), file="Data2.8",ncol=8)}
}
else if(fig == 9) {
if(is.na(n)){n <- 100}
if(SIM==0){DATA <- read.table("Data2.9")}
else{DATA <- matrix(-10,ncol=4,nrow=n)}
z <- seq(0, 1, len = knots1)
c1.mat <- c(c11, c21)
c2.mat <- c(c12, c22)
par(mfcol = c(3, 2))
for(j in 1:2) {jj <- 2*(j-1)
c1 <- c1.mat[j]
c2 <- c2.mat[j]
if(SIM==1){
X1 <- rcornerf(c = c1, n = n, CFUN = CFUN)
X2 <- rcornerf(c = c2, n = n, CFUN =CFUN)
if(WRITE==T){DATA[,c(jj+1,jj+2)] <- cbind(X1,X2)}}
else{X1 <- DATA[,jj+1];X2 <- DATA[,jj+2]}
f.est <- estcden2dimN(X1 = X1, X2 = X2, knots = knots1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH, cB = cB)
plot(X2,X1,xlab="X2",ylab="X1",main="Data")
f <- outer(dcornerf(c = c1, Z=z, CFUN = CFUN),
dcornerf(c = c2, Z=z, CFUN = CFUN))
theta<-acos(6/sqrt(36+4+900))*180/pi
phi<-acos(30/sqrt(36+4+900))*180/pi +50
r<-sqrt(36+4+900)
persp(z, z, f, xlab = "X1", ylab = "X2", zlab = "",
theta=theta,phi=phi,r=r, box = T,axes=T, ticktype="detailed",nticks=2)
title(main = "Density")
persp(z, z, f.est, xlab = "X1", ylab = "X2", zlab = "",
theta=theta,phi=phi,r=r,box = T,axes=T, ticktype="detailed",nticks=2)
title("Estimate")
}
if(WRITE){write(t(DATA), file="Data2.9",ncol=4)}
}
if(fig==10){
if(is.na(n)){nn <- 200}else{nn <- n}
if(is.na(set.c[1])){set.c <- c(1,2,3,4)}
if(SIM==0){DataM <- read.table("Data2.10")}
else{DataC <- matrix(-99,ncol=4, nrow=nn)}
Z <- seq(0,1,len=knots)
subb <- c("","","",paste("n = ",nn,sep=""))
par(mfrow=c(4,1))
for(k in 1:4) {
if(SIM==0){X <- DataM[,k]}
else{
X <- rcornerf(cornerf = set.c[k], n = nn, CFUN = CFUN)
DataC[,k] <-X
}
estF <-estcdenGEN(X = X, V=1, Z=Z,Zconf=Z, alpha=alpha,
NSimConfInt=100,
theta0=-10,FLAGNEG=0, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
fest <-estF$fest
Margin <- estF$Margin
MarginSim <- estF$MarginSim
f <- dcornerf(c=set.c[k],Z=Z,CFUN=CFUN)
ISE <- signif(mean((f-fest)^2),2)
matplot(Z,cbind(f,fest,fest+Margin,fest-Margin,fest-MarginSim,
fest+MarginSim),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3), lwd=2,
main=paste(ttle[set.c[k]],", ISE = ",ISE),ylab="f",xlab="",sub=subb[k])
if((k==4)&WRITE){write(t(DataC),file="Data2.10",ncol=4)}
}
}
} #end of ch2
#####################################################################
# CHAPTER 3
#####################################################################
##############################################################################
ch3<-function(fig = 1,SIM=1,#a=0.2,b=0.8,USE:estcregm in fig7;estcregs in fig8
dscale=0,dden =0.2,lbden =NA, sigma=NA, COL=1, c=NA, s=NA,
set.B = NA,set.corn =NA, bound.set =NA,a=NA,b=NA,scalefun =2,
muzeta=NA,sdzeta=NA,muxi=NA,sdxi=NA,#scalefun="3-(x-0.5)^2",
set.k=NA,setw.cJ0=NA,setw.cJ1=NA,set.c=NA,
desden="1+0.5*x", w = NA,n = NA, alpha = 0.05,WRITE=FALSE,
set.n = NA, knots=50,
h = NA,c11=1,c12=2,c21=2,c22=3,knots1=20,
CFUN = list(NA, NA),cJ0 = 3, cJ1 = 0.8, cTH = 4,
cB = 2)
{
ttle <- c("Uniform", "Normal", "Bimodal", "Strata")
if(!is.na(CFUN[[2]])) {
ttle[CFUN[[1
]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
else if(is.na(CFUN[[1]]) & is.na(CFUN[[2]]) & fig == 3) {
CFUN <- list(1, "2 - 2*x -sin(8*x)")
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
if(!is.na(CFUN[[2]])) {
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
#####
if(fig == 1) {
if(is.na(set.B)){set.B <- c(.2,.8)}
if(is.na(n)){n <- 100}
par(mfrow = c(1, 4))
knots <- 100; z <- seq(0,1,len=knots);
nn <- n
if(SIM==0){DATA <- read.table("Data3.1")}
if(SIM==1){DATA <- matrix(-10,ncol=4,nrow=nn)
for(i in 1:4) {
Y <- lenb.genN(i=i,Z=z,n=nn,a=set.B[1],b=set.B[2],CFUN=CFUN)
DATA[,i]<- Y$Y
}
if(WRITE){write(t(DATA), file="Data3.1", ncol=4)}
}
for(i in 1:4){
Y <- DATA[,i]
g.Y <- set.B[1] + set.B[2]*Y
hh <- (set.B[1] + set.B[2]*Y)*mean(1/g.Y)
f.est<- estcdenGEN(X =Y, V=1/hh, Z=z, Zconf=z, alpha=0.05, nn=NA, NSimConfInt=50,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB =cB,cTH=cTH)$fest
mmm <- hist(Y, plot = F, nclass = floor(n/4))$density
f <- dcornerf(c = i, Z=z, CFUN = CFUN)
mmm <- max(c(mmm, f.est, f))
hist(Y, freq=F, nclass = floor(n/4), xlab = "X",
main = ttle[i], xlim = c(0, 1), ylim = c(0, mmm))
lines(z, f, type = "l",col=1,lwd=2,ylab="")
lines(z, f.est, type = "l", lty = 2, col =1+COL,lwd=2)
}
}
if(fig==2){
if(is.na(set.B)){set.B <- c(.2,.8)}
if(is.na(n)){n <- 200}
if(is.na(set.corn[1])){set.corn <- c(3,4)}
par(mfrow = c(length(set.corn), 1))
knots <- 100; z <- seq(0,1,len=knots);
nn <- n
if(SIM==0){DATA <- read.table("Data3.2")}
if(SIM==1){DATA <- matrix(-10,ncol= length(set.corn),nrow=nn)
for(i in 1:length(set.corn)) {
Y <- lenb.genN(i=set.corn[i],Z=z,n=nn,a=set.B[1],b=set.B[2],CFUN=CFUN)
DATA[,i]<- Y$Y
}
if(WRITE){write(t(DATA), file="Data3.2", ncol=length(set.corn))}
}
for(i in 1:length(set.corn)){
if(i==1){ttle="Histogram of X, E-estimate and Confidence Bands"}
else{ttle=""}
Y <- DATA[,i]
g.Y <- set.B[1] + set.B[2]*Y
hh <- (set.B[1] + set.B[2]*Y)*mean(1/g.Y)
f <- dcornerf(c=set.corn[i],Z=z,CFUN=CFUN)
f.estF<- estcdenGEN(X =Y, V=1/hh, Z=z, Zconf=z, alpha=0.05, nn=NA, NSimConfInt=50,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB =cB,cTH=cTH)
f.est <- f.estF$fest
Margin <- f.estF$Margin
MarginSim <- f.estF$MarginSim
ISEM <- signif(mean((f-f.est)^2),2)
d.est <- mean((1/hh)^2)
f.estN<- estcdenGEN(X =Y, V=1, Z=z, Zconf=z, alpha=0.05, nn=NA, NSimConfInt=50,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB =cB,cTH=cTH)
f.estN <- f.estN$fest
mmm <- hist(Y, plot = F, nclass = floor(n/10))$density
mmm <- max(c(mmm,f.est+MarginSim, f))
hist(Y, freq=F, nclass = floor(n/4),
xlab=substitute(paste("ISE = ",aa,", "," ", hat(d)," = ",bb,", n = ",cc),
list(aa=ISEM,bb=signif(d.est,2),cc=nn)),
main =ttle ,
xlim = c(0, 1), ylim = c(0, mmm))
lines(z, f, type = "l",col=1,lwd=2,ylab="")
lines(z, f.est, type = "l", lty = 2, col =1+COL,lwd=2)
lines(z, f.est-Margin, type = "l", lty = 3, col =1+2*COL,lwd=2)
lines(z, f.est+Margin, type = "l", lty = 3, col =1+2*COL,lwd=2)
lines(z, f.est-MarginSim, type = "l", lty = 4, col =1+3*COL,lwd=2)
lines(z, f.est+MarginSim, type = "l", lty = 4, col =1+3*COL,lwd=2)
}
}
if(fig==3){
if(is.na(set.B[1])){set.B <- c(.3,.5,2)}
if(is.na(n)){n <- 100}; if(is.na(c)){c <- 1}
if(is.na(set.corn[1])){set.corn <- c(1,2)}
if(is.na(sigma)){sigma <- 1}
par(mfrow = c(length(set.corn),1))
knots <- 100; z <- seq(0,1,len=knots);
nn <- n
if(SIM==0){DATA <- read.table("Data3.3")}
if(SIM==1){DATA <- matrix(-10,ncol= 2*length(set.corn),nrow=nn)
for(i in 1:length(set.corn)) {
corn <- set.corn[i]
X <- sort(runif(nn))
mX <- dcornerf(c=set.corn[i],Z=X)+3*sigma
FF <- lenbCOND.genN(X=X, mX=mX,a1=set.B[1],a2=set.B[2],a3=set.B[3],sigma=sigma)
V <- FF$V
DATA[,2*i-1]<- X; DATA[,2*i] <- V
}
if(WRITE){write(t(DATA), file="Data3.3", ncol=2*length(set.corn))}
}
ttl2 <-paste("Regression with Biased Responses")
for(i in 1:length(set.corn)){
X <- DATA[,2*i-1]
V <- DATA[,2*i]
mX <- dcornerf(c=set.corn[i],Z=X)+3*sigma
BXYdmu <- (set.B[1]+set.B[2]*X + set.B[3]*V)/(set.B[1]+set.B[2]*X + set.B[3]*mX)
mu.est <- 1/estcregN(X =X, Y=1/(set.B[1]+set.B[2]*X+set.B[3]*V),Z=X, c=c,
cJ0 = cJ0, cJ1 = cJ1,cTH= cTH,cB = cB)$fest
BXYscaled <- (set.B[1]+set.B[2]*X+set.B[3]*V)/mu.est
#Diagram 1
DX <- (set.B[1]+set.B[2]*X + set.B[3]*mX); DX.est <- mu.est
mN.est <-estcregN(X =X, Y=V,Z=z, cJ0 = cJ0, c=c,cJ1 = cJ1,cTH= cTH,cB = cB)$fest
m.est <- estcregN(X=X, Y =V,V=1/BXYdmu,p=NA,Z=z,FLAGSUBTR=1,c=c,
cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH,FLAGNEG=0)$fest
ISEM <- signif(mean((dcornerf(c=set.corn[i],Z=z)+3*sigma-m.est)^2),2)
ISEN <- signif(mean((dcornerf(c=set.corn[i],Z=z)+3*sigma-mN.est)^2),2)
#Diagram 2
matplot(z,cbind(dcornerf(c=set.corn[i],Z=z)+3*sigma,
m.est,mN.est), type="l",lwd=2,
ylim=c(min(c(BXYdmu,V)),max(V)),
col=c(1,1+COL,1+2*COL),
main=paste("Biased Responses, n = ",nn, ", ISE = ",ISEM,", ISEN = ",ISEN),xlab="X",ylab="Y")
points(X,V,type="p",pch=1)
}
}
#####################
if(fig==4){
if(is.na(set.B[1])){set.B <- c(.2,0.5,1)}
if(is.na(n)){n <- 100}; if(is.na(c)){c <- 1}
if(is.na(set.corn[1])){set.corn <- c(1,2)}
if(is.na(sigma)){sigma <- .5}
nn <- n
par(mfcol = c(3,length(set.corn)))
knots <- 100; z <- seq(0,1,len=knots);
if(SIM==0){DATA <- read.table("Data3.4")}
if(SIM==1){DATA <- matrix(-10,ncol= 4*length(set.corn),nrow=nn)
for(i in 1:length(set.corn)) {
corn <- set.corn[i]
FLAG <- 1; XY <- matrix(-10,ncol=2,nrow=1)
while(FLAG==1){
X <- runif(2*nn)
mX <- dcornerf(c=set.corn[i],Z=X)+3*sigma; maxmX <- max(mX)
Y <- mX + sigma*rnorm(2*nn)
XYC <- cbind(X,Y)
BXYbound <-(set.B[1] + set.B[2]*X + set.B[3]*Y)/
(set.B[1] + set.B[2] +set.B[3]*(maxmX+4*sigma))
BXYbound[BXYbound > 1] <- 1;BXYbound[BXYbound < 0] <- 0
A <- rbinom(2*nn,size=1,BXYbound)
XY <- rbind(XY,XYC[A==1,])
if(nrow(XY) > nn){XY <- XY[-1,]; XY <- XY[1:nn,]; FLAG <- 0}
}
jj <- 4*(i-1)
DATA[,c(jj+1,jj+2)]<- XY
XU <- runif(nn)
mXU <- dcornerf(c=set.corn[i],Z=XU)+3*sigma
YU <- mXU + sigma*rnorm(nn)
DATA[,c(jj+3,jj+4)] <- cbind(XU,YU)
}
if(WRITE){write(t(DATA), file="Data3.4", ncol=4*length(set.corn))}
}
ttl2 <-paste("Biased Predictors and Responses")
for(i in 1:length(set.corn)){
jj <- 4*(i-1)
X <- DATA[,jj+1]
Y <- DATA[,jj+2]
XU <-DATA[,jj+3]
YU <-DATA[,jj+4]
mX <- dcornerf(c=set.corn[i],Z=X)+3*sigma
BXY <- set.B[1]+set.B[2]*X + set.B[3]*Y
BX.est <- estcregN(X =X, Y=1/BXY,Z=X,c=c,cJ0 = cJ0, cJ1 = cJ1,cTH= cTH,cB = cB)$fest
B <- 1/mean(1/BXY)
#Diagram 1 Regression
mN.est <-estcregN(X =X, Y=Y,Z=z, c=c,cJ0 = cJ0, cJ1 = cJ1,cTH= cTH,cB = cB)$fest
m.est <- estcregN(X=X, Y =Y,V=1/(BXY*BX.est),p=NA,Z=z,FLAGSUBTR=1,c=c,
cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH,FLAGNEG=0)$fest
ISEM <- signif(mean((dcornerf(c=set.corn[i],Z=z)+3*sigma-m.est)^2),2)
ISEN <- signif(mean((dcornerf(c=set.corn[i],Z=z)+3*sigma-mN.est)^2),2)
matplot(z,cbind(dcornerf(c=set.corn[i],Z=z)+3*sigma,m.est,mN.est),
type="l",lwd=2,ylim=c(min(Y),max(Y)),
col=c(1,1+COL,1+2*COL), main=ttl2, xlab="X",
sub=paste("n = ", nn, ", ISE = ",ISEM,", ISEN = ",ISEN),ylab="Y")
points(X,Y,type="p",pch=1)
#Diagram 2 Density of X
fXU.est<- estcdenGEN(X =XU, V=1, Z=z, Zconf=z, alpha=0.05, nn=NA, NSimConfInt=50,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB =cB,cTH=cTH)$fest
YSCU <- (YU-min(YU))/(max(YU) - min(YU))
fYU.est<- estcdenGEN(X =YSCU, V=1, Z=z, Zconf=z, alpha=0.05, nn=NA, NSimConfInt=50,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB =cB,cTH=cTH)$fest/(max(YU) - min(YU))
fX.estF<- estcdenGEN(X =X, V=B*BX.est, Z=z, Zconf=z, alpha=0.05, nn=NA, NSimConfInt=50,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB =cB,cTH=cTH)
fX.est <- fX.estF$fest
mm <- hist(X, plot = F, nclass = floor(n/10))$density
hist(X, freq=F, nclass = floor(n/10),xlab="X", main ="Density of Predictor")
lines(z, fX.est, type = "l", lty = 2, col =1+2*COL,lwd=2)
lines(z, fXU.est, type = "l", lty = 1, col =1+COL,lwd=2)
#Diagram 3 Density of Y
YSC <- (Y-min(Y))/(max(Y) - min(Y))
BY.est <- estcregN(X =YSC, Y=1/BXY,Z=YSC,cJ0 = cJ0, cJ1 = cJ1,cTH= cTH,cB = cB)$fest
fY.estF<- estcdenGEN(X =YSC, V=B*BY.est, Z=z, Zconf=z, alpha=0.05, nn=NA, NSimConfInt=50,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB =cB,cTH=cTH)
fY.est <- fY.estF$fest
fY.est <- fY.est/(max(Y) - min(Y))
mm <- hist(Y, plot = F, nclass = floor(n/10))$density
mmm <- max(c(mm,fY.est,fYU.est))
hist(Y, freq=F, nclass = floor(n/10),xlab="Y",xlim=c(min(c(Y,YU)),max(c(Y,YU))),
ylim=c(0,mmm), main ="Density of Response")
lines(seq(min(Y),max(Y),len=knots), fY.est, type = "l", lty = 2, col =1+2*COL,lwd=2)
lines(seq(min(YU),max(YU),len=knots), fYU.est, type = "l", lty = 1, col =1+COL,lwd=2)
}
}
else if(fig == 5) {
if(is.na(n)) {n <- 30}
if(is.na(set.corn)){set.corn <- 3}
if(is.na(sigma)){sigma <- 1}
if(is.na(bound.set)){bound.set <- c(-50, -1, 1, 3, 50)}
nn <- n
par(mfrow = c(1, 2))
if(SIM==0){DATA <- read.table("Data3.5");X <- DATA[,1];Y <-DATA[,2];Y1 <-DATA[,3]}
if(SIM==1){DATA <- matrix(-10,ncol= 3,nrow=nn)
X <- runif(nn)
Y1 <- dcornerf(c = set.corn, Z = X, CFUN = CFUN) + sigma * rnorm(nn)
Y <- 0 * Y1
m <- length(bound.set) - 1
for(i in 1:m) {
Y[bound.set[i] <= Y1 & Y1 < bound.set[i + 1]] <- i
}
DATA <- cbind(X,Y,Y1)
if(WRITE){write(t(DATA), file="Data3.5", ncol=3)}
}
plot(X, Y1, type = "p", xlab = "X", ylab = expression(Y^"*"),
pch=1, main = "Hidden 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,lwd=2)
}
plot(seq(0, 1, len = 10), seq(0, 4, len = 10), type = "n", lwd=2,#yaxp = c(-2, 4, 7),
xlab = "X", ylab = "Y", main = "Observed Data", xlim = c(0, 1),)
if(sum(Y==1) > 0){text(X[Y == 1], rep(1, length(X[Y == 1])), labels = "1")}
if(sum(Y==2) > 0){text(X[Y == 2], rep(2, length(X[Y == 2])), labels = "2")}
if(sum(Y==3) > 0){text(X[Y == 3], rep(3, length(X[Y == 3])), labels = "3")}
if(sum(Y==4) > 0){text(X[Y == 4], rep(4, length(X[Y == 4])), labels = "4")}
}
else if(fig == 6) {
if(is.na(n)) {n <- 100}
if(is.na(set.corn)){set.corn <- c(2,3)}
if(is.na(sigma)){sigma <- 1}
if(is.na(bound.set)){bound.set <- c(-50, -1, 1, 3, 50)}
if(is.na(a)){a <- .005}
if(is.na(b)){b <- .995}
nn <- n
par(mfcol = c(2,length(set.corn)))
knots <- 50
z <- seq(0, 1, len = knots)
if(SIM==1){DATA <- matrix(-10,ncol= 2*length(set.corn),nrow=nn)}
if(SIM==0){DATA <- read.table("Data3.6")}
for(i in (1:length(set.corn))) {
jj <- 2*(i-1)
if(i==1){ttl <- "Regression for Grouped Responses"}
else{ttl <- ""}
if(SIM==1){
X <-runif(nn)
Y1 <- dcornerf(c = set.corn[i], Z = X, CFUN = CFUN) + sigma * rnorm(nn)
Y <- 0 * Y1
m <- length(bound.set) - 1
for(j in 1:m) {Y[bound.set[j] <= Y1 & Y1 < bound.set[j + 1]] <- j}
DATA[,c(jj+1,jj+2)] <- cbind(X,Y)
if((i==length(set.corn))&WRITE)
{write(t(DATA), file="Data3.6", ncol=2*length(set.corn))}
}
X <- DATA[,jj+1]
Y <-DATA[,jj+2]
est <- estcregcat(X = X, Y = Y, method = 4, bound.set = bound.set,
knots = knots, a = a, b = b, s0 = .5, s1 = .5,
cJ0 = cJ0, cJ1 = cJ1, cJM = 6, cT = 4,r= 2, cB = cB)
est.f1 <- est$f.pilot1
est.prob <- est$est.prob
est1 <- negden(est.f1, FLAGBUMP = 1, cB = cB)
plot(seq(0, 1, len = 10), seq(0, 4, len = 10), type = "n", lwd=2,#yaxp = c(-2, 4, 7),
xlab = "X", ylab = "Y", main = "Observed Data", xlim = c(0, 1),)
if(sum(Y==1) > 0){text(X[Y == 1], rep(1, length(X[Y == 1])), labels = "1")}
if(sum(Y==2) > 0){text(X[Y == 2], rep(2, length(X[Y == 2])), labels = "2")}
if(sum(Y==3) > 0){text(X[Y == 3], rep(3, length(X[Y == 3])), labels = "3")}
if(sum(Y==4) > 0){text(X[Y == 4], rep(4, length(X[Y == 4])), labels = "4")}
matplot(z, cbind(dcornerf(c = set.corn[i], Z=z, CFUN = CFUN), est1, est.prob),
type = "l", lty=1:3,
col=c(1,1+COL,1+2*COL), xlab = "x", ylab = " ", main ="Estimates",lwd=2)
}
}
if(fig == 7) {
if(is.na(n)){n <- 100}
if(is.na(muzeta)){muzeta <- 0}
if(is.na(sdzeta)){sdzeta <- 0.9}
if(is.na(muxi)){muxi <- 1}
if(is.na(sdxi)){sdxi <- 0.6}
if(is.na(set.corn)){set.corn <- c(2,3)}
nn <- n
par(mfrow = c(2, 1))
if(WRITE){DATA <- matrix(-10,ncol= length(set.corn),nrow=nn)}
if(SIM==0){DATA <- read.table("Data3.7")}
for(i in 1:length(set.corn)) {
X <- seq(0, 1, len = nn)
ff <- dcornerf(c = set.corn[i], Z = X, CFUN = CFUN)/
max(dcornerf(c = set.corn[i], Z = X, CFUN = CFUN))
if(set.corn[i] == 1) {
ff <- ((3/4) * ff)/ff
}
eta <- rnorm(nn, mean = muzeta, sd = sdzeta)
xi <- rnorm(nn, mean = muxi, sd = sdxi)
Y <- rep(0, nn)
Y[runif(nn) < ff] <- 1
Z <- eta * Y + (1 - Y) * xi
if(SIM==0){Z <- DATA[,i]}
Zsc <- (Z - muxi)/(muzeta - muxi)
est <- estcregm(X = X, Y = Zsc, method = 4, s0 =.5, s1 = .5, cJ0 = cJ0, cJ1 = cJ1, cJM = 6, cT = 4, r = 2, knots=nn)
est <- negden(est, FLAGBUMP = 1, cB = cB)
est[est > 1] <- 1
llim <- range(est)
llim <- range(c(llim, range(Z)))
ttle <- ""
if(i==1){ttle <- paste("Mixtures Regression, n = ",nn)}
matplot(X, cbind(ff,est), type = "l", lty=1:2, lwd=2,
col=c(1,1+COL),xlab = "X", ylab = "Z",main=ttle,ylim = llim)
lines(X, Z, type = "p", pch =1) #19)
if(WRITE){DATA[,i] <- Z
if(i==length(set.corn))
{write(t(DATA), file="Data3.7", ncol=length(set.corn))}
}
}
}
if(fig == 8) {
if(is.na(n)){n <- 100}
if(is.na(set.corn)){set.corn <- c(2,3)}
if(is.na(sigma)){sigma <- 1}
if(is.na(scalefun)){scalefun <- 2}
if(is.na(s)){s <- 0.3}
DDATA <- "Data3.8"
nn <- n
par(mfrow = c(length(set.corn), 1))
z <- seq(0, 1, l = knots)
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 2*length(set.corn),nrow=nn)}
for(i in 1:length(set.corn)) {
jj <- i-1
if(SIM==1){
X <- runif(nn)
ff <- dcornerf(c = set.corn[i], Z = X, CFUN = CFUN)
Y <- ff + sigma * (s+dcornerf(c = scalefun, Z = X,CFUN=CFUN)) * rnorm(nn)
DATA[,c(2*jj+1,2*jj+2)] <- cbind(X,Y)
if(i==length(set.corn)&WRITE){write(t(DATA), file=DDATA, ncol=2*length(set.corn))}
}
X <- DATA[,2*jj+1]; Y <- DATA[,2*jj+2]
f.est <- estcregs(X = X, Y = Y, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = 6, cT = 4,
method = 4, s0 = .5, s1 = .5, r = 2, cB = 2)
f <- s+dcornerf(c = scalefun, Z=z, CFUN = CFUN)
llim <- range(f)
llim <- range(c(llim, range(Y)))
if(i==1){ttle=paste("Estimation of Scale Function, n = ",nn,", s = ",s)}
else{ttle=""}
mf <- dcornerf(c = set.corn[i], Z = z, CFUN = CFUN) #underlying regression
m.est <- estcregN(X=X, Y =Y,p=NA,Z=z,FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH,FLAGNEG=0)$fest
matplot(z, cbind(f,f.est,mf,m.est), type = "l", lty = 1:4, col=c(1,1+COL,1+2*COL,1+3*COL),
lwd=2, xlab = "X", ylab = "Y", main = ttle, ylim = llim)
points(X, Y, pch =1) # 19)
}
}
####################
if(fig == 9){
if(is.na(n)){n <- 100} ; if(is.na(c)){ c <- 1}
if(is.na(set.k[1])){set.k =c(30,30,50,50)}
if(is.na(cTH)){cTH <- 4}
if(is.na(setw.cJ0[1])){setw.cJ0 <-c(3,3,3,3)}
if(is.na(setw.cJ1[1])){setw.cJ1 <-c(.3,.3,.3,.3)}
if(is.na(lbden)){lbden <- 1}
TTL <- c("Uniform ", "Normal ", "Bimodal ", "Strata ")
par(mfrow = c(length(set.k), 2))
z <- seq(0, 1, len = knots)
if(SIM==0){DataC <- read.table("Data3.9")
DataE <- list(DE1 =scan("Data3.9E1"),
DE2 =scan("Data3.9E2"),
DE3 =scan("Data3.9E3"),
DE4 =scan("Data3.9E4"))
}
for(i in 1:4){
if(SIM==1){
XE <-rgenN(n=set.k[i],den=desden,d=dden)
X <- rgenN(n=n,den=desden,d=dden)
ff <- dcornerf(c = i, Z = X, CFUN = CFUN)
ff <- ff/max(ff)
if(i == 1) {ff <- ((3/4) * ff)/ff}
U <- runif(n)
A <- rep(1, n)
A[U > ff] <- 0
if(i==1){M <- cbind(X,A); ME1 <- XE }
else{M <- cbind(M,X,A)
if(i==2){ME2 <- XE}
else if(i==3){ME3 <- XE}
else if(i==4){ME4 <- XE
if(WRITE){write(t(M),file="Data3.9",ncol=8)
write(ME1,file="Data3.9E1",ncol=1)
write(ME2,file="Data3.9E2",ncol=1)
write(ME3,file="Data3.9E3",ncol=1)
write(ME4,file="Data3.9E4",ncol=1)}
}
}
}
else{X <-DataC[,2*i-1]; A <-DataC[,2*i]; XE <- DataE[[i]]}
f <- dcornerf(c = i, Z=z, CFUN = CFUN)
f <- f/max(f)
if(i == 1) {f <- rep(3/4,knots)}
#Diagram 1
XA <- X[A==1]
x <- XA
pX <- readf(fun=desden,d=dden,z=XA)
p.est <- estcdenN(X = XE,Z=XA, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH,
cB = cB)$fest
p.est[p.est < dden] <- dden
pM <- cbind(pX,p.est)
llim <- range(pM)
mmm<- hist(XE, plot=F, nclass = floor(length(XE)/4))$density
mmm <- range(c(mmm,llim))
hist(XE, freq=F, nclass = floor(length(XE)/4),
main =paste("Density of E-Sample, k = ",length(XE)),
xlim =c(0,1), ylim = mmm,xlab=expression(X^"*"),ylab="")
points(XA,pX,type="p",pch=1,col=1+COL*1)
points(XA,p.est,type="p",pch=4,col=1+COL*2)
#Diagram 2
f.est <- estcregNGen(X=XA, Y =A[A==1],Z=XA,nT=length(A),
p=as.vector(p.est), Density=F,cJ0 = setw.cJ0[i],
cJ1 = setw.cJ1[i], cB = cB,cTH=cTH,FLAGNEG=0)$fest
f.est[f.est > 1] <- 1
f.est[f.est < c/log(length(A)+20)] <- c/log(length(A) + 20)
mmm <- range(c(0,1.1,f.est))
plot(XA,rep(1,sum(A)), ylim=mmm,
type="p", main=paste(TTL[i],"Regression,",
paste(paste(" n = ",n),paste(" N = ",sum(A)),sep=", ")),
xlab="X",ylab=expression(A^"*"))
points(XA,f.est,pch=4,col=1+COL)
f.or <- estcregN(X = X, Y = A, Z=z, cJ0 = cJ0, cJ1 =cJ1, cTH = cTH,cB = cB)$fest
f.or[f.or > 1] <- 1
f.or[f.or < 0] <- 0
lines(z,f.or,type="l", lty=2,lwd=2,col=1+COL*2)
lines(z,f,type="l",lty=1,lwd=2, col=1+COL*3)
}
} #end Fig9
if(fig == 10) {
if(is.na(n)){n <- 100}; if(is.na(c)){ c <- 1}
if(is.na(sigma)){sigma <- 2}
if(is.na(set.k[1])){set.k =c(30,30,50,50)}
if(is.na(cTH)){cTH <- 4}
if(is.na(setw.cJ0[1])){setw.cJ0 <-c(3,3,3,3)}
if(is.na(setw.cJ1[1])){setw.cJ1 <-c(.3,.3,.3,.3)}
if(is.na(lbden)){lbden <- 1}
par(mfrow = c(length(set.k), 2))
z <- seq(0, 1, len = knots)
if(SIM==0){DataC <- read.table("Data3.10")
DataE <- list(DE1 =scan("Data3.10E1"),
DE2 =scan("Data3.10E2"),
DE3 =scan("Data3.10E3"),
DE4 =scan("Data3.10E4"))
}
for(i in 1:4){
if(SIM==1){
XE <-rnorm(n=set.k[i],sd=sigma)
X <- rnorm(n=n,sd=sigma)
x <- X
if(is.na(w)){w <- ".2+.8*exp(1+2*x)/(1+exp(1+2*x))"}
eval(parse(text=paste("wX <- ",w)))
A <-rbinom(n,1,wX)
if(i==1){M <- cbind(X,A); ME1 <- XE }
else{M <- cbind(M,X,A)
if(i==2){ME2 <- XE}
else if(i==3){ME3 <- XE}
else if(i==4){ME4 <- XE
if(WRITE){
write(t(M),file="Data3.10",ncol=8)
write(ME1,file="Data3.10E1",ncol=1)
write(ME2,file="Data3.10E2",ncol=1)
write(ME3,file="Data3.10E3",ncol=1)
write(ME4,file="Data3.10E4",ncol=1)}
}
}
}
else{X <-DataC[,2*i-1]; A <-DataC[,2*i]; XE <- DataE[[i]]
x <- X
if(is.na(w)) {w <- ".2+.8*exp(1+2*x)/(1+exp(1+2*x))" }}
x <- X[A==1]
eval(parse(text=paste("wXA <- ",w)))
#Diagram 1
XA <- X[A==1]
rXT <-range(c(XA,XE))
XESC <- (XE - rXT[1])/(rXT[2]-rXT[1])
XASC <- (XA - rXT[1])/(rXT[2]-rXT[1])
p.est <- estcdenN(X = XESC,Z=XASC, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH,
cB = cB)$fest
p.est[p.est < c/log(length(A)+20)] <- c/log(length(A)+20)
pXA <-dnorm(XA,sd=sigma)
pM <- cbind(pXA,p.est/(rXT[2]-rXT[1]))
llim <- range(pM)
mmm<- hist(XE, plot=F, nclass = floor(length(XE)/4))$density
mmm <- range(c(mmm,llim))
hist(XE, freq=F, nclass = floor(length(XE)/4),xlim=rXT,
main =paste("Density of E-Sample,",paste("k = ",length(XE),sep="")," "),
ylim = mmm,xlab=expression(X^"*"),ylab="")
points(XA,pM[,1],type="p",pch=1,col=1+COL*1)
points(XA,pM[,2],type="p",pch=4,col=1+COL*2)
#Diagram 2
w.est <- estcregNGen(X=XASC, Y =A[A==1],Z=XASC,nT=length(A),
p=as.vector(p.est), Density=F,cJ0 = setw.cJ0[i],
cJ1 = setw.cJ1[i], cB = cB,cTH=cTH,FLAGNEG=0)$fest
w.est[w.est > 1] <- 1
w.est[w.est < c/log(length(A)+20)] <- c/log(length(A) + 20)
mmm <- range(c(0,1.1,w.est))
matplot(XA,cbind(rep(1,sum(A)),wXA,w.est), ylim=mmm,
type="p", main=paste(paste("n = ", n,sep=""),paste("N = ",sum(A),sep=""),sep=", "),
xlab="X",ylab=expression(A^"*"), pch=c(2,1,4),col=1+COL*(0:2))
wO.est <- estcregN(X=(X -min(X))/(max(X)-min(X)), Y =A,
Z=(XA -min(X))/(max(X)-min(X)),
cJ0 = setw.cJ0[i],cJ1 = setw.cJ1[i], cB = cB,cTH=cTH,FLAGNEG=0)$fest
wO.est[wO.est > 1] <- 1
}
}
}#end of ch3
##################################
##########################################################
#
## CHAPTER 4
#
############################################################
############################################################
ch4<-function(fig = 1,w=NA, corn=NA,cornset.c=NA, set.n=NA,n=NA,nsim=NA,
sigmaN=.5, cS=4, set.c =NA, set.corn =NA,beta=NA,t=NA,
a=0.2,b=0.8, dscale=0,sigma=NA,c=NA, SIM=1,WRITE=F,COL=1,
mx="2*x", scalefun=NA,set.scalefun=NA,
desden=NA,
dden=0.2,
dwL=NA,dwU=NA,
knots=100,
CFUN = list(NA, NA),cJ0 = NA, cJ1 = NA, cTH = NA,
cB = 2,
c11=1,c12=2,c21=2,c22=3,knots1=20,knots4 =30)
{
ttle <- c("Uniform", "Normal", "Bimodal",
"Strata")
if(!is.na(CFUN[[2]])) {
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
else if(is.na(CFUN[[1]]) & is.na(CFUN[[2]]) & fig == 3) {
CFUN <- list(1, "2 - 2*x -sin(8*x)")
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
if(!is.na(CFUN[[2]])) {
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
if(fig == 1) {
if(is.na(set.n[1])){set.n=c(50,75)}
if(is.na(set.c[1])){set.c=c(2,3)}
if(is.na(w)){w <- 0.7}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
z <- seq(0,1,len=knots)
if(SIM==0){ DATA <- read.table("Data4.1")
X1 <-DATA[,1];X1 <- X1[1:set.n[1]];XA1 <- DATA[,2];XA1 <- XA1[XA1 !=-10]
X2 <-DATA[,3];X2 <- X2[1:set.n[2]];XA2 <- DATA[,4];XA2 <- XA2[XA2 !=-10]}
else{DATA <- matrix(-10,ncol=4,nrow=max(set.n))}
par(mfcol = c(4, 1))
for(i in 1:2) {
n <- set.n[i]
jj <- 2*(i-1)
if(SIM==0){if(i==1){X <- X1;XA <-XA1}
if(i==2){X <- X2;XA <- XA2}}
if(SIM==1){
X <- rcornerf(cornerf = set.c[i], n = set.n[i], CFUN = CFUN)
A <-rbinom(set.n[i],1,w)
XA <- X[A==1]
if(WRITE){
DATA[1:length(X),jj+1] <- X; DATA[1:length(XA),jj+2] <- XA
if(i==2){write(t(DATA), file="Data4.1",ncol=4)}
}
}
festM <- estcdenN(X = XA,Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH, cB = cB)$fest
festH <- estcdenN(X = X, Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH, cB = cB)$fest
plot(X,rep(1,length(X)),type="p",pch=1, xlab="X",ylab="A", ylim=c(-.1,1.2),
main=paste(ttle[set.c[i]],paste(paste("n = ",set.n[i],sep=""),paste("N = ",length(XA),sep=" "),sep=", " ),sep=", "))
points(XA,rep(0,length(XA)),pch=4)
f <- dcornerf(c = set.c[i], Z=z, CFUN = CFUN)
ISEH <- signif(mean((f-festH)^2),2)
ISEM <- signif(mean((f-festM)^2),2)
matplot(z, cbind(f,festM,festH),type = "l",col=c(1,1+COL,1+2*COL),
lwd=2, xlab="x",ylab="",
main=paste(paste("ISEH = ",ISEH,sep=" "),paste("ISEM = ",ISEM,sep=" "),
sep=", "))
}
}
if(fig == 2) {
if(is.na(nsim)){nsim <- 400}
if(is.na(n)){n <- 100}
if(is.na(corn)){corn <- 3}
if(is.na(w)){w <- 0.7}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
z <- seq(0,1,len=knots)
nM <- ceiling(n/w)
MAT <- rep(-100,nsim)
f <- dcornerf(c = corn, Z=z, CFUN = CFUN)
#SIMULATIONS
for(k in (1:nsim)){
XA <- rcornerf(cornerf = corn, n = nM, CFUN = CFUN)
X <- XA[1:n]
A <-rbinom(nM,1,w)
XA <- XA[A==1]
festM <- estcdenN(X = XA,Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH, cB = cB)$fest
festH <- estcdenN(X = X, Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH, cB = cB)$fest
ISEH <- signif(mean((f-festH)^2),2)
ISEM <- signif(mean((f-festM)^2),2)
MAT[k] <- ISEH/ISEM
}
#ENDSIMULATIONS
par(mfcol = c(4, 1))
for(i in 1:3) {
XA <- rcornerf(cornerf = corn, n = nM, CFUN = CFUN)
X <- XA[1:n]
A <-rbinom(nM,1,w)
XA <- XA[A==1]
festM <- estcdenN(X = XA,Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH, cB = cB)$fest
festH <- estcdenN(X = X, Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH, cB = cB)$fest
ISEH <- signif(mean((f-festH)^2),2)
ISEM <- signif(mean((f-festM)^2),2)
if(i==1){
ttle <- paste("ISEH = ",ISEH,", ISEM = ",ISEM,", n = ",n, ", k = ", nM)
}
else{ttle <- paste("ISEH = ",ISEH, ", ISEM = ",
ISEM,sep=" ")
ssub <-""}
matplot(z, cbind(f,festH,festM),type = "l",col=c(1,1+COL,1+2*COL),
lwd=2, xlab="x",ylab="",main=ttle)
}
#last diagram
mmin <- min(MAT); mmax <- max(MAT)
MATSC <- (MAT-mmin)/(mmax-mmin)
fest <- estcdenN(X =MATSC ,Z=seq(mmin,mmax,len=knots),
cJ0 = cJ0, cJ1 = cJ1,cTH = cTH, cB = cB)$fest
fest <- fest/(mmax-mmin)
hist(MAT,breaks=nsim/5,main=paste("Mean(ISEH/ISEM) = ",signif(mean(MAT),3),
", Median(ISEH/ISEM) = ",signif(median(MAT),3),", nsim = ",nsim),
xlab="ISEH/ISEM")
}
######
if(fig == 3) {
if(is.na(n)){n <- 100}
set.n <- c(n,n)
if(is.na(set.c[1])){set.c=c(2,3)}; if(is.na(c)){c <- 1}
if(is.na(w[1])){w ="1-.4*x"}
if(is.na(desden[1])){desden=".7+.4*x"}
if(is.na(dwL)){dwL <- 0.5}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(sigma)){sigma <- 1}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
if(is.na(scalefun)){scalefun="3-(x-0.5)^2"}
if(SIM==0){DATA <- read.table("Data4.3")}
else{DATA <- matrix(-10,ncol=6,nrow=n)}
par(mfcol = c(2, 2))
z <- seq(0, 1, l = knots)
for(i in 1:2) {
jj <- 3*(i-1)
if(SIM==0){X <- DATA[,jj+1]
Y <- DATA[,jj+2]
A <- DATA[,jj+3] }
if(SIM==1){
X <-rgenN(n=set.n[i],den=desden,d=dden)
ww <- readw(fun=w,z=X,dL=dwL,dU=dwU)
scale <- readf(fun=scalefun,z=X,d=dscale)
f <- dcornerf(c = set.c[i], Z = X, CFUN = CFUN)
Y <- f + sigma*scale* rnorm(set.n[i])
A <-rbinom(set.n[i],1,ww)
if(WRITE){DATA[,c(jj+1,jj+2,jj+3)] <- cbind(X,Y,A)
if(i==2){write(t(DATA), file="Data4.3",ncol=6)} }
}
fest <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH,cB = cB)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
festM <- estcregN(X = X[A==1], Y = Y[A==1], Z=z,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
festM <- negden(festM,FLAGBUMP=1,cB=2)
fknots <- dcornerf(c=set.c[i],Z=z,CFUN=CFUN)
fGR <- cbind(fknots,fest)
fGRM <- cbind(fknots,festM)
ISE <- signif(mean((fknots-fest)^2),2)
ISEM <- signif(mean((fknots-festM)^2),2)
llim <- range(fGR)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGR, type = "l", lty = 1:2, xlab = "X", ylab = "Y", main = paste("H-Sample, ",paste(paste("n = ",length(X),sep=""),
paste("ISE = ",ISE,sep=" "),sep=", ")),
ylim = llim,lwd=2,col=c(1,1+COL))
points(X, Y, type = "p", pch = 1)
llim <- range(fGRM)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGRM, type = "l", lty = 1:2, xlab = "X", ylab = "AY",
main = paste("M-Sample, ",paste(paste("N = ",sum(A),sep=""),
paste("ISE = ",ISEM,sep=" "),sep=", ")),
ylim = llim,lwd=2, col=c(1,1+COL))
points(X[A==1], Y[A==1], type = "p", pch = 1)
points(X[A==0],0*Y[A==0], pch=4)
}
}
if(fig == 4) {
if(is.na(sigma)){sigma <- 1};if(is.na(c)){c <- 1}
if(is.na(n)){nn <- 300}
else{nn <- n}
if(is.na(w)){w ="1-1.2*y"}
if(is.na(desden[1])){desden="1+0*x"}
if(is.na(dwL)){dwL <- 0.2}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
if(is.na(scalefun)){scalefun="3-(x-0.5)^2"}
z <- seq(0, 1, l = knots)
if(SIM==0){DATA <- read.table("Data4.4")}
else{DATA <- matrix(-10,ncol=3,nrow=nn)}
par(mfcol = c(3, 2))
i <- 1
if(SIM==0){X <- DATA[,1]
Y <- DATA[,2]
A <- DATA[,3]
RY <- range(Y)
YSC <- (Y-RY[1])/(RY[2]-RY[1]) #rescaled Y
ww <- readw(fun=w,z=YSC,dL=dwL,dU=dwU)
AX <- A*X
}
if(SIM==1){
X <-rgenN(n=nn,den=desden,d=dden)
scale <- readf(fun=scalefun,z=X,d=dscale)
f <- readw(fun=mx,z=X,FLAGD=1)
Y <- f + sigma*scale* rnorm(nn)
RY <- range(Y)
YSC <- (Y-RY[1])/(RY[2]-RY[1]) #rescaled Y
ww <- readw(fun=w,z=YSC,dL=dwL,dU=dwU)
A <-rbinom(nn,1,ww)
AX <- A*X
if(WRITE){DATA[,1:3] <- cbind(X,Y,A)
write(t(DATA), file="Data4.4",ncol=3)}
}
##First diagram
fest <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH= cTH,cB = cB)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
fknots <- readw(fun=mx,z=z,FLAGD=1)
fGR <- cbind(fknots,fest)
ISEH <- signif(mean((fknots-fest)^2),2)
llim <- range(fGR)
llim <- range(c(llim, range(Y)))
matplot(z, fGR, type = "l", lty = 1:2,col=c(1,1+COL), xlab = "X", ylab = "Y",
main=paste("H-Sample, ","n = ",length(X),", ISE = ",ISEH),
ylim = llim,lwd=2)
points(X, Y, type = "p", pch = 1)
##Second diagrm
fest <- estcregN(X = X[A==1], Y = Y[A==1], Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH= cTH,cB = cB)$fest
fGR <- cbind(fknots,fest)
ISECC <- signif(mean((fknots-fest)^2),2)
llim <- range(fGR)
llim <- range(c(llim, range(Y)))
matplot(z, fGR, type = "l", lty = 1:2, col=c(1,1+COL), xlab = "AX", ylab = "Y",
main = paste("M-Sample, ","N = ",sum(A),", ISE = ",ISECC),
ylim = llim,lwd=2)
points(X[A==1],Y[A==1])
points(0*X[A==0],Y[A==0], pch=4)
##Third diagram - estimation f^Y(y)
fY.est <- (estcdenN(X = YSC, Z=YSC, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH, cB = cB)$fest)/(RY[2]-RY[1])
plot(Y,fY.est,type="p", main="E-estimate of the Density of Response",xlab="Y",ylab="")
##Fourth diagram - estimation h(y)
w.est <-estcregN(X = YSC, Y=A,Z=YSC, cJ0 = cJ0, cJ1 = cJ1, cTH= cTH,cB = cB)$fest
w.est[w.est > 1] <- 1
w.est[w.est < c/log(length(X)+20)] <- c/log(length(X)+20)
llim=range(cbind(0,1,ww,w.est))
matplot(Y,cbind(ww,w.est),type="p",pch=2:3,col=c(1,1+COL),
xlab="Y",main="w(Y)",ylab="A",
ylim=c(llim[1]-0.1,llim[2]+0.1))
points(Y,A,pch=1)
##Fifth diagram - estimation f^X(X)
fX.est <- estcdenGEN(X = X[A==1], V=(A/w.est)[A==1],nn=length(Y),
Z=X[A==1], Zconf=X[A==1],cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH, cB = cB)$fest
fX.est[fX.est < 0] <- 0
fX.est <- fX.est/mean(fX.est)
fX <- readf(fun=desden,z=X[A==1],d=dden)
fest <-estcdenN(X = X[A==1], Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH= cTH, cB = cB)$fest
llim <- range(cbind(fX,fX.est),range(fest))
matplot(X[A==1],cbind(fX,fX.est),xlab="X[A==1]",ylab="",type="p",
pch =2:3, col=c(1,1+COL),ylim=llim,
main="E-estimate of the Density of Predictor")
lines(seq(0,1,len=knots),fest,type="l",lty=2,lwd=2)
## Sixth diagram - estimation m(x)
m.est <- estcdenGEN(X = X[A==1], V=(A*Y/w.est)[A==1]/fX.est,nn=length(Y),
Z=z,reg=0, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH, cB = cB)$fest
ISE <- signif(mean((fknots-m.est)^2),2)
matplot(z,cbind(fknots,m.est), type = "l", lty = 1:2,col=c(1,1+COL),
xlab = "x", ylab = "m(x)", lwd=2,
main = paste("Regression and its E-estimate",paste("ISE = ",ISE,sep=""),sep=", "))
}
if(fig == 5) {
if(is.na(n)){nn <- 500}
else{nn <- n}
if(is.na(corn)){corn <- 2};if(is.na(c)){c <- 1}
if(is.na(sigma)){sigma <- 4}
if(is.na(w)){w ="1-0.4*x"}
if(is.na(dwL)){dwL <- 0.5}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(cTH)){cTH <- 10}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
if(SIM==0){DATA <- read.table("Data4.5")}
else{DATA <- matrix(-10,ncol=3,nrow=nn)}
par(mfcol = c(2, 2))
z <- seq(0, 1, l = knots4)
if(SIM==1){X <- rcornerf(c=1,n=nn,CFUN=CFUN)
ww <- readw(fun=w,z=X,dL=dwL,dU=dwU)
f <- dcornerf(c = corn, Z = X,CFUN = CFUN)
eps <- rcornerf(c = cS,n=nn,CFUN=CFUN)
Y <- f + sigma*eps + sigmaN*rnorm(nn)
A <-rbinom(nn,1,ww)
if(WRITE){DATA[,1:3] <- cbind(X,Y,A)
write(t(DATA), file="Data4.5",ncol=3)} }
if(SIM==0){X <- DATA[,1]
Y <- DATA[,2]
A <- DATA[,3] }
##Diagram 1
plot(X,Y,type="p",xlab="X", ylab="Y",
main = paste("H-Sample, n = ",nn))
##Diagram 2
RY <- range(Y)
YSC <- (Y-RY[1])/(RY[2]-RY[1])
fX.est <- estcdenN(X = X, Z=X, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH, cB = cB)$fest
fX.est[fX.est < c/log(nn+20)] <- c/log(nn+20)
fYgX.est <- estc2dimGEN(X1 = X, X2 = YSC,
H=as.vector(fX.est),cJ0 = cJ0,
cJ1 = cJ1, cTH = cTH,reg=0,knots=knots4)
fYgX.est[fYgX.est < 0] <- 0
fYgX.est <- fYgX.est/(RY[2]-RY[1])
theta<-acos(6/sqrt(36+4+900))*180/pi
phi<-acos(30/sqrt(36+4+900))*180/pi +50
r<-sqrt(36+4+900)
persp(z, (RY[2]-RY[1])*z, fYgX.est, xlab = "x", ylab = "y", zlab = "",
theta=theta,phi=phi,r=r,box = T,axes=T, ticktype="detailed",nticks=2)
title("E-estimate for H-Sample")
##Diagram 3
YY <- Y[A==1]
XX <- X[A==1]
plot(XX,YY,type="p",xlab="X", ylab="AY",
main = paste("M-Sample, N = ", sum(A)))
points(X[A==0],rep(0,nn-sum(A)),pch=4)
##Diagram 4
RY <- range(YY)
YSC <- (YY-RY[1])/(RY[2]-RY[1])
fX.est <- estcdenN(X = XX, Z=XX, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH, cB = cB)$fest
fX.est[fX.est < c/log(nn+20)] <- c/log(nn+20)
fYgX.est <- estc2dimGEN(X1 = XX, X2 = YSC,
H=as.vector(fX.est),cJ0 = cJ0,
cJ1 = cJ1, cTH = cTH,reg=0,knots=knots4)
fYgX.est[fYgX.est < 0] <- 0
fYgX.est <- fYgX.est/apply(fYgX.est,1,mean)
fYgX.est <- fYgX.est/(RY[2]-RY[1])
theta<-acos(6/sqrt(36+4+900))*180/pi
phi<-acos(30/sqrt(36+4+900))*180/pi +50
r<-sqrt(36+4+900)
persp(z, (RY[2]-RY[1])*z, fYgX.est, xlab = "x", ylab = "y", zlab = "",
theta=theta,phi=phi,r=r,box = T,axes=T, ticktype="detailed",nticks=2)
title("E-estimate for M-Sample")
}
if(fig==6) {
if(is.na(n)){nn <- 500} else{nn <- n}
if(is.na(corn)){corn <- 2};if(is.na(c)){c <- 1}
if(is.na(sigma)){sigma <- 4}
if(is.na(w)){w ="1-.4*y"}
if(is.na(dwL)){dwL <- 0.2}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(cTH)){cTH <- 10}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
par(mfrow = c(3, 2))
z <- seq(0, 1, l = knots4)
if(SIM==1){
X <- rcornerf(c=1,n=nn,CFUN=CFUN)
f <- dcornerf(c = c, Z = X, CFUN = CFUN)
eps <- rcornerf(c = cS,n=nn,CFUN=CFUN)
Y <- f + sigma*eps + sigmaN*rnorm(nn)
RY <- range(Y)
YSC <- (Y-RY[1])/(RY[2]-RY[1])
ww <- readw(fun=w,z=YSC,dL=dwL,dU=dwU)
A <- rbinom(nn,1,ww)
if(WRITE){write(t(cbind(X,Y,A)), file="Data4.6",ncol=3)} }
if(SIM==0){DATA <- read.table("Data4.6")
X <- DATA[,1]
Y <- DATA[,2]
A <- DATA[,3]
RY <- range(Y)
YSC <- (Y-RY[1])/(RY[2]-RY[1])
ww <- readw(fun=w,z=YSC,dL=dwL,dU=dwU)
}
##Diagram 1
plot(X,Y,type="p",xlab="X", ylab="Y",
main = paste("H-Sample, n = ",nn))
##Diagram 2
RY <- range(Y)
YSC <- (Y-RY[1])/(RY[2]-RY[1])
fX.est <- estcdenN(X = X, Z=X, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH, cB = cB)$fest
fX.est[fX.est < c/log(nn+20)] <- c/log(nn+20)
fYgX.est <- estc2dimGEN(X1 = X, X2 = YSC,
H=as.vector(fX.est),cJ0 = cJ0,
cJ1 = cJ1, cTH = cTH,reg=0,knots=knots4)
fYgX.est[fYgX.est < 0] <- 0
fYgX.est <- fYgX.est/(RY[2]-RY[1])
theta<-acos(6/sqrt(36+4+900))*180/pi
phi<-acos(30/sqrt(36+4+900))*180/pi +50
r<-sqrt(36+4+900)
persp(z, (RY[2]-RY[1])*z, fYgX.est, xlab = "x", ylab = "y", zlab = "",
theta=theta,phi=phi,r=r,box = T,axes=T, ticktype="detailed",nticks=2)
title("E-estimate for H-Sample")
##Diagram 3
YY <- Y[A==1]
XX <- X[A==1]
RYA <- range(YY)
YSCA <- (YY-RY[1])/(RY[2]-RY[1])
plot(XX,YY,type="p",xlab="AX", ylab="Y",
main = paste("M-Sample, N = ",sum(A)))
points(rep(0,nn-sum(A)),Y[A==0],pch=4)
fY.est <- (estcdenN(X = YSC, Z=YSC, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH, cB = cB)$fest)/(RY[2]-RY[1])
##Diagram 4
w.est <-estcregN(X = YSC, Y=A,Z=YSC, cJ0 = cJ0, cJ1 = cJ1,cTH= cTH,cB = cB)$fest
w.est[w.est > 1] <- 1
w.est[w.est < c/log(length(X)+20)] <- c/log(length(X)+20)
llim=range(cbind(0,1,ww,w.est))
matplot(Y,cbind(ww,w.est),type="p",pch=2:3,col=c(1,1+COL),
xlab="Y",main="w(Y)",ylab="A",
ylim=c(llim[1]-0.1,llim[2]+0.1))
points(Y,A,pch=1)
##Diagram 5
fX.est <- estcdenGEN(X = XX, V=(A/w.est)[A==1],nn=length(Y),
Z=XX, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH, cB = cB)$fest
fX.est[fX.est < 0] <- 0
fX.est <- fX.est/mean(fX.est)
fX <- rep(1,length(fX.est))
llim <- range(cbind(fX,fX.est))
matplot(X[A==1],cbind(fX,fX.est),xlab="X[A==1]",ylab="",type="p",
pch =2:3, col=c(1,1+COL),ylim=llim,
main="Density of Predictor and its E-estimate")
#Diagram 6
fYgX.est <- estc2dimGEN(X1 = XX, X2 = YSCA,nn=length(Y),
H=as.vector(fX.est*w.est[A==1]),cJ0 = cJ0,
cJ1 = cJ1, cTH = cTH,reg=0,knots=knots4)
fYgX.est[fYgX.est < 0] <- 0
fYgX.est <- fYgX.est/apply(fYgX.est,1,mean) ##make integrated to 1
fYgX.est <- fYgX.est/(RYA[2]-RYA[1])
theta<-acos(6/sqrt(36+4+900))*180/pi
phi<-acos(30/sqrt(36+4+900))*180/pi +50
r<-sqrt(36+4+900)
persp(z, (RYA[2]-RYA[1])*z, fYgX.est, xlab = "x", ylab = "y", zlab = "",
theta=theta,phi=phi,r=r,box = T,axes=T, ticktype="detailed",nticks=2)
title("E-estimate for M-Sample")
}
if(fig == 7) {
if(is.na(n)){n <- 100};if(is.na(c)){c <- 1}
set.n <- c(n,n)
if(is.na(set.c[1])){set.c=c(2,3)}
if(is.na(w[1])){w ="1-.4*x"}
if(is.na(desden[1])){desden=".7+.4*x"}
if(is.na(dwL)){dwL <- 0.5}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(sigma)){sigma <- 1}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
if(SIM==0){DATA <- read.table("Data4.7")}
else{DATA <- matrix(-10,ncol=6,nrow=n)}
par(mfcol = c(2, 2))
z <- seq(0, 1, l = knots)
for(i in 1:2) {
jj <- 3*(i-1)
if(SIM==0){X <- DATA[,jj+1]
Y <- DATA[,jj+2]
A <- DATA[,jj+3] }
if(SIM==1){
X <-rgenN(n=set.n[i],den=desden,d=dden)
ww <- readw(fun=w,z=X,dL=dwL,dU=dwU)
f <- dcornerf(c = set.c[i], Z = X, CFUN = CFUN)
Y <-rpois(n,f)
A <-rbinom(set.n[i],1,ww)
if(WRITE){DATA[,c(jj+1,jj+2,jj+3)] <- cbind(X,Y,A)
if(i==2){write(t(DATA), file="Data4.7",ncol=6)} }
}
fest <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH,cB = cB)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
festM <- estcregN(X = X[A==1], Y = Y[A==1], Z=z,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
festM <- negden(festM,FLAGBUMP=1,cB=2)
fknots <- dcornerf(c=set.c[i],Z=z,CFUN=CFUN)
fGR <- cbind(fknots,fest)
fGRM <- cbind(fknots,festM)
ISE <- signif(mean((fknots-fest)^2),2)
ISEM <- signif(mean((fknots-festM)^2),2)
llim <- range(fGR)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGR, type = "l", lty = 1:2, xlab = "X", ylab = "Y", main = paste("H-Sample, ",paste(paste("n = ",length(X),sep=""),
paste("ISE = ",ISE,sep=" "),sep=", ")),
ylim = llim,lwd=2,col=c(1,1+COL))
points(X, Y, type = "p", pch = 1)
llim <- range(fGRM)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGRM, type = "l", lty = 1:2, xlab = "X", ylab = "AY", main = paste("M-Sample, ",paste(paste("N = ",sum(A),sep=""),
paste("ISE = ",ISEM,sep=" "),sep=", ")),
ylim = llim,lwd=2, col=c(1,1+COL))
points(X[A==1], Y[A==1], type = "p", pch = 1)
points(X[A==0],0*Y[A==0], pch=4)
}
}
if(fig == 8) {
if(is.na(n)){n <- 100}
if(is.na(set.corn[1])){set.corn <- c(2,2)}
if(is.na(set.scalefun[1])){set.scalefun <- c(2,3)}
if(is.na(sigma)){sigma <- 1}
if(is.na(scalefun)){scalefun <- 2}
if(is.na(w[1])){w ="1-.4*x"}
if(is.na(dwL)){dwL <- 0.5}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
nn <- n
par(mfrow = c(length(set.corn),1))
z <- seq(0, 1, l = knots)
if(SIM==0){DATA <- read.table("Data4.8")}
if(SIM==1){DATA <- matrix(-10,ncol= 3*length(set.corn),nrow=nn)}
for(i in 1:length(set.corn)) {
jj <- i-1
if(SIM==1){
X <- runif(nn)
ww <- readw(fun=w,z=X,dL=dwL,dU=dwU)
A <-rbinom(n,1,ww)
ff <- dcornerf(c = set.corn[i], Z = X, CFUN = CFUN)
Y <- ff + sigma * (1+dcornerf(c = set.scalefun[i],
Z = X,CFUN=CFUN))*rnorm(nn)
DATA[,c(3*jj+1,3*jj+2,3*jj+3)] <- cbind(X,Y,A)
if(i==length(set.corn)&WRITE){
write(t(DATA),file="Data4.8", ncol=3*length(set.corn))}
}
X <- DATA[,3*jj+1]; Y <- DATA[,3*jj+2];A <- DATA[,3*jj+3]
XA <- X[A==1];YA <- Y[A==1]; N <- sum(A)
f.est <- estcregs(X = XA, Y = YA, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cJM = 6, cT = 4,method = 4, s0 = .5, s1 = .5, r = 2, cB = 2)
f <- sigma*(1+dcornerf(c = set.scalefun[i], Z=z, CFUN = CFUN))
llim <- range(f)
llim <- range(c(llim, range(YA)))
ttl=paste("M-Sample for ",ttle[set.scalefun[i]]," Scale,",
" N = ", N,", n = ",n)
mf <- dcornerf(c = set.corn[i], Z = z, CFUN = CFUN)
m.est <- estcregN(X=X, Y =Y,p=NA,Z=z,FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH,FLAGNEG=0)$fest
matplot(z, cbind(f,f.est,mf,m.est), type = "l", lty = 1:4, col=c(1,1+COL,1+2*COL,1+3*COL),
lwd=2, xlab = "X", ylab = "AY", main = ttl, ylim = llim)
points(XA, YA)# pch = 19)
points(X[A==0],rep(0,sum(1-A)), pch=4)
}
}
####################
if(fig==9){
if(is.na(set.corn[1])){set.corn=c(2,2)}
if(is.na(n)){n <- 100}
if(is.na(w[1])){w ="1-.6*x1*x2"}
if(is.na(dwL)){dwL <- 0.5}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(sigma)){sigma <- 1}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 4}
if(is.na(cJ1)){cJ1 <- .5}
cD <- 1; cJT=2;cT=2;cJM=2;knots=50;z<- seq(0,1,len=knots)
if(SIM==0){DATA <- read.table("Data4.9")
X1 <- DATA[,1];X2 <- DATA[,2];Y <- DATA[,3];A <- DATA[,4]
w <- readw2dim(fun=w,Z1=X1,Z2=X2,dL=dwL,dU=dwU,FLAGD=0)
m1 <- dcornerf(c =set.corn[1], Z = X1, CFUN = CFUN) *
dcornerf(c = set.corn[2],Z = X2,CFUN = CFUN)}
else{DATA <- matrix(-10,ncol=4,nrow=n)
X1 <- runif(n)
X2 <- runif(n)
w <- readw2dim(fun=w,Z1=X1,Z2=X2,dL=dwL,dU=dwU,FLAGD=0)
A <- rbinom(n,size=1,w)
m1 <- dcornerf(c =set.corn[1], Z = X1, CFUN = CFUN) *
dcornerf(c = set.corn[2],Z = X2,CFUN = CFUN)
er <- sigma * rnorm(n)
Y <- m1 + er
if(WRITE){DATA <- cbind(X1,X2,Y,A)
write(t(DATA), file="Data4.9",ncol=4)}
}
Z1 <- ceiling(X1 * n)
Z2 <- ceiling(X2 * n)
m.mat <- matrix(0, ncol = n, nrow = n)
for(i in 1:n) {
m.mat[Z1[i], Z2[i]] <- Y[i]
}
split.screen(fig=c(2,1))
screen(1)
ss<- scatterplot3d(X1[A==1],X2[A==1],Y[A==1], type = "h",
angle = 55, scale.y = 0.7, pch = 16,xlab=expression(X[1]),
ylab=expression(X[2]),zlab="Y",
main = paste("Scattergram, n = ",n,", N = ",sum(A)))
ss$points3d(X1[A==0],X2[A==0],Y[A==0], type = "h", col =1+COL,pch = 8)
m.est <- estcreg.2dim(Y =Y, X1 = X1, X2 = X2, knots = knots,
cD = cD, cJ0 = cJ0, cJ1 = cJ1, cJM = 2, cT = cT, cB = cB)
m.estMAR <- estcreg.2dim(Y = Y[A==1], X1 = X1[A==1], X2 = X2[A==1],
knots = knots,cD = cD, cJ0 = cJ0, cJ1 = cJ1, cJM = 2, cT = cT, cB = cB)
m <- outer(dcornerf(c = set.corn[1], Z=z, CFUN = CFUN),
dcornerf(c = set.corn[2], Z=z, CFUN = CFUN))
theta<-acos(6/sqrt(36+4+900))*180/pi
phi<-acos(30/sqrt(36+4+900))*180/pi +50
r<-sqrt(36+4+900)
split.screen(fig=c(1,3),screen=2)
screen(3)
persp(z, z, m, xlab ="X1", ylab ="X2",
zlab = "",
theta=theta,phi=phi,r=r, box = T,axes=T, ticktype="detailed",nticks=2)
title(main = "Regression Function")
screen(4)
persp(z, z, m.est, xlab ="X1", ylab ="X2",
zlab = "",
theta=theta,phi=phi,r=r,box = T,axes=T, ticktype="detailed",nticks=2)
title("H-Sample")
screen(5)
persp(z, z, m.estMAR, xlab="X1",ylab="X2",
zlab = "",
theta=theta,phi=phi,r=r,box = T,axes=T, ticktype="detailed",nticks=2)
title("M-Sample")
close.screen(all=TRUE)
}
###################################################################
if(fig==10){
if(is.na(beta)){beta <- 1}
if(is.na(set.corn[1])){set.corn=c(2,4)}
if(is.na(n)){n <- 100}
if(is.na(w[1])){w ="1-.6*x1*x2"}
if(is.na(dwL)){dwL <- 0.5}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(sigma)){sigma <- 1}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 4}
if(is.na(cJ1)){cJ1 <- .5}
if(is.na(t)){t <- .5}
cD <- 1; cJT=2;cT=2;cJM=2;knots=100;z<- seq(0,1,len=knots)
if(SIM==0){DATA <- read.table("Data4.10")
X1 <- DATA[,1];X2 <- DATA[,2];Y <- DATA[,3];A <- DATA[,4]
w <- readw2dim(fun=w,Z1=X1,Z2=X2,dL=dwL,dU=dwU,FLAGD=0)
m1 <- beta + dcornerf(c =set.corn[1], Z = X1, CFUN = CFUN) +
dcornerf(c = set.corn[2],Z = X2,CFUN = CFUN)}
if(SIM==1){DATA <- matrix(-10,ncol=4,nrow=n)
X1 <- runif(n)
X2 <- runif(n)
BB <- rbinom(n,size=1,t)
RBB <- BB*runif(n) + (1-BB)*rcornerf(c = 2,n = n,CFUN = CFUN)
X2[X1 > t] <- RBB[X1 > t]
w <- readw2dim(fun=w,Z1=X1,Z2=X2,dL=dwL,dU=dwU,FLAGD=0)
A <- rbinom(n,size=1,w)
m1 <- beta+dcornerf(c = set.corn[1], Z = X1,CFUN = CFUN) +
dcornerf(c = set.corn[2], Z = X2,CFUN = CFUN)-2
Y <- m1 +sigma*rnorm(n)
if(WRITE){DATA <- cbind(X1,X2,Y,A)
write(t(DATA), file="Data4.10",ncol=4)}
}
z <- seq(0, 1, len = knots)
m.est <- estcreg.adbiv(Y = Y, X1 = X1, X2 = X2, knots = knots,
cJ0 = cJ0, cJ1 = cJ1, cJM = cJM, cT = cT, cB = cB, cD = cD)
m.estMAR <- estcreg.adbiv(Y = Y[A==1], X1 = X1[A==1],
X2 = X2[A==1], knots = knots,cJ0 = cJ0, cJ1 = cJ1, cJM = cJM,cT = cT, cB = cB, cD = cD)
split.screen(fig=c(2,1))
screen(1)
ss<- scatterplot3d(X1[A==1],X2[A==1],Y[A==1], type = "h",
angle = 55, scale.y = 0.7, pch = 16,xlab="X1",ylab="X2",zlab="Y",
main = paste("Scattergram, n = ",n,", N = ",sum(A),", beta = ",beta))
ss$points3d(X1[A==0],X2[A==0],Y[A==0], type = "h", col =1+COL,pch = 8)
split.screen(fig=c(1,2),screen=2)
screen(3)
matplot(z, cbind(dcornerf(c = set.corn[1],Z=z, CFUN = CFUN) - 1,
m.est[, 2],m.estMAR[,2]), type = "l", lty = 1:3,
col=c(1,1+COL,1+2*COL), lwd=2, main = "First Component",
xlab=paste("H-beta.est = ",signif(m.est[1,1],2)),
ylab =expression(m[2]))
screen(4)
matplot(z, cbind(dcornerf(c = set.corn[2],Z=z, CFUN = CFUN) - 1,
m.est[, 3],m.estMAR[,3]), type = "l", lty = 1:3,
col=c(1,1+COL,1+2*COL), lwd=2, main="Second Component",
xlab=paste("M-beta.est = ",signif(m.estMAR[1,1],2)),#xlab = "x",
ylab = expression(m[1]))
close.screen(all=TRUE)
}
}#end of ch4
#######################################################################
#######################################################################
# CHAPTER 5
################################################################################
##########################################################
ch5<-function(fig = NA,w=NA, set.corn=NA, set.n=NA,n=NA, k=NA,v=.6,
SIM=1,WRITE=FALSE, COL=1, set.c =NA,
sigmaN=.5, cS=4,c=NA,setw.cJ0=NA,setw.cJ1=NA,set.beta=NA,
a=NA,b=NA, #a=0.2,b=0.8,
dscale=0,sigma=NA, set.dfyL =NA,
mx="2*x",
scalefun="3-(x-0.5)^2",
desden=NA,
dden=0.2,
dwL=NA,dwU=NA,
knots=100,
CFUN = list(NA, NA),cJ0 = 3, cJ1 = 0.8, cTH = NA,
cB = 2,
c11=1,c12=2,c21=2,c22=3,knots1=20,knots4 =30)
{
ttle <- c("1. Uniform", "2. Normal", "3. Bimodal",
"4. Strata")
if(!is.na(CFUN[[2]])) {
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
if(!is.na(CFUN[[2]])) {
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
if(fig == 1) {
if(is.na(n)){n <- 100}
if(is.na(set.corn[1])){set.corn=c(1,3)}
if(is.na(w)){w <- "1-.7*x"}
if(is.na(dwL)){dwL <- .3}
if(is.na(dwU)){dwU <- .9}
par(mfcol = c(2, 2))
z <- seq(0, 1, l = knots)
wz <- readw(fun=w,z=z,dL=dwL,dU=dwU,NN=10000,FLAGD=0)
if(SIM==0){DATA <- read.table("Data5.1")}
if(SIM==1){DATA <- matrix(-10,nrow=n,ncol=4)
for(k in 1:2){jj <- 2*(k-1)
X <- rcornerf(cornerf = set.corn[k], n =n,CFUN = CFUN)
wX <- readw(fun=w,z=X,dL=dwL,dU=dwU,NN=10000,FLAGD=0)
A <-rbinom(n,1,wX)
DATA[,c(jj+1,jj+2)] <- cbind(X,A)
if(k==2&WRITE){write(t(DATA),file="Data5.1",ncol=4)}
}
}
for(i in 1:2){jj <- 2*(i-1)
X <- DATA[,jj+1]; A <- DATA[,jj+2]; AX <- X[A==1]
f <- dcornerf(c = set.corn[i], Z=z, CFUN = CFUN)
mmm <- hist(X, plot = F, nclass = floor(length(X)/4))$density
mmm <- max(c(mmm, f))
hist(X, freq=F, nclass = floor(length(X)/4), xlab = "X",
main = paste("H-Sample", paste("n = ",length(X),sep=""),sep=", "),
xlim = c(0, 1), ylim = c(0, mmm))
lines(z, f, type = "l",col=1+2*COL,lwd=2)
mmm <- hist(AX, plot = F, nclass = floor(length(AX)/4))$density
mmm <- max(c(mmm, f))
hist(AX, freq=F, nclass = floor(length(AX)/4), xlab = "X[A==1]",
main = paste("M-Sample", paste("N = ",length(AX),sep=""),sep=", "),
xlim = c(0, 1), ylim = c(0, mmm))
lines(z, f, type = "l",col=1+2*COL,lty=1,lwd=2)
lines(z, wz, type = "l",col=1+3*COL,lty=2,lwd=2)
}
}
if(fig == 2) {
if(is.na(n)){n <- 100}
if(is.na(w)){w <- "1-.7*x"}
if(is.na(cTH)){cTH <- 4}
if(is.na(dwL)){dwL <- .3}
if(is.na(dwU)){dwU <- .9}
par(mfcol = c(2, 4))
z <- seq(0, 1, l = knots)
wz <- readw(fun=w,z=z,dL=dwL,dU=dwU,NN=10000,FLAGD=0)
if(SIM==0){DATA <- read.table("Data5.2")}
if(SIM==1){DATA <- matrix(-10,nrow=n,ncol=8)
for(k in 1:4){jj <- 2*(k-1)
X <- rcornerf(cornerf = k, n =n,CFUN = CFUN)
wX <- readw(fun=w,z=X,dL=dwL,dU=dwU,NN=10000,FLAGD=0)
A <-rbinom(n,1,wX)
DATA[,c(jj+1,jj+2)] <- cbind(X,A)
if(k==4&WRITE){write(t(DATA),file="Data5.2",ncol=8)}
}
}
for(i in 1:4){jj <- 2*(i-1)
X <- DATA[,jj+1]; A <- DATA[,jj+2]; AX <- X[A==1]
f <- dcornerf(c = i, Z=z, CFUN = CFUN)
f.est <- estcdenN(X = X, Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH,
cB = cB)$fest
ISE <- signif(mean((f-f.est)^2),2)
mmm <- hist(X, plot = F, nclass = floor(length(X)/4))$density
mmm <- max(c(mmm, f,f.est))
hist(X, freq=F, nclass = floor(length(X)/4),
xlab =paste("ISE = ",ISE),
main = paste("H-Sample", paste("n = ",length(X),sep=""),sep=", "),
xlim = c(0, 1), ylim = c(0, mmm))
lines(z, f, type = "l",lty=1,col=1+COL,lwd=2)
lines(z, f.est, type = "l",lty=2,col=1+2*COL,lwd=2)
wAX <-readw(fun=w,z=AX,dL=dwL,dU=dwU,NN=10000,FLAGD=0)
fM.est <- estcdenGEN(X = AX, V=1/wAX, nn=length(A),d=1,Z=z,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1,cB = cB,cTH=cTH)$fest
ISE <- signif(mean((f-fM.est)^2),2)
mmm <- hist(AX, plot = F, nclass = floor(length(AX)/4))$density
mmm <- max(c(mmm, f,fM.est))
hist(AX, freq=F, nclass = floor(length(AX)/4), xlab =paste("ISE = ",ISE),
main = paste("M-Sample", paste("N = ",length(AX),sep=""),sep=", "),
xlim = c(0, 1), ylim = c(0, mmm))
lines(z, f, type = "l",lty=1,col=1+COL, lwd=2)
lines(z, fM.est, type = "l",col=1+2*COL,lty=2,lwd=2)
}
}
if(fig == 3) {
if(is.na(n)){n <- 200}
if(is.na(set.corn[1])){set.corn <- c(1,2,3,3)}
if(is.na(k)){ k <- 30}
if(is.na(w)){w <- "1 -.7*x"}
if(is.na(dwL)){dwL <- .5}
if(is.na(dwU)){dwU <- .9}
if(is.na(cTH)){cTH <- 4}; if(is.na(c)){ c <-3}
par(mfrow = c(4, 3))
z <- seq(0, 1, l = knots)
if(SIM==0){DATA <- read.table("Data5.3")
DATAE <- read.table("Data5.3E")
}
if(SIM==1){DATA <- matrix(-10,nrow=n,ncol=8)
DATAE <- matrix(-10,nrow=k,ncol=4)
for(j in 1:4){jj <- 2*(j-1)
X <- rcornerf(cornerf = set.corn[j], n =n,CFUN = CFUN)
wX <- readw(fun=w,z=X,dL=dwL,dU=dwU,NN=10000,FLAGD=0)
A <-rbinom(n,1,wX)
DATA[,c(jj+1,jj+2)] <- cbind(X,A)
XE <- rcornerf(cornerf = set.corn[j], n =k,CFUN = CFUN)
DATAE[,j] <-XE
if(j==4&WRITE){write(t(DATA),file="Data5.3",ncol=8)
write(t(DATAE),file="Data5.3E",ncol=4) }
}
}
for(i in 1:4) {jj <- 2*(i-1)
X <- DATA[,jj+1]; A <- DATA[,jj+2]; AX <- X[A==1];XE <- DATAE[,i]
fX <- dcornerf(cornerf =set.corn[i], Z=X,CFUN = CFUN)
f <- dcornerf(c = set.corn[i], Z=z, CFUN = CFUN)
wX <- readw(fun=w,z=X,dL=dwL,dU=dwU,NN=10000,FLAGD=0)
fEz.est <- estcdenN(X = XE, Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH,
cB = cB)$fest
#Diagram 1
mmm <- hist(XE,plot = F, nclass = floor(length(XE)/3))$density
mmm <- max(c(mmm, fEz.est, f))
ISE <- signif(mean((f-fEz.est)^2),2)
subb<- paste("ISE = ",ISE)
hist(XE, freq=F, nclass = floor(length(XE)/3), xlab = "X",
main =paste(paste("E-Sample, k = ",length(XE)),subb,sep=", "),
xlim = c(0, 1), ylim = c(0, mmm))
lines(z, f, type = "l",col=1,lwd=2)
lines(z, fEz.est, type = "l",col=1+COL,lty=2,lwd=2)
#Diagram 2
fE.est <- as.vector(estcdenN(X = XE,Z=X, cJ0 = cJ0,
cJ1 = cJ1,cTH = cTH,cB = cB)$fest)
fE.est[fE.est < 1/(c*log(length(XE)))] <- 1/(c*log(length(XE)))
wX.est <- estcregNGen(X=A*X, Y =A,Z=X[A==1],
p=as.vector(fE.est),Density=F,cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH,FLAGNEG=0)$fest
wX.est[wX.est > 1] <- 1
wX.est[wX.est < 1/log(length(A)+20)] <- 1/log(length(A) + 20)
mmm <- range(c(1,wX[A==1],wX.est))
plot(X[A==1],rep(1,sum(A)),xlim=c(0,1), ylim=mmm,
type="p", main="E-Estimate of w(X)",xlab="X[A==1]",ylab="")
points(X[A==1],wX[A==1],pch=2,col=1+COL)
points(X[A==1],wX.est,pch=4,col=1+2*COL)
#Diagram 3
fM.est <- estcdenGEN(X = X[A==1], V=1/wX.est, nn=length(A),d=1,Z=z,
theta0=1,reg=0,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1,cB = cB,cTH=cTH)$fest
ISEM <- signif(mean((f-fM.est)^2),2)
mmm <- hist(X[A==1], plot = F, nclass = floor(length(X[A==1])/4))$density
mmm <- max(c(mmm, fM.est, f))
Ssub <-paste("ISE = ",ISEM)
mttle <- paste(paste("M-Sample, N = ",sum(A)),Ssub, sep=", ")
hist(X[A==1], freq=F, nclass = floor(length(X[A==1])/4), xlab ="X[A==1]",
main = mttle, xlim = c(0, 1), ylim = c(0, mmm))
lines(z, f, type = "l",col=1+COL,lwd=2)
lines(z, fM.est, type = "l",col=1+2*COL,lty=2,lwd=2)
}
}
if(fig == 4) {
if(is.na(n)){n <- 200}; if(is.na(c)){ c <- 3}
if(is.na(set.corn[1])){set.corn <- c(2,2,3,3)}
if(is.na(k)){ k <- 30}
if(is.na(w)){w <- "1.1 -.7*x"}
if(is.na(dwL)){dwL <- .3}
if(is.na(dwU)){dwU <- .9}
if(is.na(v)){v<- .6}
if(is.na(cTH)){cTH <- 4}
if(is.na(setw.cJ0[1])){setw.cJ0 <-c(2,2,2,2)}
if(is.na(setw.cJ1[1])){setw.cJ1 <-c(0,0,0,0)}
par(mfrow = c(4, 3))
z <- seq(0, 1, l = knots)
if(SIM==0){DATA <- read.table("Data5.4")
DATAE <- read.table("Data5.4E")
}
if(SIM==1){DATA <- matrix(-10,nrow=n,ncol=8)
DATAE <- matrix(-10,nrow=k,ncol=4)
for(j in 1:4){jj <- 2*(j-1)
V <- rbinom(n+k,1,v)
X <- V*rcornerf(cornerf =1, n = n+k,CFUN = CFUN)+
(1-V)* rcornerf(cornerf =set.corn[j], n = n+k,CFUN = CFUN)
XE <- X[-(1:n)]
X <- X[1:n]
wX <- readw(fun=w,z=X,dL=dwL,dU=dwU,NN=10000,FLAGD=0)
A <-rbinom(n,1,wX)
DATA[,c(jj+1,jj+2)] <- cbind(X,A)
DATAE[,j] <-XE
if(j==4&WRITE){write(t(DATA),file="Data5.4",ncol=8)
write(t(DATAE),file="Data5.4E",ncol=4) }
}
}
for(i in 1:4) {jj <- 2*(i-1)
X <- DATA[,jj+1]; A <- DATA[,jj+2]; AX <- X[A==1];XE <- DATAE[,i]
f <- v*dcornerf(cornerf =1, Z=z,CFUN = CFUN)+
(1-v)* dcornerf(cornerf =set.corn[i],Z=z,CFUN = CFUN)
wX <- readw(fun=w,z=X,dL=dwL,dU=dwU,NN=10000,FLAGD=0)
fEz.est <- estcdenN(X = XE, Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH,
cB = cB)$fest
#Diagram 1
mmm <- hist(XE,plot = F, nclass = floor(length(XE)/3))$density
mmm <- max(c(mmm, fEz.est, f))
ISE <- signif(mean((f-fEz.est)^2),2)
subb<- paste("ISE = ",ISE)
hist(XE, freq=F, nclass = floor(length(XE)/3), xlab = "X",
main =paste(paste("E-Sample, k = ",length(XE)),subb,sep=", "),
xlim = c(0, 1), ylim = c(0, mmm))
lines(z, f, type = "l",col=1,lwd=2)
lines(z, fEz.est, type = "l",col=1+COL,lty=2,lwd=2)
#Diagram 2
fE.est <- as.vector(estcdenN(X = XE,Z=X, cJ0 = cJ0,
cJ1 = cJ1,cTH = cTH,cB = cB)$fest)
fE.est[fE.est < 1/(c*log(length(XE)+20))] <- 1/(c*log(length(XE)+20))
wX.est <- estcregNGen(X=A*X, Y =A,Z=X[A==1],
p=as.vector(fE.est),Density=F,cJ0 = setw.cJ0[i], cJ1 = setw.cJ1[i],
cB = cB,cTH=cTH,FLAGNEG=0)$fest
wX.est[wX.est > 1] <- 1
wX.est[wX.est < 1/log(length(A)+20)] <- 1/log(length(A) + 20)
mmm <- range(c(1,wX[A==1],wX.est))
plot(X[A==1],rep(1,sum(A)),xlim=c(0,1), ylim=mmm,
type="p", main="E-Estimate of w(X)",xlab="X[A==1]",ylab="")
points(X[A==1],wX[A==1],pch=2,col=1+COL)
points(X[A==1],wX.est,pch=4,col=1+2*COL)
#Diagram 3
fM.est <- estcdenGEN(X = X[A==1], V=1/wX.est, nn=length(A),d=1,Z=z,
theta0=1,reg=0,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1,cB = cB,cTH=cTH)$fest
ISEM <- signif(mean((f-fM.est)^2),2)
Ssub <-paste("ISE = ",ISEM)
mttle <- paste(paste("M-Sample, N = ",sum(A)),Ssub,sep=", ")
mmm <- hist(X[A==1], plot = F, nclass = floor(length(X[A==1])/4))$density
mmm <- max(c(mmm, fM.est, f))
hist(X[A==1], freq=F, nclass = floor(length(X[A==1])/4), xlab ="X[A==1]",
main = mttle, xlim = c(0, 1), ylim = c(0, mmm))
lines(z, f, type = "l",col=1+COL,lwd=2)
lines(z, fM.est, type = "l",col=1+2*COL,lty=2,lwd=2)
}
}#end Fig4
if(fig ==5|fig==6) {
if(fig==5){DDATA <- "Data5.5"}
else{DDATA <- "Data5.6"}
if(is.na(n)){n <- 200}; if(is.na(c)){ c <- 1}
if(is.na(set.beta[1])){set.beta=c(0,.3)}
if(is.na(sigma)){sigma <- 2}
if(is.na(set.corn[1])){set.corn <- c(2,2,3,3)}
if(is.na(w)){w <- ".3+.5*exp(1+y)/(1+exp(1+y))"}
if(is.na(setw.cJ0[1])){setw.cJ0 <-c(3,3,3,3)}
if(is.na(setw.cJ1[1])){setw.cJ1 <-c(.3,.3,.3,.3)}
if(is.na(dwL)){dwL <- .3}
if(is.na(dwU)){dwU <- .9}
if(is.na(cTH)){cTH <- 4}
par(mfrow = c(length(set.corn), 2))
z <- seq(0, 1, l = knots)
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,nrow=n,ncol=12)
for(j in 1:4) { jj <- 3*(j-1)
X <- rcornerf(cornerf =set.corn[j], n = n,CFUN = CFUN)
if(fig==5){Y <-set.beta[1] + set.beta[2]*X + sigma*rnorm(n)}
else{Y <- X*sigma*rnorm(n)}
y <- Y
eval(parse(text=paste("wY <- ",w)))
wY[wY >dwU] <- dwU; wY[wY < dwL] <- dwL
A <-rbinom(n,1,wY)
DATA[,c(jj+1,jj+2,jj+3)] <- cbind(X,Y,A)
if(j==4&WRITE){write(t(DATA),file=DDATA,ncol=12)}
}
}
for(i in 1:4) {jj <- 3*(i-1)
X <- DATA[,jj+1]; Y <-DATA[,jj+2];A <- DATA[,jj+3]
#Diagram 1
rY <- range(Y)
YSC <- (Y-rY[1])/(rY[2]-rY[1])
y <- Y
eval(parse(text=paste("wY <- ",w)))
wY[wY >dwU] <- dwU; wY[wY < dwL] <- dwL
w.est <- estcregN(X=YSC, Y = A,Z=YSC,FLAGSUBTR=1,
cJ0 = setw.cJ0[i], cJ1 = setw.cJ1[i], cB = cB,cTH=cTH,FLAGNEG=0)$fest
w.est[w.est > 1] <- 1
w.est[w.est < 1/(c*log(length(A)+20))] <- 1/(c*log(length(A)+20))
plot(Y,A,type="p",main=paste("Estimation of w(Y), n =",length(A),sep=""),
xlab="Y", ylab="")
points(Y[A==1],wY[A==1],type="p",pch=2,col=1+COL)
points(Y[A==1],w.est[A==1],type="p",pch=4,col=1+2*COL)
#Diagram 2
f <- dcornerf(c = set.corn[i], Z=z, CFUN = CFUN)
fM.est <- estcdenGEN(X = X[A==1], V=1/w.est[A==1],
Z=z,nn=length(A),d=1,theta0=1,reg=0,FLAGNEG=1,
cJ0 = cJ0, cJ1 = cJ1,cB = cB,cTH=cTH)$fest
ISEM <- signif(mean((f-fM.est)^2),2)
mttle <- paste(paste("M-Sample, N = ",sum(A)),paste("ISE = ",ISEM),sep=", ")
mmm <- hist(X[A==1], plot = F, nclass = floor(length(X[A==1])/8))$density
mmm <- max(c(mmm, fM.est, f))
hist(X[A==1], freq=F, nclass = floor(length(X[A==1])/8), xlab ="X[A==1]",
main = mttle, xlim = c(0, 1), ylim = c(0, mmm))
lines(z, f, type = "l",col=1+COL,lwd=2)
lines(z, fM.est, type = "l",col=1+2*COL,lty=2,lwd=2)
}
} #end Fig 5&6
if(fig == 7) {
DDATA <- "Data5.7"
if(is.na(n)){n <- 100; nn <- n}
set.n <- c(n,n); nn <- n
if(is.na(set.c[1])){set.c=c(2,4)}
if(is.na(w[1])){w ="1-.3*y"}
if(is.na(dwL)){dwL <- 0.3}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(sigma)){sigma <- .5}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
if(SIM==0){DATA <- read.table(DDATA)}
else{DATA <- matrix(-10,ncol=6,nrow=n)}
par(mfcol = c(2, 2))
z <- seq(0, 1, l = knots)
for(i in 1:2) {
jj <- 3*(i-1)
if(SIM==0){X <- DATA[,jj+1]; nn <- length(X)
Y <- DATA[,jj+2]
A <- DATA[,jj+3] }
if(SIM==1){
X <- runif(nn)
scale <- 1
f <- dcornerf(c = set.c[i], Z = X, CFUN = CFUN)
Y <- f + sigma*scale* rnorm(nn)
ww <- readwN(fun=w,Z=Y,dL=dwL,dU=dwU)
ww[ww < dwL] <- dwL; ww[ww> dwU] <- dwU
A <-rbinom(nn,1,ww)
if(WRITE){DATA[,c(jj+1,jj+2,jj+3)] <- cbind(X,Y,A)
if(i==2){write(t(DATA), file=DDATA,ncol=6)} }
}
fest <- estcregm(X = X, Y = Y, knots=knots, method = 4, s0 = 0.5,
s1 =0.5, cJ0 = cJ0, cJ1 = cJ1, cJM = 6, cT = 4, r = 2)
fest <- negden(fest,FLAGBUMP=1,cB=2)
festM <- estcregm(X = X[A==1], Y = Y[A==1], knots=knots, method = 4, s0 = 0.5,
s1 =0.5, cJ0 = cJ0, cJ1 = cJ1, cJM = 6, cT = 4, r = 2)
festM <- negden(festM,FLAGBUMP=1,cB=2)
fknots <- dcornerf(c=set.c[i],Z=z,CFUN=CFUN)
fGR <- cbind(fknots,fest)
fGRM <- cbind(fknots,festM)
ISE <- signif(mean((fknots-fest)^2),2)
ISEM <- signif(mean((fknots-festM)^2),2)
llim <- range(fGR)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGR, type = "l", lty = 1:2, xlab = "X",
ylab = "Y",
main = paste(paste("H-Sample, n = ",length(X)),paste("ISE = ",ISE),sep=", "),
ylim = llim,lwd=2,col=c(1,1+COL))
points(X, Y, type = "p", pch = 1)
llim <- range(fGRM)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGRM, type = "l", lty = 1:2,
xlab = "X", ylab = "AY",
main = paste(paste("M-Sample, N = ",sum(A)),paste("ISE = ",ISEM),sep=", "),
ylim = llim,lwd=2, col=c(1,1+COL))
points(X[A==1], Y[A==1], type = "p", pch = 1)
points(X[A==0],0*Y[A==0], pch=4)
}
}
if(fig == 8) {
DDATA <- "Data5.8"
if(is.na(n)){n <- 100; nn <- n}
nn <- n
if(is.na(set.c[1])){set.c=c(2,4)}
if(is.na(w[1])){w ="1-.3*y"}
if(is.na(dwL)){dwL <- 0.3}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(sigma)){sigma <- .5}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
if(SIM==0){DATA <- read.table(DDATA)}
else{DATA <- matrix(-10,ncol=6,nrow=n)}
par(mfcol = c(2, 2))
z <- seq(0, 1, l = knots)
for(i in 1:2) {
jj <- 3*(i-1)
if(SIM==0){X <- DATA[,jj+1]; nn <- length(X)
Y <- DATA[,jj+2]
A <- DATA[,jj+3]
ww <- readwN(fun=w,Z=Y,dL=dwL,dU=dwU)
ww[ww < dwL] <- dwL; ww[ww> dwU] <- dwU
}
if(SIM==1){
X <- runif(nn)
scale <- 1
f <- dcornerf(c = set.c[i], Z = X, CFUN = CFUN)
Y <- f + sigma*scale* rnorm(nn)
ww <- readwN(fun=w,Z=Y,dL=dwL,dU=dwU)
ww[ww < dwL] <- dwL; ww[ww> dwU] <- dwU
A <-rbinom(nn,1,ww)
if(WRITE){DATA[,c(jj+1,jj+2,jj+3)] <- cbind(X,Y,A)
if(i==2){write(t(DATA), file=DDATA,ncol=6)} }
}
fest <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH,cB = cB)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
festM <- estcregN(X = X, Y = Y, V = A/ww, Z=z,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
festM <- negden(festM,FLAGBUMP=1,cB=2)
fknots <- dcornerf(c=set.c[i],Z=z,CFUN=CFUN)
fGR <- cbind(fknots,fest)
fGRM <- cbind(fknots,festM)
ISE <- signif(mean((fknots-fest)^2),2)
ISEM <- signif(mean((fknots-festM)^2),2)
llim <- range(fGR)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGR, type = "l", lty = 1:2, xlab = "X",
ylab = "Y",
main = paste(paste("H-Sample, n = ",length(X)),paste("ISE = ",ISE), sep=", "),
ylim = llim,lwd=2,col=c(1,1+COL))
points(X, Y, type = "p", pch = 1)
llim <- range(fGRM)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGRM, type = "l", lty = 1:2,
xlab = "X", ylab = "AY",
main = paste(paste("M-Sample, N = ",sum(A)),paste("ISE = ",ISEM), sep=", "),
ylim = llim,lwd=2, col=c(1,1+COL))
points(X[A==1], Y[A==1], type = "p", pch = 1)
points(X[A==0],0*Y[A==0], pch=4)
}
}
if(fig == 9) {
DDATA <- "Data5.9"
if(is.na(n)){n <- 100; nn <- n}
nn <- n
if(is.na(a)){ a <- 3}; if(is.na(b)){ b <- 1};if(is.na(c)){ c <- 1}
if(is.na(set.c[1])){set.c=c(2,4)}
if(is.na(w[1])){w ="1-z"}
if(is.na(dwL)){dwL <- 0.4}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(sigma)){sigma <- .5}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
if(SIM==0){DATA <- read.table(DDATA)}
else{DATA <- matrix(-10,ncol=8,nrow=n)}
if(SIM==0){DATA <- read.table(DDATA)}
else{DATA <- matrix(-10,ncol=8,nrow=n)}
par(mfcol = c(3, 2))
zz <- seq(0, 1, l = knots)
for(i in 1:2) {
jj <- 4*(i-1)
if(SIM==0){X <- DATA[,jj+1]; nn <- length(X)
Y <- DATA[,jj+2]; A <- DATA[,jj+3]; Z <- DATA[,jj+4]
ww <- readwN(fun=w,Z=Z,dL=dwL,dU=dwU)
ww[ww < dwL] <- dwL; ww[ww> dwU] <- dwU
}
if(SIM==1){
X <- runif(nn)
scale <- 1
f <- dcornerf(c = set.c[i], Z = X, CFUN = CFUN)
Y <- f + sigma*scale* rnorm(nn)
Z <- exp(1+a*(Y-b))/(1+exp(1+a*(Y-b)))
ww <- readwN(fun=w,Z=Z,dL=dwL,dU=dwU)
ww[ww < dwL] <- dwL; ww[ww> dwU] <- dwU
A <-rbinom(nn,1,ww)
if(WRITE){DATA[,c(jj+1,jj+2,jj+3,jj+4)] <- cbind(X,Y,A,Z)
if(i==2){write(t(DATA), file=DDATA,ncol=8)} }
}
fest <- estcregN(X = X, Y = Y, Z=zz, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH,cB = cB)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
west <- estcregN(X = Z, Y = A, Z=Z, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH,cB = cB)$fest
west[west < c/log(nn)] <-c/log(nn); west[west > 1] <- 1
festM <- estcregN(X = X, Y = Y, V = A/west, Z=zz,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
festM <- negden(festM,FLAGBUMP=1,cB=2)
fknots <- dcornerf(c=set.c[i],Z=zz,CFUN=CFUN)
fGR <- cbind(fknots,fest)
fGRM <- cbind(fknots,festM)
ISE <- signif(mean((fknots-fest)^2),2)
ISEM <- signif(mean((fknots-festM)^2),2)
#Diagram 1
llim <- range(fGR)
llim <- range(c(llim, range(Y)))
matplot(zz, fGR, type = "l", lty = 1:2, xlab = "X", ylab = "Y",
main = paste(paste("H-Sample, n = ",length(X)),paste("ISE = ",ISE),sep=", "),
ylim = llim,lwd=2,col=c(1,1+COL))
points(X, Y, type = "p", pch = 1)
#Diagram 2
matplot(Z,cbind(A,ww,west),type = "p", pch=c(1,2,4), xlab = "Z", ylab = "A",
main = "Availability Likelihood", lwd=1,col=c(1,1+COL))
#Diagram 3
llim <- range(fGRM)
llim <- range(c(llim, range(Y)))
matplot(zz, fGRM, type = "l", lty = 1:2, xlab = "X", ylab = "AY",
main = paste(paste("M-Sample, N = ",sum(A)),paste("ISE = ",ISEM),sep=", "),
ylim = llim,lwd=2, col=c(1,1+COL))
points(X[A==1], Y[A==1], type = "p", pch = 1)
points(X[A==0],0*Y[A==0], pch=4)
}
}
if(fig == 10) {
DDATA <- "Data5.10"
if(is.na(n)){n <- 100; nn <- n}
nn <- n
if(is.na(set.c[1])){set.c=c(2,4)}
if(is.na(w[1])){w ="1-.3*x*y"}
if(is.na(dwL)){dwL <- 0.3}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(sigma)){sigma <- .5}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
if(SIM==0){DATA <- read.table(DDATA)}
else{DATA <- matrix(-10,ncol=6,nrow=n)}
par(mfcol = c(2, 2))
z <- seq(0, 1, l = knots)
for(i in 1:2) {
jj <- 3*(i-1)
if(SIM==0){X <- DATA[,jj+1]; nn <- length(X)
Y <- DATA[,jj+2]
A <- DATA[,jj+3]
ww <- readw2dimxy(fun=w,Z1=X,Z2=Y,dL=dwL,dU=dwU,FLAGD=0)
}
if(SIM==1){
X <- runif(nn)
scale <- 1
f <- dcornerf(c = set.c[i], Z = X, CFUN = CFUN)
Y <- f + sigma*scale* rnorm(nn)
ww <- readw2dimxy(fun=w,Z1=X,Z2=Y,dL=dwL,dU=dwU,FLAGD=0)
A <-rbinom(nn,1,ww)
if(WRITE){DATA[,c(jj+1,jj+2,jj+3)] <- cbind(X,Y,A)
if(i==2){write(t(DATA), file=DDATA,ncol=6)} }
}
fest <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH,cB = cB)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
festM <- estcregN(X = X, Y = Y, V = A/ww, Z=z,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
festM <- negden(festM,FLAGBUMP=1,cB=2)
fknots <- dcornerf(c=set.c[i],Z=z,CFUN=CFUN)
fGR <- cbind(fknots,fest)
fGRM <- cbind(fknots,festM)
ISE <- signif(mean((fknots-fest)^2),2)
ISEM <- signif(mean((fknots-festM)^2),2)
llim <- range(fGR)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGR, type = "l", lty = 1:2, xlab = "X",
ylab = "Y",
main = paste(paste("H-Sample, n = ",length(X)),paste("ISE = ",ISE),sep=", "),
ylim = llim,lwd=2,col=c(1,1+COL))
points(X, Y, type = "p", pch = 1)
llim <- range(fGRM)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGRM, type = "l", lty = 1:2, xlab = "X",
ylab = "AY",
main = paste(paste("M-Sample, N = ",sum(A)),paste("ISE = ",ISEM),sep=", "),
ylim = llim,lwd=2, col=c(1,1+COL))
points(X[A==1], Y[A==1], type = "p", pch = 1)
points(X[A==0],0*Y[A==0], pch=4)
}
}
if(fig == 11) {
DDATA <- "Data5.11"
if(is.na(n)){n <- 100; nn <- n}
nn <- n
if(is.na(set.c[1])){set.c=c(2,4)}
if(is.na(w[1])){w ="1-.3*x*y"}
if(is.na(dwL)){dwL <- 0.3}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(sigma)){sigma <- .5}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
if(SIM==0){DATA <- read.table(DDATA)}
else{DATA <- matrix(-10,ncol=6,nrow=n)}
par(mfcol = c(2, 2))
z <- seq(0, 1, l = knots)
for(i in 1:2) {
jj <- 3*(i-1)
if(SIM==0){X <- DATA[,jj+1]; nn <- length(X)
Y <- DATA[,jj+2]
A <- DATA[,jj+3]
ww <- readw2dimxy(fun=w,Z1=X,Z2=Y,dL=dwL,dU=dwU,FLAGD=0)
}
if(SIM==1){
X <- runif(nn)
scale <- 1
f <- dcornerf(c = set.c[i], Z = X, CFUN = CFUN)
Y <- f + sigma*scale* rnorm(nn)
ww <- readw2dimxy(fun=w,Z1=X,Z2=Y,dL=dwL,dU=dwU,FLAGD=0)
A <-rbinom(nn,1,ww)
if(WRITE){DATA[,c(jj+1,jj+2,jj+3)] <- cbind(X,Y,A)
if(i==2){write(t(DATA), file=DDATA,ncol=6)} }
}
fest <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH,cB = cB)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
festM <- estcregN(X=X, Y = Y,V=A/ww,p=1,H=1,Z=z,FLAGSUBTR=1, c=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = 2)$fest
festM <- negden(festM,FLAGBUMP=1,cB=2)
fknots <- dcornerf(c=set.c[i],Z=z,CFUN=CFUN)
fGR <- cbind(fknots,fest)
fGRM <- cbind(fknots,festM)
ISE <- signif(mean((fknots-fest)^2),2)
ISEM <- signif(mean((fknots-festM)^2),2)
llim <- range(fGR)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGR, type = "l", lty = 1:2, xlab = "X",
ylab = "Y",
main = paste(paste("H-Sample, n = ",length(X)),paste("ISE = ",ISE),sep=", "),
ylim = llim,lwd=2,col=c(1,1+COL))
points(X, Y, type = "p", pch = 1)
llim <- range(fGRM)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGRM, type = "l", lty = 1:2, xlab = "AX",
ylab = "Y",
main = paste(paste("M-Sample, N = ",sum(A)),paste("ISE = ",ISEM),sep=", "),
ylim = llim,lwd=2, col=c(1,1+COL))
points(X[A==1], Y[A==1], type = "p", pch = 1)
points(0*X[A==0],Y[A==0], pch=4)
}
}
if(fig == 12) {
DDATA <- "Data5.12"
if(is.na(n)){n <- 100; nn <- n}
nn <- n
if(is.na(set.c[1])){set.c=c(2,4)}
if(is.na(w[1])){w ="1-.3*x*y"}
if(is.na(dwL)){dwL <- 0.3}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(sigma)){sigma <- .5}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
if(is.na(c)){c <= 1}
if(SIM==0){DATA <- read.table(DDATA)}
else{DATA <- matrix(-10,ncol=6,nrow=n)}
par(mfcol = c(3, 2))
z <- seq(0, 1, l = knots)
for(i in 1:2) {
jj <- 3*(i-1)
if(SIM==0){X <- DATA[,jj+1]; nn <- length(X)
Y <- DATA[,jj+2]
A <- DATA[,jj+3]
ww <- readw2dimxy(fun=w,Z1=X,Z2=Y,dL=dwL,dU=dwU,FLAGD=0)
f <- dcornerf(c = set.c[i], Z = X, CFUN = CFUN)
}
if(SIM==1){
X <- runif(nn)
scale <- 1
f <- dcornerf(c = set.c[i], Z = X, CFUN = CFUN)
Y <- f + sigma*scale* rnorm(nn)
ww <- readw2dimxy(fun=w,Z1=X,Z2=Y,dL=dwL,dU=dwU,FLAGD=0)
A <-rbinom(nn,1,ww)
if(WRITE){DATA[,c(jj+1,jj+2,jj+3)] <- cbind(X,Y,A)
if(i==2){write(t(DATA), file=DDATA,ncol=6)} }
}
fest <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH,cB = cB)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
wAX <- readw2dimxy(fun=w,Z1=X[A==1],Z2=Y[A==1],dL=dwL,dU=dwU,FLAGD=0)
fXdes.est <- estcdenGEN(X = X[A==1], V=1/wAX, nn=length(A),d=1,Z=X,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1,cB = cB,cTH=cTH)$fest
fzdes.est <- estcdenGEN(X = X[A==1], V=1/wAX, nn=length(A),d=1,Z=z,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1,cB = cB,cTH=cTH)$fest
fXdes.est[fXdes.est < c/log(nn)] <- c/log(nn)
fzdes.est[fzdes.est < c/log(nn)] <- c/log(nn)
festM <- estcregN(X=X, Y = Y,V=A/ww,p=fXdes.est,H=1,Z=z,FLAGSUBTR=1, c=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = 2)$fest
festM <- negden(festM,FLAGBUMP=1,cB=2)
fknots <- dcornerf(c=set.c[i],Z=z,CFUN=CFUN)
fGR <- cbind(fknots,fest)
fGRM <- cbind(fknots,festM)
ISE <- signif(mean((fknots-fest)^2),2)
ISEM <- signif(mean((fknots-festM)^2),2)
llim <- range(fGR)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGR, type = "l", lty = 1:2, xlab = "X",
ylab = "Y",
main = paste(paste("H-Sample, n = ",length(X)),
paste(" ISE = ",ISE),sep=", "),
ylim = llim,lwd=2,col=c(1,1+COL))
points(X, Y, type = "p", pch = 1)
#Diagram 2
ISEX <- signif(mean((1-fzdes.est)^2),2)
mmm <- hist(X[A==1], plot = F, nclass = floor(length(X[A==1])/4))$density
mmm <- max(c(mmm, f,fzdes.est))
hist(X[A==1], freq=F, nclass = floor(length(X[A==1])/4),
xlab ="X[A==1]",
main = paste(paste("Design Density, N = ",sum(A)),
paste(" ISE = ",ISEX),sep=", "),
xlim = c(0, 1), ylim = c(0, mmm))
lines(z, rep(1,knots), type = "l",lty=1,col=1+COL, lwd=2)
lines(z, fzdes.est, type = "l",col=1+2*COL,lty=2,lwd=2)
#Diagram 3
llim <- range(fGRM)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGRM, type = "l", lty = 1:2, xlab = "AX",
ylab = "Y", main = paste(paste("M-Sample, N = ",sum(A)),
paste(" ISE = ",ISEM),sep=", "),
ylim = llim,lwd=2, col=c(1,1+COL))
points(X[A==1], Y[A==1], type = "p", pch = 1)
points(0*X[A==0],Y[A==0], pch=4)
}
}
if(fig == 13) {
DDATA <- "Data5.13"
if(is.na(n)){n <- 100; nn <- n}
nn <- n
if(is.na(set.c[1])){set.c=c(2,4)}
if(is.na(w[1])){w ="1-.3*x*y"}
if(is.na(dwL)){dwL <- 0.3}
if(is.na(dwU)){dwU <- 0.9}
if(is.na(sigma)){sigma <- .5}
if(is.na(cTH)){cTH <- 4}
if(is.na(cJ0)){cJ0 <- 3}
if(is.na(cJ1)){cJ1 <- .8}
if(is.na(c)){c <= 1}
if(SIM==0){DATA <- read.table(DDATA)}
else{DATA <- matrix(-10,ncol=6,nrow=n)}
par(mfcol = c(3, 2))
z <- seq(0, 1, l = knots)
for(i in 1:2) {
jj <- 3*(i-1)
if(SIM==0){X <- DATA[,jj+1]; nn <- length(X)
Y <- DATA[,jj+2]
A <- DATA[,jj+3]
ww <- readw2dimxy(fun=w,Z1=X,Z2=Y,dL=dwL,dU=dwU,FLAGD=0)
f <- dcornerf(c = set.c[i], Z = X, CFUN = CFUN)
}
if(SIM==1){
X <- runif(nn)
scale <- 1
f <- dcornerf(c = set.c[i], Z = X, CFUN = CFUN)
Y <- f + sigma*scale* rnorm(nn)
ww <- readw2dimxy(fun=w,Z1=X,Z2=Y,dL=dwL,dU=dwU,FLAGD=0)
A <-rbinom(nn,1,ww)
if(WRITE){DATA[,c(jj+1,jj+2,jj+3)] <- cbind(X,Y,A)
if(i==2){write(t(DATA), file=DDATA,ncol=6)} }
}
fest <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0, cJ1 = cJ1,
cTH = cTH,cB = cB)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
wAX <- readw2dimxy(fun=w,Z1=X[A==1],Z2=Y[A==1],dL=dwL,dU=dwU,FLAGD=0)
fXdes.est <- estcdenGEN(X = X[A==1], V=1/wAX, nn=length(A),d=1,Z=X,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1,cB = cB,cTH=cTH)$fest
fzdes.est <- estcdenGEN(X = X[A==1], V=1/wAX, nn=length(A),d=1,Z=z,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1,cB = cB,cTH=cTH)$fest
fXdes.est[fXdes.est < c/log(nn)] <- c/log(nn)
fzdes.est[fzdes.est < c/log(nn)] <- c/log(nn)
festM <- estcregN(X=X, Y = Y,V=A/ww,p=fXdes.est,H=1,Z=z,FLAGSUBTR=1, c=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = 2)$fest
festM <- negden(festM,FLAGBUMP=1,cB=2)
fknots <- dcornerf(c=set.c[i],Z=z,CFUN=CFUN)
fGR <- cbind(fknots,fest)
fGRM <- cbind(fknots,festM)
ISE <- signif(mean((fknots-fest)^2),2)
ISEM <- signif(mean((fknots-festM)^2),2)
llim <- range(fGR)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGR, type = "l", lty = 1:2, xlab = "X",
ylab = "Y",
main = paste(paste("H-Sample, n = ",length(X)),
paste(" ISE = ",ISE),sep=", "),
ylim = llim,lwd=2,col=c(1,1+COL))
points(X, Y, type = "p", pch = 1)
#Diagram 2
ISEX <- signif(mean((1-fzdes.est)^2),2)
mmm <- hist(X[A==1], plot = F, nclass = floor(length(X[A==1])/4))$density
mmm <- max(c(mmm, f,fzdes.est))
hist(X[A==1], freq=F, nclass = floor(length(X[A==1])/4),
xlab ="X[A==1]",
main = paste(paste("Design Density, N = ",sum(A)),
paste(" ISE = ",ISEX),sep=", "),
xlim = c(0, 1), ylim = c(0, mmm))
lines(z, rep(1,knots), type = "l",lty=1,col=1+COL, lwd=2)
lines(z, fzdes.est, type = "l",col=1+2*COL,lty=2,lwd=2)
#Diagram 3
llim <- range(fGRM)
llim <- range(c(llim, range(Y)))
matplot(seq(0,1,len=knots), fGRM, type = "l", lty = 1:2, xlab = "X[A==1]",
ylab = "Y[A==1]",
main = paste(paste("M-Sample, N = ",sum(A)),
paste(" ISE = ",ISEM),sep=", "),
ylim = llim,lwd=2, col=c(1,1+COL))
points(X[A==1], Y[A==1], type = "p", pch = 1)
points(0*X[A==0],0*Y[A==0], pch=4)
}
}
}# end of ch5
##########################################################################
###########################################################################
# CHAPTER 6
########################################################################
#######################################################################
ch6<-function(fig = 1,corn=NA, SIM=1,COL=1, a=NA,A=NA,b=NA,B=NA, n=NA, lambdaC=NA,
lambdaT=NA,k=NA,sh1=NA,sh2=NA,sc1=NA,sc2=NA, nsim=NA,NFIG=NA,mT=NA,
sigma=NA,desden=NA, dden=NA, u=NA,
knots=100, alpha=0.05,WRITE=F, cens="Unif", trunc="Unif",
uT=NA,ut=NA,uC=NA, uc=NA,a1=NA,b1=NA,censp=NA,
CFUN = list(NA, NA),cJ0 = 4, cJ1 = 0.5, cTH = 4,cB = 2,cTP=NA)
{
ttle <- c("1. Uniform", "2. Normal", "3. Bimodal",
"4. Strata")
if(!is.na(CFUN[[2]])) {
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
else if(is.na(CFUN[[1]]) & is.na(CFUN[[2]]) & fig == 3) {
CFUN <- list(1, "2 - 2*x -sin(8*x)")
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
if(!is.na(CFUN[[2]])) {
ttle[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
##############################################
if(fig == 1) {
if(is.na(corn)){corn <- 3}
if(is.na(n)){n <- 400}
if(is.na(k)){k <- 1}
if(is.na(a)){a <-0}
if(is.na(b)){b <-.6}
if(is.na(a1)){a1 <-0}
if(is.na(b1)){b1 <-.7}
if(is.na(B)){B <-.7}
par(mfrow = c(4, 2))
nn <- n
if(SIM==0){Y <- read.table("Data6.1"); Y <- Y[,1]}
if(SIM==1){
if(is.na(corn)){
Y <- rweibull(n=nn,scale=lambda,shape=k)}
else{Y <- rcornerf(c=corn,n=nn)}
if(WRITE){write(Y,file="Data6.101", ncol=1)}
}
Y <- sort(Y)
Ind <- rep(TRUE,length(Y))
Ind[(Y <= a)|(Y >= (a+b))] <- FALSE
IndN <- 1*Ind
hatG <- (nn-rank(Y) +1)/nn
if(is.na(corn)){G <- 1-pweibull(Y,scale=lambda,shape=k)}
else{G <- hGcornerf(c=corn,Z=Y)$G}
#Diagram1
plot(Y,1/G,type="l", main =paste("n = ",nn,sep=""),col=1,
xlab="X", ylab="1/G")
points(Y,1/hatG,pch=3,col=1+COL)
YSC <- (Y-a)/b
Z <- seq(0, 1, len = knots)
z <- seq(a,a+b, len=knots)
fb.est <- b^(-1)*estcdenGEN(X = YSC, V=IndN, Z=Z,theta0=-10,
FLAGNEG=0, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
fb.est[fb.est < 0] <- 0
fb <- dcornerf(c=corn,Z=z)
ISEMab <- signif((b-a)*mean((fb-fb.est)^2),2)
f1.est <- estcdenGEN(X = Y, V=1, Z=Z,theta0=1,
FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
f1 <- dcornerf(c=corn, Z=Z)
ISEM01 <- signif(mean((f1-f1.est)^2),2)
#Diagram2
matplot(Z,cbind(f1,f1.est), xlab="",ylab="f", type="l",
main=paste(paste(paste("a = ",a,sep=""),paste("b = ",b,
sep=""),sep=", "),paste("N = ", sum(Ind)),sep=", "),
sub =paste(paste("ISEab = ",ISEMab,sep=""),paste("ISE01 = ",ISEM01,sep=""),
sep=", "), col=c(1,1+COL))
lines(z,fb.est,col=1+3*COL,type="l",lty=3)
#Digrams 3 and 4
d.vec <- cumsum(G^(-2))/(nn*(Y-a1+.01))
IndDD <- (Y>= a1) &(Y <= a1+b1)
dab.vec <-cumsum((G[IndDD])^(-2))/(nn*(Y[IndDD]-a1+0.01))
plot(Y,log(d.vec),type="p",
main =expression(paste("log(",hat(d),"(0,x))")),
col=1, xlab="x", ylab="")
plot(Y[IndDD],dab.vec,type="p",
main = substitute(paste(hat(d),"(a1,x) on [a1,a1+b1], a1 = ",aa,
", b1 = ", bb),list(aa=a1,bb=b1)), col=1, xlab="x", ylab="")
#Diagram 5
IndaB <- (Z >=a)&(Z <=B)
ZB <- Z[IndaB]
hB <- hGcornerf(c=corn,ZB)$h
hatGB <- c(1,hatG,0)
hatGBAppr <- approx(x=c(-.01,Y,1),y=hatGB,xout=ZB,method="constant")$y
fB.est <- f1.est[IndaB]
hRB.est <- fB.est/hatGBAppr
ISEMB <- signif((B-a)*mean((hB-hRB.est)^2),2)
matplot(ZB,cbind(hB,hRB.est),
main=paste("Ratio-Estimate on [a,a+B], B = ",B),type="l",
col=cbind(1,1+COL), xlab="",ylab="h",sub=paste("ISE = ",ISEMB))
#Diagram 6
hb <- hGcornerf(c=corn,Z=z)$h
hatGb <- c(1,hatG,0)
hatGbAppr <- approx(x=c(-.01,Y,1),y=hatGb,xout=z,method="constant")$y
hRb.est <- fb.est/hatGbAppr
ISEMb <- signif((b-a)*mean((hb-hRb.est)^2),2)
ISEMaB <- signif((b-a)*mean((hB[ZB <= b] - hRB.est[ZB <= b])^2),2)
matplot(z,cbind(hb,hRb.est), main="Two Ratio-Estimates on [a,a+b]", type="l",
lty=c(1,3),col=cbind(1,1+2*COL), xlab="",ylab="h",
sub=paste(paste("ISEab = ",ISEMb), paste("ISEaB = ",ISEMaB),sep=", "))
lines(ZB[ZB <= b],hRB.est[ZB <= b], type="l", col=1+COL, lty=2)
#Diagrams 7 and 8
bb <- b
for(kk in 1:2){
if(kk==1){b <- B; titl <-"E-Estimate on [a,a+B]"}
else{b <- bb; titl <-"E-Estimate on [a,a+b]"}
Ind <- rep(TRUE,length(Y))
Ind[(Y <= a)|(Y >= (a+b))] <- FALSE
IndN <-1*Ind
z <- seq(a,a+b,len=knots)
YSC <- (Y-a)/b
V <- IndN/hatG
hb.estF <-estcdenGEN(X = YSC, V=V, Z=Z,Zconf=Z, alpha=0.05,
NSimConfInt=100,
theta0=-10,FLAGNEG=0, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
hb.est <- b^(-1)*hb.estF$fest
hb.est[hb.est < 0] <-0
Marginb <- b^(-1)* hb.estF$Margin
MarginSimb <- b^(-1)* hb.estF$MarginSim
hb <- hGcornerf(c=corn,Z=z)$h
ISEM <- signif(b*mean((hb-hb.est)^2),2)
matplot(z,cbind(hb,hb.est,hb.est+Marginb,hb.est-Marginb,hb.est-MarginSimb,
hb.est+MarginSimb),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3),
main=titl, ylab="h",xlab="",sub=paste("ISE = ",ISEM))
}
}#End 6.1
if(fig == 2) {
if(is.na(corn)){corn <- 3}
if(is.na(n)){n <- 300}
if(is.na(uC)){uC <- 1.5}
if(is.na(lambdaC)){lambdaC<-1.5}
if(is.na(a)){a <-0}
if(is.na(b)){b <-.55}
if(is.na(B)){B <-.75}
if(is.na(a1)){a1 <-0}
if(is.na(b1)){b1 <-.75}
par(mfrow = c(4, 1))
nn <- n
if(SIM==0){DATA <- read.table("Data6.2"); YY <- DATA[,1]; DeltaN=DATA[,2]}
if(SIM==1){X <- rcornerf(c=corn,n=nn);
if(cens=="Unif"){Z <- uC*runif(nn)}else{Z <- rexp(nn,rate=1/lambdaC)}
YY <- pmin(X,Z); DeltaL <- X <= Z; DeltaN <- 1*DeltaL
if(WRITE){write(t(cbind(YY,DeltaN)), file="Data6.2", ncol=2)}
}
r <- order(YY)
Y <- YY[r]
Delta <- DeltaN[r]
#Diagram1
plot(Y,Delta, type="p",xlab="V",ylab=expression(Delta),ylim=c(-.1,1.1),
yaxp=c(0,1,1),xaxp=c(0,1,5),xlim=c(0,1),
main=paste(paste("Censored Data, n = ", nn),
paste("N = ",sum(Delta)),sep=", "))
#Diagram 2
hatG <- (nn-rank(Y) +1)/nn
IndDD <- (Y>= a1) &(Y <= a1+b1)&(Delta==1)
d.vec <- cumsum((hatG^(-2))[IndDD])/(nn*(Y[IndDD]-a1+.01))
plot(Y[IndDD],1/hatG[IndDD],
type="p",pch=3,col=1,
main= expression(paste("Estimates of ", 1/G^V,"(v)", " and d(a1,v)")),
xlab=expression(paste(paste("V[", Delta),"==1]",sep="")), ylab="",
xlim=c(a1,a1+b1))
par(new=TRUE)
plot(Y[IndDD],d.vec,xaxt="n",axes=F,ylab=NA,xlab=NA,xlim=c(a1,a1+b1),col=1+COL)
axis(4)
mtext(expression(hat(d)),side=4,line=3)
#Diagrams 3 and 4
Z <- seq(0, 1, len = knots)
bb <- b
for(kk in 1:2){
if(kk==1){b <- B
titl <-paste(paste("E-Estimate on [a,a+B], a = ",a),paste("B = ",b),sep=", ")}
else{b <- bb
titl <-paste(paste("E-Estimate on [a,a+b], a = ",a),paste("b = ",b),sep=", ")}
Ind <- rep(TRUE,length(Y))
Ind[(Y <= a)|(Y >= (a+b))] <- FALSE
IndN <-1*Ind
z <- seq(a,a+b,len=knots)
V <- Delta*IndN/hatG
YSC <- (Y-a)/b
hb.estF <-estcdenGEN(X = YSC, V=V, Z=Z,Zconf=Z, alpha=0.05,
NSimConfInt=100,
theta0=-10,FLAGNEG=0, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
hb.est <- b^(-1)*hb.estF$fest
hb.est[hb.est < 0] <-0
Marginb <- b^(-1)* hb.estF$Margin
MarginSimb <- b^(-1)* hb.estF$MarginSim
hb <- hGcornerf(c=corn,Z=z)$h
ISEM <- signif(b*mean((hb-hb.est)^2),2)
matplot(z,cbind(hb,hb.est,hb.est+Marginb,hb.est-Marginb,hb.est-MarginSimb,
hb.est+MarginSimb),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3),
main=paste(titl,paste(", N = ",sum(Delta*IndN))), ylab="h",
xlab="",sub=paste("ISE = ",ISEM))
}
}#end 6.2
if(fig == 3) {
if(is.na(corn)){corn <- 3}
if(is.na(n)){n <- 300}
if(is.na(uT)){uT <- .5}
if(is.na(lambdaT)){lambdaT<-.3}
if(is.na(a)){a <-.2}
if(is.na(A)){A <-.2}
if(is.na(b)){b <-.45}
if(is.na(B)){B <-.55}
if(is.na(a1)){a1 <-.2}
if(is.na(b1)){b1 <-.45}
par(mfrow = c(4, 1))
nn <- n
if(SIM==0){DATA <- read.table("Data6.3"); YY <- DATA[,1]; TT=DATA[,2]}
if(SIM==1){
FLAG <- 1; DATA <- NA
while(FLAG == 1){
X <- rcornerf(c=corn,n=nn);
if(trunc=="Unif"){T <- uT*runif(nn)}else{T <- rexp(nn,rate=1/lambdaT)}
MATT <- cbind(X,T); MAT <- MATT[X >= T,]
if(is.na(DATA[1])){DATA <- MAT}else{DATA <- rbind(DATA,MAT)}
if(nrow(DATA) >=n){DATA <- DATA[1:nn,]; FLAG <- 0}
}
YY <-DATA[,1]; TT <- DATA[,2]
if(WRITE){write(t(DATA), file="Data6.3", ncol=2)}
}
r <- order(YY)
Y <- YY[r]
T<- TT[r]
#Diagram1
plot(Y,Y,type="l",main=paste(paste("Truncated Data, n = ", nn)),
xlab="X",ylab="T",ylim=c(min(Y)-.01,max(Y)+.01),
xlim=c(min(Y)-.01,max(Y)+.01))
points(Y,T)
#Diagram 2
MTF <- matrix(T,ncol=nn,nrow=nn, byrow=T)
MT <- MTF
MT[row(MT) > col(MT)] <- max(Y) + 100
MTL <- (MT <= Y)
g <- apply(MTL,1,mean)
IndDD <- (Y>= a1) &(Y <= a1+b1)
d.vec <- cumsum((g^(-2))[IndDD])/(nn*(Y[IndDD]-a1+.01))
plot(Y[IndDD],1/g[IndDD],
type="p",pch=3,col=1,main=paste("Estimates of 1/g(x) and d(a1,x), a1 = ",
a1,", b1 = ",b1), #ylab=expression(1/hat(g)),
ylab="", xlim=c(min(Y)-.01,a1+b1),xlab="x") #max(Y)+.01),xlab="x")
par(new=TRUE)
plot(Y[IndDD],d.vec,xaxt="n",axes=F,ylab=NA,xlab=NA,
xlim=c(min(Y)-.01,a1+b1),col=1+COL)
axis(4)
#Diagrams 3 and 4
Z <- seq(0, 1, len = knots)
bb <- b
aa<- a
for(kk in 1:2){
if(kk==1){b <- B;a <- A
titl <-paste(paste("E-Estimate on [A,A+B], A = ",a),paste("B = ",b),sep=", ")}
else{b <- bb; a <- aa
titl <-paste(paste("E-Estimate on [a,a+b], a = ",a),paste("b = ",b),sep=", ")}
Ind <- rep(TRUE,length(Y))
Ind[(Y <= a)|(Y >= (a+b))] <- FALSE
IndN <-1*Ind
z <- seq(a,a+b,len=knots)
V <- IndN/g
YSC <- (Y-a)/b
hb.estF <-estcdenGEN(X = YSC, V=V, Z=Z,Zconf=Z, alpha=0.05,
NSimConfInt=100,
theta0=-10,FLAGNEG=0, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
hb.est <- b^(-1)*hb.estF$fest
hb.est[hb.est < 0] <-0
Marginb <- b^(-1)* hb.estF$Margin
MarginSimb <- b^(-1)* hb.estF$MarginSim
hb <- hGcornerf(c=corn,Z=z)$h
ISEM <- signif(b*mean((hb-hb.est)^2),2)
matplot(z,cbind(hb,hb.est,hb.est+Marginb,hb.est-Marginb,hb.est-MarginSimb,
hb.est+MarginSimb),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3),
main=paste(titl,paste("N = ",sum(IndN)),sep=", "),
ylab="h",xlab="",sub=paste("ISE = ",ISEM))
}
}#end 6.3
if((fig == 4)|(fig==5)) {
if(is.na(corn)){corn <- 3}
if(is.na(n)){n <- 300}
if(is.na(u)){u <- 0.5}
if(is.na(uT)){uT <- .5}
if(is.na(lambdaT)){lambdaT<-.3}
if(is.na(uC)){uC <- 1.5}
if(is.na(lambdaC)){lambdaC<-1.5}
if(is.na(a)){a <-.1}
if(is.na(A)){A <-.05}
if(is.na(b)){b <-.5}
if(is.na(B)){B <-.7}
if(is.na(a1)){a1 <-.05}
if(is.na(b1)){b1 <-.6}
par(mfrow = c(4, 1))
nn <- n
if(fig==4){DataName <- "Data6.4"}else{DataName <-"Data6.5"}
if(SIM==0){DATA <- read.table(DataName); YY <- DATA[,1]; TT<-DATA[,2]
DeltaN =DATA[,3]}
if(SIM==1){
FLAG <- 1; DATA <- NA
while(FLAG == 1){
X <- rcornerf(c=corn,n=nn);
if(trunc=="Unif"){TT <- uT*runif(nn)}else{TT <- rexp(nn,rate=1/lambdaT)}
if(cens=="Unif"){Z <- uC*runif(nn)}else{Z <- rexp(nn,rate=1/lambdaC)}
if(fig==5){Z <- pmin(u,Z) + TT}
YY <- pmin(X,Z); DeltaL <- X <= Z; DeltaN <- 1*DeltaL
MATT <- cbind(YY,TT,DeltaN); MAT <- MATT[YY >= TT,]
if(is.na(DATA[1])){DATA <- MAT}else{DATA <- rbind(DATA,MAT)}
if(nrow(DATA) >=n){DATA <- DATA[1:nn,]; FLAG <- 0}
}
YY <-DATA[,1]; TT <- DATA[,2]; DeltaN <- DATA[,3]
if(WRITE){write(t(DATA), file=DataName, ncol=3)}
}
r <- order(YY)
Y <- YY[r]; T<- TT[r]; Delta <- DeltaN[r]
#Diagram1
plot(Y,Y,type="l",main=paste(paste("LTRC Data, n = ", nn),
", N = ", sum(Delta)),
xlab="V",ylab="T",ylim=c(min(Y)-.01,max(Y)+.01),
xlim=c(min(Y)-.01,max(Y)+.01))
points(Y[Delta==1],T[Delta==1],pch=1,col=1)
points(Y[Delta==0],T[Delta==0],pch=2,col=1+COL)
if(fig==5){lines(Y+u,Y,type="l")}
#Diagram 2
MTF <- matrix(T,ncol=nn,nrow=nn, byrow=T)
MT <- MTF
MT[row(MT) > col(MT)] <- max(Y) + 100
MTL <- (MT <= Y)
g <- apply(MTL,1,mean)
IndDD <- (Y>= a1) &(Y <= a1+b1)&(Delta==1)
d.vec <- cumsum((g^(-2))[IndDD])/(nn*(Y[IndDD]-a1+.01))
plot(Y[IndDD],1/g[IndDD],type="p",pch=3,col=1,
main = paste("Estimates of 1/g(v) and d(a1,v), a1 = ",a1,", b1 = ",b1),
xlab=expression(paste(paste("V[", Delta),"==1]",sep="")),
ylab="",
xlim=c(min(Y[Delta==1])-.01,a1+b1+.01),)
par(new=TRUE)
plot(Y[IndDD],d.vec,xaxt="n",axes=F,ylab=NA,xlab=NA,
xlim=c(min(Y[Delta==1])-.01,a1+b1+.01),col=1)
axis(4)
mtext(expression(hat(d)),side=4,line=3)
#Diagrams 3 and 4
Z <- seq(0, 1, len = knots)
bb <- b
aa<- a
for(kk in 1:2){
if(kk==1){b <- B;a <- A
titl <-paste(paste("E-Estimate on [A,A+B], A = ",a),paste("B = ",b),sep=", ")}
else{b <- bb; a <- aa
titl <-paste(paste("E-Estimate on [a,a+b], a = ",a),paste("b = ",b),sep=", ")}
Ind <- rep(TRUE,length(Y))
Ind[(Y <= a)|(Y >= (a+b))] <- FALSE
IndN <-1*Ind
z <- seq(a,a+b,len=knots)
V <- Delta*IndN/g
YSC <- (Y-a)/b
hb.estF <-estcdenGEN(X = YSC, V=V, Z=Z,Zconf=Z, alpha=0.05,NSimConfInt=100,
theta0=-10,FLAGNEG=0, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
hb.est <- b^(-1)*hb.estF$fest
hb.est[hb.est < 0] <-0
Marginb <- b^(-1)* hb.estF$Margin
MarginSimb <- b^(-1)* hb.estF$MarginSim
hb <- hGcornerf(c=corn,Z=z)$h
ISEM <- signif(b*mean((hb-hb.est)^2),2)
matplot(z,cbind(hb,hb.est,hb.est+Marginb,hb.est-Marginb,hb.est-MarginSimb,
hb.est+MarginSimb),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3),
main=paste(titl,paste("N = ",sum(Delta*IndN)),sep=", "),
ylab="h",xlab="",sub=paste("ISE = ",ISEM))
}
}#End Fig 4-5
if((fig == 6)|(fig==7)) {
if(is.na(corn)){corn <- 3; if(fig==7){corn <- 4}}
if(is.na(n)){n <- 300; if(fig==7){n <- 300}}
if(is.na(uC)){uC <- 1.5;if(fig==7){uC <-.7}}
if(is.na(lambdaC)){lambdaC<-1.5}
if(fig==6){DataStr <-"Data6.6"} else{DataStr <-"Data6.7"}
par(mfrow = c(4, 1))
nn <- n
if(cens=="Unif"){param=paste(", uC = ",uC)}else{param=paste(", lambdaC = ",lambdaC)}
if(SIM==0){DATA <- read.table(DataStr); YY <- DATA[,1]; DeltaN=DATA[,2]}
if(SIM==1){X <- rcornerf(c=corn,n=nn);
if(cens=="Unif"){Z <- runif(nn,max=uC)}else{Z <- rexp(nn,rate=1/lambdaC)}
YY <- pmin(X,Z); DeltaL <- X <= Z; DeltaN <- 1*DeltaL
if(WRITE){write(t(cbind(YY,DeltaN)), file=DataStr, ncol=2)}
}
r <- order(YY)
V <- YY[r]
Delta <- DeltaN[r]
#Diagram1
plot(V,Delta, type="p",xlab="V",ylab=expression(Delta),ylim=c(-.1,1.1),
main=paste("Censored Data, cens = ",cens, ", n = ", nn, ", N = ",sum(Delta),
param))
#Diagram 2
GX <-hGcornerf(c=corn,Z=V)$G
if(cens=="Unif"){GC <- punif(V,max=uC,lower.tail=F)}
else{GC <- pexp(V,rate=1/lambdaC,lower.tail=F)}
GV <-GX*GC
g.est <- (nn-rank(V) +1)/nn
HC.est <- apply((1-lower.tri(matrix(1,ncol=nn,nrow=nn)))*(1-Delta)/g.est,2,mean)
GC.est <- exp(-HC.est)
matplot(V,cbind(GC,GC.est),main="Survival Function of C and its Estimates",
xlab="C", ylab="", col=c(1,1+COL),type="l")
##Kaplan-Meyer
surv.object <- Surv(time=V,event=1*(1-Delta))
KMfit <- summary(survfit(surv.object~1))$surv
lines(V[Delta==0],KMfit,col=1+2*COL, lty=3)
##Diagram 3
z <- seq(0,1,len=knots)
GC.est[GC.est < 1/log(nn)] <- 1/log(nn)
VVV <- Delta/GC.est
f.estF <-estcdenGEN(X = V, V=VVV, Z=z,Zconf=z, alpha=alpha,
NSimConfInt=100,
theta0=-10,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
f.est <- f.estF$fest
Margin <- f.estF$Margin
MarginSim <- f.estF$MarginSim
f <- dcornerf(c=corn,Z=z)
ISEM <- signif(mean((f-f.est)^2),2)
d.est <- mean(VVV^2)
matplot(z,cbind(f,f.est,f.est+Margin,f.est-Margin,f.est-MarginSim,f.est+MarginSim),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3),
main="Density of X, E-estimate and Confidence Bands",
ylab="",xlab=paste("ISE = ",ISEM))
##Diagram 4
b <- max(V)
z <- seq(0,1,len=knots)
zb <- seq(0,b,len=knots)
VVV <- Delta/GC.est
Vsc <-V/b
f.estF <-estcdenGEN(X = Vsc, V=VVV, Z=z,Zconf=z, alpha=alpha,
NSimConfInt=100,
theta0=-10,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
f.est <- f.estF$fest/b
Margin <- f.estF$Margin
MarginSim <- f.estF$MarginSim
f <- dcornerf(c=corn,Z=zb)
ISEM <- signif(b*mean((f-f.est)^2),2)
d.est <- mean(VVV^2/b)
matplot(zb,cbind(f,f.est,f.est+Margin,f.est-Margin,f.est-MarginSim,f.est+MarginSim),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3),
main="Density of X, E-estimate and Confidence Bands", ylab="",
xlab=substitute(paste("ISE = ",aa,", ",hat(d)," = ",bb),list(aa=ISEM,bb=signif(d.est,2))))
}#end 6-7
##################################
if(fig == 8) {
if(is.na(corn)){corn <- 4}
if(is.na(n)){n <- 200}
if(is.na(uT)){uT <-.7}
par(mfrow = c(3, 1))
nn <- n
XP <- rcornerf(c=corn,n=10000);
TP <- uT*runif(10000)
pp <-mean(TP <= XP)
if(SIM==0){DATA <-read.table("Data6.8");YY <- DATA[,1];TT=DATA[,2];pp <- DATA[1,3]
}
if(SIM==1){
FLAG <- 1; DATA <- NA
while(FLAG == 1){
X <- rcornerf(c=corn,n=nn);
T <- uT*runif(nn)
MATT <- cbind(X,T); MAT <- MATT[X >= T,]
if(is.na(DATA[1])){DATA <- MAT}else{DATA <- rbind(DATA,MAT)}
if(nrow(DATA) >=n){DATA <- DATA[1:nn,]; FLAG <- 0}
}
YY <-DATA[,1]; TT <- DATA[,2]
DATA <- cbind(DATA, matrix(pp,ncol=1,nrow=nn))
if(WRITE){write(t(DATA), file="Data6.8", ncol=3)}
}
r <- order(YY)
X <- YY[r]
T<- TT[r]
z <- seq(0,1,len=knots)
MTF <- matrix(T,ncol=nn,nrow=nn, byrow=TRUE)
MT <- MTF
MT[row(MT) > col(MT)] <- max(X) + 100
MTL <- (MT <= X)
gX.est <- apply(MTL,1,mean)
cdfT <- X/uT
cdfT[cdfT > 1] <-1
GX <-hGcornerf(c=corn,Z=X)$G
gX <- cdfT*GX/pp
matplot(X,cbind(gX,gX.est),pch=c(1,3),col=c(1,1+COL),ylab="",
main=paste("g(X) and its Estimate, n = ",nn,", uT = ",uT))
points(T, rep(gX[1]/4,nn), pch=2)
Ind <-matrix(X,ncol=knots,nrow=nn)<=matrix(z,ncol=knots,nrow=nn,byrow=TRUE)
Hz.est <- apply(Ind/matrix(gX.est,ncol=knots,nrow=nn),2,mean)
Gznew.est <- 1-apply(Ind,2,mean)[z >max(T)]
IndX <-matrix(X,ncol=nn,nrow=nn)<=matrix(X,ncol=nn,nrow=nn,byrow=TRUE)
HX.est <- apply(IndX/matrix(gX.est,ncol=nn,nrow=nn),2,mean)
G.Tmax <- exp(-mean((X <= max(T))/gX.est))
p.est <- G.Tmax/mean((max(T) <= X))
Gz.est <- exp(-Hz.est)
Gznew.est <- p.est*Gz.est
matplot(z,cbind(hGcornerf(c=corn,Z=z)$G,exp(-Hz.est)),
ylab="",
type="l",col=c(1,1+COL), lwd=c(3,2),
main="Survival Function and its Estimates",
xlab=substitute(paste("p = ",a,", ",hat(p), " = ",b),
list(a=signif(pp,2),b=signif(p.est,2))))
surv.object <- Surv(T,X,rep(1,nn))
KMfit <- summary(survfit(surv.object~1))$surv
lines(X,KMfit,lty=3,col=1+3*COL)
V <- exp(-HX.est)/gX.est
f.estF <-estcdenGEN(X = X, V=V, Z=z,Zconf=z, alpha=alpha,
NSimConfInt=100,
theta0=-10,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
f.est <- f.estF$fest
Margin <- f.estF$Margin
MarginSim <- f.estF$MarginSim
f <- dcornerf(c=corn,Z=z)
ISEM <- signif(mean((f-f.est)^2),2)
d.est <- mean(V^2)
matplot(z,cbind(f,f.est,f.est+Margin,f.est-Margin,f.est-MarginSim,f.est+MarginSim),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3),
main="Density, E-estimate and Confidence Bands",
ylab="",
xlab=substitute(paste("ISE = ",aa,", ",hat(d)," = ",bb),list(aa=ISEM,bb=signif(d.est,2))))
}#end 6.8
##############################
if(fig == 9) {
RM <- NULL
if(is.na(corn)){corn <- 2}
if(is.na(n)){n <- 75}
if(is.na(uT)){uT <- .7}
if(is.na(nsim)){nsim <-100}
if(is.na(NFIG)){NFIG <-2}
if(is.na(mT)){mT <-0}
nsimT <- nsim
par(mfrow=c(NFIG,1))
nn <- n
DATAM <- NULL
if(SIM==0){DATA <-read.table("Data6.9"); nsim <- NFIG}
for(k in (1:nsim)){
if (SIM==0){YY <- DATA[,2*k-1];TT <- DATA[,2*k]}
if(SIM==1){DATA <- NA
FLAG <- 1;
while(FLAG == 1){
X <- rcornerf(c=corn,n=nn);
T <- uT*runif(nn)
MATT <- cbind(X,T); MAT <- MATT[X >= T,]
if(is.na(DATA[1])){DATA <- MAT}else{DATA <- rbind(DATA,MAT)}
if(nrow(DATA) >=n){DATA <- DATA[1:nn,]; FLAG <- 0}
}
YY <-DATA[,1]; TT <- DATA[,2]
if(k > nsim-NFIG){DATAM <- cbind(DATAM,DATA)}
}
r <- order(YY)
X <- YY[r]
T<- TT[r]
TMAX <- max(T)+mT
z <- seq(max(T),1,len=knots)
MTF <- matrix(T,ncol=nn,nrow=nn, byrow=TRUE)
MT <- MTF
MT[row(MT) > col(MT)] <- max(X) + 100
MTL <- (MT <= X)
gX.est <- apply(MTL,1,mean)
Ind <-matrix(X,ncol=knots,nrow=nn)<=matrix(z,ncol=knots,nrow=nn,byrow=TRUE)
Hz.est <- apply(Ind/matrix(gX.est,ncol=knots,nrow=nn),2,mean)
Gz.est <- exp(-Hz.est)
Gz.est[z >=max(X)] <- 0
G.TMAX <- exp(-mean((X <= TMAX)/gX.est))
p.est <- G.TMAX/mean((TMAX <= X))
Gobserved.est <- 1-apply(Ind,2,mean)
Gznew.est <- p.est*Gobserved.est
Gz <- hGcornerf(c=corn,Z=z)$G
RC <- mean((Gz-Gz.est)^2)/mean((Gz-Gznew.est)^2)
RM <- cbind(RM,RC)
ttt <-paste("ISE/ISEN = ",signif(RC,3))
mttt <-"Tail of Survival Function and its Estimates"
if(k==nsim){meaNN <-signif(mean(RM),3);medN <- signif(median(RM),3)
if(SIM==0){meaNN <-DATA[1,2*NFIG+1];medN <- DATA[1,2*NFIG+2]
nsimT <- DATA[1,2*NFIG+3]}
ttt <-paste("ISE/ISEN = ",signif(RC,3),
", Mean(ISE/ISEN) = ",meaNN,
", Median(ISE/ISEN) = ",medN)
mttt=paste("n = ",nn,", uT = ",uT, ", corn = ",corn,
", nsim = ",nsimT,sep="")}
if(k >nsim-NFIG){matplot(z,cbind(Gz,Gz.est,Gznew.est),
ylab="",xlab=ttt,
type="l",col=c(1,1+COL,1+2*COL), lwd=c(1,2,2),main=mttt)}
}
if(SIM==1 & WRITE){DATAM <- cbind(DATAM,signif(mean(RM),3),signif(median(RM),3),nsim)
write(t(DATAM), file="Data6.7", ncol=2*NFIG+3)}
}#end 6.9
##################################
if(fig == 10) {
if(is.na(corn)){corn <- 4}
if(is.na(n)){n <- 100}
if(is.na(uT)){uT <-.7}
if(is.na(alpha)) {alpha <- .05}
par(mfrow = c(3, 1))
nn <- n
if(SIM==0){DATA <-read.table("Data6.10");YY <- DATA[,1];TT=DATA[,2]
}
if(SIM==1){
FLAG <- 1; DATA <- NA
while(FLAG == 1){
X <- rcornerf(c=corn,n=nn);
T <- uT*runif(nn)
MATT <- cbind(X,T); MAT <- MATT[X >= T,]
if(is.na(DATA[1])){DATA <- MAT}else{DATA <- rbind(DATA,MAT)}
if(nrow(DATA) >=n){DATA <- DATA[1:nn,]; FLAG <- 0}
}
YY <-DATA[,1]; TT <- DATA[,2]
if(WRITE){write(t(DATA), file="Data6.10", ncol=2)}
}
r <- order(TT)
X <- YY[r]
T<- TT[r]
z <- seq(0,max(T),len=knots)
#Diagram 1
plot(X,T, type="p",main=paste(paste("LT Data, n = ",nn),
paste(" uT = ", uT),sep=", "))
MXF <- matrix(X,ncol=nn,nrow=nn, byrow=TRUE)
MX <- MXF
MX[row(MX) < col(MX)] <- -5
MXL <- (MX >= T)
gT.est <- apply(MXL,1,mean)
Indz <-matrix(T,ncol=knots,nrow=nn)>=matrix(z,ncol=knots,nrow=nn,byrow=TRUE)
Qz.est <- apply(Indz/matrix(gT.est,ncol=knots,nrow=nn),2,mean)
IndT <-matrix(T,ncol=nn,nrow=nn)>=matrix(T,ncol=nn,nrow=nn,byrow=TRUE)
QT.est <- apply(IndT/matrix(gT.est,ncol=nn,nrow=nn),2,mean)
Fz.est <- exp(-Qz.est)
Fz.est[z >=max(T)] <- 1
FT.est <- exp(-QT.est)
FT.est[T >=max(T)] <- 1
VarQ <- (1/n)* (apply(Indz/matrix((gT.est)^2,ncol=knots,nrow=nn),2,mean) - (Qz.est)^2)
VarF<- (Fz.est)^2*VarQ; q <- qnorm(alpha/2,lower.tail=F)
Uband <- Fz.est + q*(VarF)^(1/2);Lband <- Fz.est - q*(VarF)^(1/2)
matplot(z,cbind(z/uT,Fz.est,Uband,Lband),
ylab="", type="l", lty=c(1,2,3,3),
col=c(1,1+COL,1+2*COL,1+2*COL), lwd=rep(2,4),
main=expression(paste("Cumulative Distribution Function of ", T^"*", ", its Estimate and Band")),
xlab=substitute(paste(alpha, " = ",b),
list(b=alpha)))
V <- FT.est/gT.est
Tscaled <- T/max(T)
f.estF <-estcdenGEN(X = Tscaled, V=V, Z=z,Zconf=z, alpha=alpha,
NSimConfInt=100,
theta0=-10,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
f.est <- f.estF$fest/max(T)
Margin <- f.estF$Margin
MarginSim <- f.estF$MarginSim
f <- rep(1/uT,knots)
ISEM <- signif(mean((f-f.est)^2)*max(T),2)
matplot(z,cbind(f,f.est,f.est+Margin,f.est-Margin,f.est-MarginSim,f.est+MarginSim),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3), lwd=rep(1.5,4),
main=expression(paste("Density of ",T^"*",", E-estimate and Confidence Bands")),
ylab="",xlab=paste("ISE = ",ISEM))
}#end 6.10
###############
if(fig == 11) {
gNest <- function(T=NA,V=NA,X=NA){
g <- rep(-10,length(X))
for(i in 1:length(X)){g[i] <- mean((T <= X[i])&(X[i] <= V))
}
g}
if(is.na(corn)){corn <- 4}
if(is.na(n)){n <- 200}
if(is.na(uT)){uT <-.7}
if(is.na(ut)){ut <- .2}
par(mfrow = c(3, 1))
nn <- n
XP <- rcornerf(c=corn,n=10000);
TP <- runif(10000,min=ut,max=uT)
pp <-mean(TP <= XP)
if(SIM==0){DATA <-read.table("Data6.11");YY <- DATA[,1];TT=DATA[,2];
pp <- DATA[1,3]
}
if(SIM==1){
FLAG <- 1; DATA <- NA
while(FLAG == 1){
X <- rcornerf(c=corn,n=nn);T <- runif(nn,min=ut,max=uT)
MATT <- cbind(X,T); MAT <- MATT[X >= T,]
if(is.na(DATA[1])){DATA <- MAT}else{DATA <- rbind(DATA,MAT)}
if(nrow(DATA) >=n){DATA <- DATA[1:nn,]; FLAG <- 0}
}
YY <-DATA[,1]; TT <- DATA[,2]
DATA <- cbind(DATA, matrix(pp,ncol=1,nrow=nn))
if(WRITE){write(t(DATA), file="Data6.11", ncol=3)}
}
r <- order(YY)
X <- YY[r]
T<- TT[r]
z <- seq(min(X)-.001,1,len=knots)
MTF <- matrix(T,ncol=nn,nrow=nn, byrow=TRUE)
MT <- MTF
MT[row(MT) > col(MT)] <- max(X) + 100
MTL <- (MT <= X)
gX.est <- apply(MTL,1,mean)
cdfT <- (X-ut)/(uT-ut)
cdfT[cdfT > 1] <-1
GX <-hGcornerf(c=corn,Z=X)$G
gX <- cdfT*GX/pp
matplot(X,cbind(gX,gX.est),pch=c(1,3),col=c(1,1+COL),xlim=c(min(T),1),
ylim=c(-.1,max(c(gX,gX.est))), ylab="",
main=paste("g(X) and its Estimate, n = ",nn,", ut = ",ut,", uT = ",uT))
points(T, rep(-.1,nn), pch=2, col=1)
#Diagram 2
Ind <-matrix(X,ncol=knots,nrow=nn)<=matrix(z,ncol=knots,nrow=nn,byrow=TRUE)
Hz.est <- apply(Ind/matrix(gX.est,ncol=knots,nrow=nn),2,mean)
Gznew.est <- 1-apply(Ind,2,mean)[z >max(T)]
IndX <-matrix(X,ncol=nn,nrow=nn)<=matrix(X,ncol=nn,nrow=nn,byrow=TRUE)
HX.est <- apply(IndX/matrix(gX.est,ncol=nn,nrow=nn),2,mean)
G.Tmax <- exp(-mean((X <= max(T))/gX.est))
p.est <- G.Tmax/mean((max(T) <= X))
Gz.est <- exp(-Hz.est)
Gz.est[1] <- 1
Gznew.est <- p.est*Gz.est
Gcond <- hGcornerf(c=corn,Z=z)$G/(hGcornerf(c=corn,Z=ut)$G)
matplot(z,cbind(hGcornerf(c=corn,Z=z)$G,Gz.est,Gcond),
ylab="",lty=c(1,2,1),
type="l",col=c(1,1+COL), lwd=c(3,2,1),
main="Survival Function and its Estimates",
xlab=substitute(paste("p = ",a,", ",hat(p), " = ",b),
list(a=signif(pp,2),b=signif(p.est,2))))
surv.object <- Surv(T,X,rep(1,nn))
KMfit <- summary(survfit(surv.object~1))$surv
if(length(KMfit) = TT,]
if(is.na(DATA[1])){DATA <- MAT}else{DATA <- rbind(DATA,MAT)}
if(nrow(DATA) >=n){DATA <- DATA[1:nn,]; FLAG <- 0}
}
YY <-DATA[,1]; TT <- DATA[,2]; DeltaN <- DATA[,3]
if(WRITE){write(t(DATA), file=DataName, ncol=3)}
}
r <- order(YY)
V <- YY[r]; T<- TT[r]; Delta <- DeltaN[r]
#Diagram1
subb <- paste("uc = ",uc,", uC = ",uC)
if(cens=="Expon"){subb <- paste(", lambdaC = ",lambdaC)}
if(trunc=="Unif"){subT <-paste(", ut = ",ut,", uT = ",uT)}
else{subT <- paste(", lambdaT = ", lambdaT)}
subb <-paste(subT,subb,sep=", ")
if(fig==15){subb<- paste(subb,", censp = ",censp)}
plot(V,Delta,type="p",main=paste("LTRC Data, ",
" n = ", nn,", N = ", sum(Delta),subb), ylab="",
xlab="T, V", ylim=c(0,2))
points(T,rep(1.5,nn),pch=3,col=1+COL)
#Diagram 2
MTF <- matrix(T,ncol=nn,nrow=nn, byrow=T)
MT <- MTF
MT[row(MT) > col(MT)] <- max(V) + 100
MTL <- (MT <= V)
gV.est <- apply(MTL,1,mean)
HXV.est <- apply((1-lower.tri(matrix(1,ncol=nn,nrow=nn)))*Delta/gV.est,2,mean)
GXV.est <- exp(-HXV.est)
VARR <- GXV.est^2*(apply((1-lower.tri(matrix(1,ncol=nn,nrow=nn)))*Delta/gV.est^2,2,mean)-HXV.est^2)
band <- qnorm(alpha/2,lower.tail=F)*(VARR/nn)^(1/2)
GX <-hGcornerf(c=corn,Z=V)$G
GXut <-hGcornerf(c=corn,Z=ut)$G
KMfit <- survfit(coxph(Surv(T,V,Delta)~1),type="kaplan-meier")
matplot(V,cbind(GX/GXut,GXV.est,GXV.est+band,GXV.est-band),lty=c(1,2,3,3),lwd=1.5,
main=substitute(paste("Conditional Survival Function of X"^"*",", Estimates and Confidence Band")),
xlab="x", ylab="", col=c(1,1+COL,1+2*COL,1+2*COL),type="l")
lines(KMfit$time,KMfit$surv,col=1+3*COL, lty=4)
##Diagram 3
if(is.na(a)){a <-min(V)}
if(is.na(b)){b <-max(V)-min(V)}
titl <- substitute(paste("Conditional Density of X"^"*",", E- Estimate and Confidence Bands"))
Ind <- rep(TRUE,length(V))
Ind[(V <= a)|(V >= (a+b))] <- FALSE
IndN <-1*Ind
z <- seq(a,a+b,len=knots)
zz <- seq(0,1,len=knots)
VV <- Delta*IndN*GXV.est/gV.est
VSC <- (V-a)/b
estF <-estcdenGEN(X = VSC, V=VV, Z=zz,Zconf=zz, alpha=alpha,NSimConfInt=100,
theta0=-10,FLAGNEG=0, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
f.est <- b^(-1)*estF$fest
f.est[f.est < 0] <-0
Marginb <- b^(-1)* estF$Margin
MarginSimb <- b^(-1)* estF$MarginSim
d.est <- mean((Delta*IndN*GXV.est/gV.est)^2)/b
f <- dcornerf(c=corn,Z=z)
ISEM <- signif(b*mean((f-f.est)^2),2)
matplot(z,cbind(f/GXut,f.est,f.est+Marginb,f.est-Marginb,f.est-MarginSimb,
f.est+MarginSimb),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3), main=titl,ylab="",lwd=1.5,
xlab=substitute(paste("ISE = ",aa,", ",hat(d)," = ",bb,
", a = ",cc,", a+b = ",dd),list(aa=ISEM,bb=signif(d.est,2),cc=signif(a,2),dd=signif(a+b,2))))
}#end 6.14-15
if((fig == 16)|(fig==17)) {
if(is.na(corn)){corn <- 2}
if(is.na(n)){n <- 300
if(fig==17){n <- 200}}
if(is.na(a)){a <-0.3}
if(is.na(lambdaC)){lambdaC<-2
if(fig==17){lambdaC <- 5}}
DDATA <-"Data6.16"
if(fig==17){DDATA <- "Data6.17"}
par(mfrow = c(3, 1))
nn <- n; z <- seq(0,1,len=knots)
if(SIM==0){DATA <- read.table(DDATA);X <- DATA[,1]; V <-DATA[,2];
DeltaN=DATA[,3]; DeltaL <- (DeltaN > 0);Y <- DATA[,4] }
if(SIM==1){X <- runif(nn)
m<- a + dcornerf(cornerf=corn,Z=X); Y<- rexp(nn,rate=1/m)
C<- rexp(nn,rate=1/lambdaC)
V <- pmin(Y,C); DeltaL <- (Y <= C); DeltaN <- 1*DeltaL
if(WRITE){write(t(cbind(X,V,DeltaN,Y)), file=DDATA, ncol=4)}
}
r <- order(V);X <- X[r];V <- V[r];DeltaN <- DeltaN[r]; DeltaL <- DeltaL[r]; Y <- Y[r]
m<- a + dcornerf(cornerf=corn,Z=z)
# Diagram1 Scattergram
plot(X[DeltaL],V[DeltaL], type="p",pch=1,xlab="X",ylab="V",ylim=range(0,max(V)),
main=paste("Censored Data, n = ", nn, ", N = ",sum(DeltaN),", lambdaC = ",lambdaC))
points(X[!DeltaL],V[!DeltaL], type="p", pch=3)
# Diagram 2 Underlying Scattergram
mO.est <- estcregN(X = X, Y = Y, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
matplot(z,cbind(m,mO.est),type="l",lty = c(1,4),ylim=range(c(0,Y)),
main = "Hidden Data and Regression", xlab="X", ylab="Y", lwd=2, col=c(1,1+COL))
points(X,Y,type="p")
m.est <- estcregN(X = X[DeltaL], Y = V[DeltaL], Z=z,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
llim <- range(c(V[DeltaL],m,m.est))
g.est <- (nn-rank(V) +1)/nn
HC.est <- apply((1-lower.tri(matrix(1,ncol=nn,nrow=nn)))*(1-DeltaN)/g.est,2,mean)
GC.est <- exp(-HC.est)
GC <- pexp(V,rate=1/lambdaC,lower.tail=F)
mN.est <- estcregN(X = X, Y = V, Z=z, V = DeltaN/GC.est, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
matplot(z,cbind(m,mN.est,m.est,mO.est),main="Regression Estimates", #ylim=range(V*DeltaN/GC.est),
xlab="x", ylab="m(x)", col=c(1,1+(1:3)*COL),type="l",lwd=2)
}#end 6.16-17
if((fig == 18)|(fig==19)) {
if(is.na(corn)){corn <- 4}
if(is.na(n)){n <- 300}
if(is.na(sigma)){sigma <- 1}
if(is.na(uC)){uC<-1.1
if(fig==19){uC <- .9}}
DDATA <-"Data6.18"
if(fig==19){DDATA <- "Data6.19"}
par(mfrow = c(3, 1))
nn <- n; z <- seq(0,1,len=knots)
if(SIM==0){DATA <- read.table(DDATA);X <- DATA[,1]; V <-DATA[,2];
DeltaN=DATA[,3]; DeltaL <- (DeltaN > 0);Y <- DATA[,4] }
if(SIM==1){X <- runif(nn);Y <- dcornerf(cornerf=corn,Z=X) + sigma*rnorm(nn)
C<- uC* runif(nn); V <- pmin(X,C); DeltaL <- (X <= C); DeltaN <- 1*DeltaL
if(WRITE){write(t(cbind(X,V,DeltaN,Y)), file=DDATA, ncol=4)}
}
m<- dcornerf(cornerf=corn,Z=z)
#Diagram1 Scattergram
plot(V[DeltaL],Y[DeltaL], type="p",pch=1,xlab="U",ylab="Y",ylim=range(Y),
xlim=c(0,1),
main=paste("Censored Data, n = ", nn, ", N = ",
sum(DeltaN),", sigma = ", sigma,", uC = ",uC))
points(V[!DeltaL],Y[!DeltaL], type="p", pch=3)
# Diagram 2 Underlying Scattergram
mO.est <- estcregN(X = X, Y = Y, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
mO.est[mO.est < 0] <- 0
matplot(z,cbind(m,mO.est),type="l",lty = c(1,3),ylim=range(Y),
main = "Hidden Data and Regression", xlab="X", ylab="Y", lwd=2, col=c(1,1+2*COL))
points(X,Y,type="p")
#Diagram 3 Complete Case Approach
bb <- max(V); VSC <- V/bb; zSC <- seq(0, bb, len=knots)
m.est <- estcregN(X = VSC[DeltaL], Y = Y[DeltaL], Z=z,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
m.est[m.est < 0] <- 0
llim <- range(c(Y[DeltaL],m,m.est,mO.est))
matplot(z[z <= bb],cbind(m,mO.est)[z <= bb,],main="Uncensored-Case Regression",
ylim=llim,lty=c(1,3), xlim=c(0,1),
xlab="x", ylab="m(x)", col=c(1,1+2*COL),type="l",lwd=2)
lines(zSC,m.est,type="l", lty=2, col=1+COL, lwd=2)
points(V[DeltaL],Y[DeltaL], type="p", pch=1)
} #End 6.18-19
}#End Chapter 6
########################################
######################################################################
########################################################################
# CHAPTER 7
################################################################################
###############
ch7 <-function(fig = NA,corn=NA,w=NA,c=NA,
SIM=1,COL=1, a=NA,A=NA,b=NA,B=NA, n=NA, lambdaC=NA,
lambdaT=NA,k=NA,sh1=NA,sh2=NA,sc1=NA,sc2=NA, nsim=NA,NFIG=NA,mT=NA,
knots=100, alpha=0.05,WRITE=F, cens="Unif", trunc=NA,
uT=NA,ut=NA,uC=NA, uc=NA,a1=NA,b1=NA,censp=NA,
CFUN = list(NA, NA),cJ0 = 4, cJ1 = 0.5, cTH = 4,cB = 2,cTP=NA){
##################################################
if(fig<10){if(is.na(trunc)){trunc <- "Unif"}}
if(fig==10){if(is.na(trunc)){trunc <- "Expon"}}
######
if(fig == 1 | fig==2) {
if(is.na(corn)){corn <- 3; if(fig==2){corn <- 4}};if(is.na(c)){c <- 1}
if(is.na(n)){n <- 300; if(fig==2){n <- 300}}
if(is.na(uC)){uC <- 1.5;if(fig==2){uC <-.7}}
if(is.na(lambdaC)){lambdaC<-1.5}
if(is.na(w)){w =".1+.8*exp(1+6*(v-.5))/(1+exp(1+6*(v-.5)))"}
if(fig==1){DataStr <-"Data7.1"} else{DataStr <-"Data7.2"}
par(mfrow = c(4, 1))
nn <- n
if(cens=="Unif"){param=paste(", uC = ",uC)}else{param=paste(", lambdaC = ",lambdaC)}
if(SIM==0){DATA <- read.table(DataStr); YY <- DATA[,1]; DeltaN=DATA[,2];A <-DATA[,3]}
if(SIM==1){X <- rcornerf(c=corn,n=nn);
if(cens=="Unif"){Z <- runif(nn,max=uC)}
else{param=paste(", lambdaC = ",lambdaC); Z <- rexp(nn, rate=1/lambdaC)}
YY <- pmin(X,Z); DeltaL <- X <= Z; DeltaN <- 1*DeltaL
wYY <- readw(fun=w,z=YY)
A <-rbinom(n,1,wYY)
if(WRITE){write(t(cbind(YY,DeltaN,A)), file=DataStr, ncol=3)}
}
r <- order(YY)
V <- YY[r]
Delta <- DeltaN[r]
A <-A[r]
wV <- readw(fun=w,z=V)
a <- min(V)
b <- max(V) -a
#Diagram1
plot(V,Delta, type="p",xlab="V",ylab=expression(Delta),ylim=c(-.1,1.1),
main=paste("Missing Censored Data, cens = ",cens, ", n = ", nn, ", N = ",sum(Delta),
", M = ",sum(A*Delta),param))
points(V[A==0],Delta[A==0],pch=4,col=1+COL)
#Diagram 2
w.est <-estcregN(X = (V-a)/b, Y=A,Z=(V-a)/b, cJ0 = cJ0, cJ1 = cJ1,cTH= cTH,cB = cB)$fest
w.est[w.est > 1] <- 1
w.est[w.est < c/log(nn)] <- c/log(nn)
llim=range(cbind(0,1,wV,w.est))
w.est <- as.vector(w.est)
matplot(V,cbind(wV,w.est),type="l",lty=1:2,ylim=llim,lwd=1.5,
xlab="v",main="w(v)",ylab="A",col=c(1,1+COL))
points(V,A,pch=1)
#Diagram 3
GX <-hGcornerf(c=corn,Z=V)$G
if(cens=="Unif"){GC <- punif(V,max=uC,lower.tail=F)}
else{GC <- pexp(V,rate=1/lambdaC,lower.tail=F)}
g.est <- (nn-rank(V) +1)/nn
g.est[g.est < c/log(nn)] <- c/log(nn)
HC.est <- apply((1-lower.tri(matrix(1,ncol=nn,nrow=nn)))*A*(1-Delta)/(g.est*w.est),2,mean)
GC.est <- exp(-HC.est)
HX.est <- apply((1-lower.tri(matrix(1,ncol=nn,nrow=nn)))*A*Delta/(g.est*w.est),2,mean)
GX.est <- exp(-HX.est)
matplot(V,cbind(GX,GX.est,GC,GC.est),
main="Survival Functions of X and C and their Estimates",
xlab="x", ylab="", col=c(1,1+COL,1+2*COL,1+3*COL),type="l",lwd=1.5)
##Diagram 4
a <- min(V)
b <- max(V)-a
z <- seq(0,1,len=knots)
zb <- seq(a,a+b,len=knots)
PP <- GC.est*w.est
PP[PP < (1/log(nn))^2] <- (1/log(nn))^2
VVV <- A*Delta/PP
Vsc <-(V-a)/b
f.estF <-estcdenGEN(X = Vsc, V=VVV, Z=z,Zconf=z, alpha=alpha,
NSimConfInt=100,
theta0=-10,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
f.est <- f.estF$fest/b
Margin <- f.estF$Margin
MarginSim <- f.estF$MarginSim
f <- dcornerf(c=corn,Z=zb)
ISEM <- signif(b*mean((f-f.est)^2),2)
d.est <- mean(VVV^2/b)
matplot(zb,cbind(f,f.est,f.est+Margin,f.est-Margin,f.est-MarginSim,f.est+MarginSim),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3), lwd=1.5,
main="Density of X, E-estimate and Confidence Bands", ylab="",
xlab=substitute(paste("ISE = ",aa,", ",hat(d)," = ",bb),list(aa=ISEM,bb=signif(d.est,2))))
}#End 7.1-2
#########
if(fig == 3 | fig==444) {
if(is.na(corn)){corn <- 3
if(is.na(n)){n <- 300; if(fig==444){n <- 300}}
if(is.na(uC)){uC <- 1.3};if(fig==444){uC <-.7}}
if(is.na(lambdaC)){lambdaC<-1.5}
if(is.na(w)){w =".1+.8*exp(1+6*(x-.5))/(1+exp(1+6*(x-.5)))"}
if(fig==3){DDATA <-"Data7.3"}
par(mfrow = c(4, 1))
nn <- n
if(cens=="Unif"){param=paste(", uC = ",uC)}else{param=paste(", lambdaC = ",lambdaC)}
if(SIM==0){DATA <- read.table(DDATA); YY <- DATA[,1]; DeltaN=DATA[,2];A <-DATA[,3]
X <- DATA[,4]}
if(SIM==1){X <- rcornerf(c=corn,n=nn);
if(cens=="Unif"){Z <- runif(nn,max=uC)}else{param=paste(", lambdaC = ",lambdaC)}
YY <- pmin(X,Z); DeltaL <- X <= Z; DeltaN <- 1*DeltaL
wX <- readw(fun=w,z=X)
A <-rbinom(n,1,wX)
if(WRITE){write(t(cbind(YY,DeltaN,A,X)), file=DDATA, ncol=4)}
}
r <- order(YY)
V <- YY[r]
Delta <- DeltaN[r]
A <-A[r]
X <- X[r]
a <- min(V[A==1])
b <- max(V[(A*Delta)==1]) - a
Vab <- V[(V >=a)&(V <= a+b)]
Aab <- A[(V >=a)&(V <= a+b)]
Deltaab <- Delta[(V >=a)&(V <= a+b)]
wX <- readw(fun=w,z=Vab)
#Diagram1
plot(V,Delta, type="p",xlab="V",ylab=expression(Delta),ylim=c(-.1,1.1),
main=paste("Missing Censored Data, cens = ",cens, ", n = ", nn, ", N = ",sum(Delta),
", M = ",sum(A*Delta),param))
points(V[A==0],Delta[A==0],pch=4,col=1+COL)
#Diagram 2
VSC <- (Vab[Deltaab==1]-a)/b
wX.est <-estcregN(X = VSC, Y=Aab[Deltaab==1],Z=(Vab-a)/b, cJ0 = cJ0, cJ1 = cJ1,cTH= cTH,cB = cB)$fest
wX.est[wX.est > 1] <- 1
wX.est[wX.est < 1/log(nn)] <- 1/log(nn)
wV.est <-estcregN(X = (V-min(V))/(max(V) - min(V)), Y=A,Z=(Vab-min(V))/(max(V) -min(V)),
cJ0 = cJ0, cJ1 = cJ1,cTH= cTH,cB = cB)$fest
wV.est[wV.est > 1] <- 1
wV.est[wV.est < 1/log(nn)] <- 1/log(nn)
llim=range(cbind(0,1,wX))
wX.est <- as.vector(wX.est)
wV.est <- as.vector(wV.est)
matplot(Vab,cbind(wX,wX.est),type="l",lty=1:2,ylim=llim,lwd=1.5,
xlab="X",main="w(x) and its Estimate",ylab="A",col=c(1,1+COL))
points(Vab[Deltaab==1],Aab[Deltaab==1],pch=1)
#Diagram 3
GX <-hGcornerf(c=corn,Z=V)$G
if(cens=="Unif"){GC <- punif(V,max=uC,lower.tail=F)}
else{GC <- pexp(V,rate=1/lambdaC,lower.tail=F)}
GV <-GX*GC
g.est <- (nn-rank(V) +1)/nn
wXX.est <- rep(1,nn)
wXX.est[(V >=a)&(V <= a+b)] <- wX.est
wXX <- rep(1,nn)
wXX[(V >=a)&(V <= a+b)] <-wX[(V >=a)&(V <= a+b)]
HX.est <- apply((1-lower.tri(matrix(1,ncol=nn,nrow=nn)))*A*Delta/(g.est*wXX.est),2,mean)
GX.est <- exp(-HX.est)
GC.est <- g.est/pmax(GX.est,rep(1/(10*log(nn)),nn))
matplot(Vab,cbind(GX,GX.est)[(V >=a)&(V <= a+b),],
main="Survival Function of X and its Estimate",
xlab="x", ylab="", col=c(1,1+COL),type="l",lwd=1.5)
##Diagram 4
z <- seq(0,1,len=knots)
zb <- seq(a,a+b,len=knots)
wXX.est[wXX.est < 1/(2*log(nn))] <- 1/(2*log(nn))
VVV <- A*Delta*GX.est/(g.est*wXX.est)
Vsc <-(V-a)/b
f.estF <-estcdenGEN(X = Vsc, V=VVV, Z=z,Zconf=z, alpha=alpha,
NSimConfInt=100,
theta0=-10,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
f.est <- f.estF$fest/b
Margin <- f.estF$Margin
MarginSim <- f.estF$MarginSim
f <- dcornerf(c=corn,Z=zb)
ISEM <- signif(b*mean((f-f.est)^2),2)
d.est <- mean(VVV^2/b)
matplot(zb,cbind(f,f.est,f.est+Margin,f.est-Margin,f.est-MarginSim,f.est+MarginSim),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3), lwd=1.5,
main="Density of X, E-estimate and Confidence Bands", ylab="",
xlab=substitute(paste("ISE = ",aa,", ",hat(d)," = ",bb),list(aa=ISEM,bb=signif(d.est,2))))
}#End 7.3
if(fig == 4){
if(is.na(c)){c <- 1}
if(is.na(corn)){corn <- 4}
if(is.na(n)){n <- 300
if(fig==17){n <- 200}}
if(is.na(a)){a <-0.3}
if(is.na(w)){w =".1+.8*exp(1+6*(x-.5))/(1+exp(1+6*(x-.5)))"}
if(is.na(lambdaC)){lambdaC<-3}
DDATA <-"Data7.4"
par(mfrow = c(5, 1))
nn <- n; z <- seq(0,1,len=knots)
if(SIM==0){DATA <- read.table(DDATA);X <- DATA[,1]; V <-DATA[,2];
DeltaN=DATA[,3]; DeltaL <- (DeltaN > 0);Y <- DATA[,4]; A <- DATA[,5] }
if(SIM==1){X <- runif(nn)
m<- a + dcornerf(cornerf=corn,Z=X); Y<- rexp(nn,rate=1/m)
C<- rexp(nn,rate=1/lambdaC)
V <- pmin(Y,C); DeltaL <- (Y <= C); DeltaN <- 1*DeltaL
wX <- readw(fun=w,z=X)
A <-rbinom(n,1,wX)
if(WRITE){write(t(cbind(X,V,DeltaN,Y,A)), file=DDATA, ncol=5)}
}
r <- order(V);X <- X[r];V <- V[r];DeltaN <- DeltaN[r]; DeltaL <- DeltaL[r]; Y <- Y[r];A <- A[r]
m<- a + dcornerf(cornerf=corn,Z=z)
# Diagram 1 Scattergram of (X,Y)
mO.est <- estcregN(X = X, Y = Y, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
ISEO <- signif(mean((m-mO.est)^2),2)
matplot(z,cbind(m,mO.est),type="l",lty = c(1,2),ylim=range(c(0,Y)),
main = paste("Underlying Scattergram of (X,Y), n =", nn,", ISE= ",ISEO), xlab="X", ylab="Y", lwd=2, col=c(1,1+COL))
points(X,Y,type="p")
# Diagram 2 Scattergram of $(X,V,Delta)$
g.est <- (nn-rank(V) +1)/nn
HC.est <- apply((1-lower.tri(matrix(1,ncol=nn,nrow=nn)))*(1-DeltaN)/g.est,2,mean)
GC.est <- exp(-HC.est)
GC <- pexp(V,rate=1/lambdaC,lower.tail=F)
mV.est <- estcregN(X = X, Y = V, Z=z, V = DeltaN/GC.est, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
ISEV <- signif(mean((m-mV.est)^2),2)
llim <- range(c(m,mV.est,V))
plot(X[DeltaL],V[DeltaL], type="p",pch=1,xlab="X",ylab="V",ylim=llim,
main=paste("RC Data, N = ",sum(DeltaN),", lambdaC = ",lambdaC, ", ISE = ", ISEV))
points(X[!DeltaL],V[!DeltaL], type="p", pch=3)
lines(z,m,type = "l", lty = 1, col=1, lwd=2)
lines(z,mV.est,type = "l", lty = 2, col=1+COL, lwd=2)
#Diagram 3 MAR RC Data
plot(X[DeltaL][A==1],V[DeltaL][A==1], type="p",pch=1,xlab="X",
ylab="AV",ylim=llim,
main=paste("MAR RC Data, M = ",sum(DeltaN*A)))
points(X[!DeltaL][A==1],V[!DeltaL][A==1], type="p", pch=3)
points(X[A==0],rep(0, nn-sum(A)), type="p", pch=2)
XA <- X[A==1]; VA <- V[A==1]; DeltaLA <- DeltaL[A==1];DeltaNA <-1*DeltaLA
mm <- sum(A); G <- rep(-10,mm)
for (i in 1:mm){
G[i] <- estcregN(X = XA, Y = (VA >= VA[i]), Z=XA[i], V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
}
p.est <-estcdenGEN(X = XA, V=1, Z=XA,theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
pestG <-p.est*G
HC <- cumsum((1-DeltaNA)/(sum(A)*p.est*G))
GC <- exp(-HC)
GC[is.na(HC)] <- c/log(nn)
GC[GC < c/log(nn)] <- c/log(nn)
#Diagram 4 G^C
matplot(VA[DeltaLA],cbind(GC,exp(-VA/lambdaC))[DeltaLA,],xlab="V",ylab="",
type="p", pch=c(0,1), col=c(1,1+COL),
main = "Survival Function of C and its Estimate")
#Diagram 5 Regression
mCA.est <- estcregN(X = XA, Y = VA, Z=z, V = 1/GC, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
mCA.est[mCA.est < 0] <- 0
ISECA <- signif(mean((m-mCA.est)^2),2)
matplot(z,cbind(m,mCA.est),type="l",lty = c(1,2),
main = paste("Regression Function and its Estimate, ISE= ",
ISECA), xlab="x", ylab="m(x)", lwd=2, col=c(1,1+COL))
}# End7.4
if(fig == 5){
if(is.na(c)){c <- 1}
if(is.na(corn)){corn <- 4}
if(is.na(n)){n <- 300}
if(is.na(a)){a <-0.3}
if(is.na(w)){w =".3+.5*exp(1+2*(v-2))/(1+exp(1+2*(v-2)))"}
if(is.na(lambdaC)){lambdaC<-3}
DDATA <-"Data7.5"
par(mfrow = c(3, 1))
nn <- n; z <- seq(0,1,len=knots)
if(SIM==0){DATA <- read.table(DDATA);X <- DATA[,1]; V <-DATA[,2];
DeltaN=DATA[,3]; DeltaL <- (DeltaN > 0);Y <- DATA[,4]; A <- DATA[,5] }
if(SIM==1){X <- runif(nn)
m<- a + dcornerf(cornerf=corn,Z=X); Y<- rexp(nn,rate=1/m)
C<- rexp(nn, rate= 1/lambdaC)
V <- pmin(Y,C); DeltaL <- (Y <= C); DeltaN <- 1*DeltaL
wV <- readwN(fun=w,Z=V)
A <-rbinom(n,1,wV)
if(WRITE){write(t(cbind(X,V,DeltaN,Y,A)), file=DDATA, ncol=5)}
}
r <- order(V);X <- X[r];V <- V[r];DeltaN <- DeltaN[r]; DeltaL <- DeltaL[r]; Y <- Y[r];A <- A[r]
m<- a + dcornerf(cornerf=corn,Z=z)
# Diagram 1 Scattergram of (X,Y)
mO.est <- estcregN(X = X, Y = Y, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
ISEO <- signif(mean((m-mO.est)^2),2)
matplot(z,cbind(m,mO.est),type="l",lty = c(1,2),ylim=range(c(0,Y)),
main = paste("Underlying Scattergram of (X,Y), n =", nn,", ISE= ",ISEO), xlab="X", ylab="Y", lwd=2, col=c(1,1+COL))
points(X,Y,type="p")
# Diagram 2 Scattergram of $(X,V,Delta)$
g.est <- (nn-rank(V) +1)/nn
HC.est <- apply((1-lower.tri(matrix(1,ncol=nn,nrow=nn)))*(1-DeltaN)/g.est,2,mean)
GC.est <- exp(-HC.est)
GC <- pexp(V,rate=1/lambdaC,lower.tail=F)
mV.est <- estcregN(X = X, Y = V, Z=z, V = DeltaN/GC.est, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
mV.est[mV.est < 0] <- 0
ISEV <- signif(mean((m-mV.est)^2),2)
llim <- range(c(m,mV.est,V))
plot(X[DeltaL],V[DeltaL], type="p",pch=1,xlab="X",ylab="V",ylim=llim,
main=paste("RC Data, N = ",sum(DeltaN),", lambdaC = ",lambdaC, ", ISE = ", ISEV))
points(X[!DeltaL],V[!DeltaL], type="p", pch=3)
lines(z,m,type = "l", lty = 1, col=1, lwd=2)
lines(z,mV.est,type = "l", lty = 2, col=1+COL, lwd=2)
aa <- min(V); bb <- max(V); VSC <- (V-aa)/(bb-aa)
w.est <- estcregN(X = VSC, Y = A, Z=VSC, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
w.est[w.est < 0] <- 0; w.est[w.est > 1] <- 1
wO <- readwN(fun=w,Z=V); llim <- range(c(w.est,wO,0,1))
ww <- w.est; ww[ww< c/log(nn)] <- c/log(nn)
fX.est <-estcdenGEN(X = A*X, V=A/ww, Z=A*X,Zconf=z, alpha=alpha,
NSimConfInt=100,
theta0=1,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
mm <- sum(A*(1-DeltaN)); Gest <- rep(-10,mm);
XA <- X[A==1]; VA <- V[A==1]; DeltaLL <- !DeltaL; DeltaLLA <- DeltaLL[A==1];
XAD <- XA[DeltaLLA]; VAD <- VA[DeltaLLA]
for (i in 1:mm){
Gest[i] <-estcdenGEN(X = A*X, V=(A*(V >= VAD[i]))/(w.est*fX.est),
Z=XAD[i], cJ0 = cJ0, cJ1 = cJ1,cTH = cTH, cB = cB,FLAGNEG=0,FLAGBUMP=0)$fest
}
Gest[Gest < 0] <- 0; Gest[Gest>1] <- 1
GC <- pexp(V,rate=1/lambdaC,lower.tail=F)
mX<- a + dcornerf(cornerf=corn,Z=X); GYX <-exp(-V/mX)
GVX <- GC*GYX
Indd <- (A==1)&(!DeltaL); GestV <- rep(-100,nn); GestV[Indd] <- Gest
HC <- (1/n)*cumsum((1-DeltaN)*A/(w.est*fX.est*GestV))
GCest <- exp(-HC)
GCest[GCest < c/log(nn)] <- c/log(nn)
## Fifth diagram - estimation m(x)
m.est <- estcdenGEN(X = A*X, V=A*DeltaN*V/(w.est*fX.est*GCest),
Z=z, cJ0 = cJ0, cJ1 = cJ1,cTH = cTH, cB = cB,FLAGNEG=0,FLAGBUMP=0)$fest
m.est[m.est < 0] <- 0
ISE <- signif(mean((m-m.est)^2),2)
matplot(z,cbind(m,m.est),type="l",lty = c(1,2),ylim=range(c(m,m.est,V)),
main=paste("MAR RC Data and Regression, M = ",sum(DeltaN*A), ", ISE = ",ISE),
xlab="AX",
ylab="", lwd=2, col=c(1,1+COL))
points(X[DeltaL&(A==1)],V[DeltaL&(A==1)], type="p",pch=1)
points(X[(!DeltaL)&(A==1)],V[(!DeltaL)&(A==1)], type="p", pch=3)
points(rep(0, nn-sum(A)),V[A==0], type="p", pch=2)
#Diagram 4 G^C
Ind <- (A==1)&DeltaL
}#End 7.5
if(fig == 6){
if(is.na(c)){c <- 1}
if(is.na(corn)){corn <- 4}
if(is.na(n)){n <- 300
if(fig==17){n <- 200}}
if(is.na(a)){a <-0.3}
if(is.na(w)){w =".1+.8*exp(1+6*(u-.5))/(1+exp(1+6*(u-.5)))"}
if(is.na(uC)){uC<-1.5}
DDATA <-"Data7.6"
par(mfrow = c(3, 1))
nn <- n; z <- seq(0,1,len=knots)
if(SIM==0){DATA <- read.table(DDATA);X <- DATA[,1]; V <-DATA[,2];
DeltaN=DATA[,3]; DeltaL <- (DeltaN > 0);Y <- DATA[,4]; A <- DATA[,5] }
if(SIM==1){X <- runif(nn)
m<- a + dcornerf(cornerf=corn,Z=X); Y<- rexp(nn,rate=1/m)
C<- uC*runif(nn)
V <- pmin(X,C); DeltaL <- (X <= C); DeltaN <- 1*DeltaL
wV <- readw(fun=w,z=V)
A <-rbinom(n,1,wV)
if(WRITE){write(t(cbind(X,V,DeltaN,Y,A)), file=DDATA, ncol=5)}
}
r <- order(V);X <- X[r];V <- V[r];DeltaN <- DeltaN[r]; DeltaL <- DeltaL[r]; Y <- Y[r];A <- A[r]
m<- a + dcornerf(cornerf=corn,Z=z)
# Diagram 1 Scattergram of (X,Y)
mO.est <- estcregN(X = X, Y = Y, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
ISEO <- signif(mean((m-mO.est)^2),2)
matplot(z,cbind(m,mO.est),type="l",lty = c(1,2),ylim=range(c(0,Y)),
main = paste("Underlying Scattergram of (X,Y), n =", nn,", ISE= ",ISEO), xlab="X", ylab="Y", lwd=2, col=c(1,1+COL))
points(X,Y,type="p")
#Diagram 2 MAR RC Data
DeltaLA <- DeltaL[A==1]; VAD <- (V[A==1])[DeltaLA]; YAD <-(Y[A==1])[DeltaLA]
plot(VAD,YAD, type="p",pch=1,xlab="U",ylab="AY",ylim=range(Y),
main=paste("MAR Responses and RC Predictors, uC = ",uC))
points((V[!DeltaL])[(A==1)[!DeltaL]],(Y[!DeltaL])[(A==1)[!DeltaL]], type="p", pch=3)
points(V[A==0],rep(0, nn-sum(A)), type="p", pch=2)
###Diagram 3
DeltaLA <- DeltaL[A==1]; VAD <- (V[A==1])[DeltaLA]; YAD <-(Y[A==1])[DeltaLA]
m.est <- estcregN(X = VAD, Y = YAD, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
m.est[m.est < 0] <- 0; m<- a + dcornerf(cornerf=corn,Z=z)
ISECA <- signif(mean((m-m.est)^2),2)
matplot(z,cbind(m,m.est),type="l",lty = c(1,2),ylim=range(c(m,m.est,YAD)),
main = paste("Regression Function, M = ",sum(DeltaN*A), ", ISE= ",ISECA),
xlab="x", ylab="m(x)", lwd=2, col=c(1,1+COL))
points(VAD,YAD)
}#End 7.6
if(fig==7){
if(is.na(corn)){corn <- 3}
if(is.na(n)){n <- 300}
if(is.na(uT)){uT <- .5}
if(is.na(a)){a <-.3}
if(is.na(w)){w =".1+.8*exp(1+6*(x-.5))/(1+exp(1+6*(x-.5)))"}
DDATA <- "Data7.7"
par(mfrow = c(3, 1))
nn <- n
if(SIM==0){DATA <- read.table(DDATA); X <- DATA[,1];Y <-DATA[,2];T<- DATA[,3]; A <-DATA[,4]}
if(SIM==1){
FLAG <- 1; DATAXT <- NA
while(FLAG == 1){
X <- rcornerf(c=1,n=nn); T <- uT*runif(nn)
MATT <- cbind(X,T); MAT <- MATT[X >= T,]
if(is.na(DATAXT[1])){DATAXT <- MAT}else{DATAXT <- rbind(DATAXT,MAT)}
if(nrow(DATAXT) >=nn){DATAXT <- DATAXT[1:nn,]; FLAG <- 0}
}
X <-DATAXT[,1]; T <- DATAXT[,2]; Y <- rexp(nn, rate=1/(a + dcornerf(cornerf=corn,Z=X)))
wX <- readw(fun=w,z=X); A <-rbinom(n,1,wX)
if(WRITE){write(t(cbind(X,Y,T,A)), file=DDATA, ncol=4)} }
z <- seq(0,1,len=knots)
# Diagram 1 Scattergram of (X,Y)
m <- a + dcornerf(cornerf=corn,Z=z)
mO.est <- estcregN(X = X, Y = Y, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
mO.est[mO.est < 0] <- 0
ISEO <- signif(mean((m-mO.est)^2),2)
matplot(z,cbind(m,mO.est),type="l",lty = c(1,2),ylim=range(c(0,Y)),
main = paste("Hidden LT Data, n =", nn, ", uT = ",uT,", ISE= ",ISEO),
xlab="X", ylab="Y", lwd=2, col=c(1,1+COL))
points(X,Y,type="p")
#Diagram 2 MAR LT Data
m.est <- estcregN(X = X[A==1], Y = Y[A==1], Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
m.est[m.est < 0] <- 0
ISE <- signif(mean((m-m.est)^2),2)
matplot(z,cbind(m,m.est),type="l",lty = c(1,2),ylim=range(c(0,Y[A==1])),
main = paste("MAR LT DATA, N =", sum(A),", ISE= ",ISE),
xlab="X", ylab="AY", lwd=2, col=c(1,1+COL))
points(X,A*Y,type="p")
points(X[A==0],A[A==0],type="p",pch=3)
#Diagram 3 Availability Likelihhod
w.est <- estcregN(X = X, Y = A, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
w.est[w.est < 0] <- 0; w.est[w.est > 1] <- 1
w <- readw(fun=w,z=z)
plot(z,w.est,type="l",lty = 2,ylim=range(c(0,1)),
main = "E-Estimate of Availability Likelihood",
xlab="X", ylab="A", lwd=2, col=1)
points(X,A,type="p")
}#End 7.7
###############################################
if(fig==8){
if(is.na(corn)){corn <- 3}
if(is.na(n)){n <- 300}
if(is.na(uT)){uT <- .8};if(is.na(ut)){ut <- .1}
if(is.na(a)){a <-.3}
if(is.na(w)){w =".1+.8*exp(1+6*(u-.5))/(1+exp(1+6*(u-.5)))"}
DDATA <- "Data7.8"
par(mfrow = c(3, 1))
nn <- n
if(SIM==0){DATA <- read.table(DDATA); X <- DATA[,1];Y <-DATA[,2];T<- DATA[,3]; A <-DATA[,4]}
if(SIM==1){
FLAG <- 1; DATAXT <- NA
while(FLAG == 1){
X <- rcornerf(c=1,n=nn); T <- runif(nn,min=ut,max=uT)
MATT <- cbind(X,T); MAT <- MATT[X >= T,]
if(is.na(DATAXT[1])){DATAXT <- MAT}else{DATAXT <- rbind(DATAXT,MAT)}
if(nrow(DATAXT) >=nn){DATAXT <- DATAXT[1:nn,]; FLAG <- 0}
}
X <-DATAXT[,1]; T <- DATAXT[,2];
Y <- rexp(nn, rate=1/(a + dcornerf(cornerf=corn,Z=X)))
wX <- readw(fun=w,z=X); A <-rbinom(n,1,wX)
if(WRITE){write(t(cbind(X,Y,T,A)), file=DDATA, ncol=4)} }
z <- seq(0,1,len=knots)
# Diagram 1 Scattergram of (X,Y)
m <- a + dcornerf(cornerf=corn,Z=z)
mO.est <- estcregN(X = X, Y = Y, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
mO.est[mO.est < 0] <- 0
ISEO <- signif(mean((m-mO.est)^2),2)
matplot(z,cbind(m,mO.est),type="l",lty = c(1,2),ylim=range(c(0,Y)),
main = paste("Hidden LT Data, n =", nn,", ut = ",ut,
", uT = ",uT,", ISE= ",ISEO),
xlab="X", ylab="Y", lwd=2, col=c(1,1+COL))
points(X,Y,type="p")
#Diagram 2 Availability Likelihhod
XSC <- (X-min(X))/(1-min(X)); zSC <- seq(min(X),1,len=knots)
w.est <- estcregN(X = XSC, Y = A, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
w.est[w.est < 0] <- 0; w.est[w.est > 1] <- 1
w <- readw(fun=w,z=zSC)
matplot(zSC,cbind(w,w.est),type="l",lty = 1:2,ylim=range(c(0,1)),
main = "Availability Likelihood",
xlab="X", ylab="A", lwd=2, col=c(1,1+COL))
points(X,A,type="p")
aa <-scan()
if(aa < 0 |aa > 1){stop("a_manual should be between 0 and 1")}
#Diagram 3 MAR LT Data
XA <- X[A==1]; YA <- Y[A==1];
XAaa <- XA[XA >= aa]; YAaa <- YA[XA >= aa]
XAaaSC <- (XAaa-aa)/(1-aa);zaa <- seq(aa,1,len=knots)
m.est <- estcregN(X = XAaaSC, Y = YAaa, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
m.est[m.est < 0] <- 0
m <- a + dcornerf(cornerf=corn,Z=zaa)
ISE <- signif(mean((m-m.est)^2),2)
matplot(zaa,cbind(m,m.est),type="l",lty = c(1,2),ylim=range(c(0,YAaa)),
main = paste("MAR LT DATA, N =", sum(A),", M = ", length(XAaa),
", ISE= ",ISE,", a_manual = ",aa),
xlab="X", ylab="AY", lwd=2, col=c(1,1+COL))
points(XAaa,YAaa,type="p")
points(X[(X >= aa)&(A==0)],A[(X >= aa)&(A==0)],type="p",pch=3)
}#End 7.8
if((fig == 9)|(fig==10)) {
if(is.na(corn)){corn <- 3}
if(is.na(n)){n <- 300; if(fig==10){n <- 300}}
if(is.na(ut)){ut <- 0}
if(is.na(uT)){uT <- .5}
if(is.na(lambdaT)){lambdaT<-.3}
if(is.na(uc)){uc <- 0}
if(is.na(uC)){uC <- 1.5; if(fig==10){uC=.6}}
if(is.na(lambdaC)){lambdaC<-1.5}
if(is.na(censp)){censp <- .2}
if(is.na(a)){a <-.3}
if(is.na(w)){w =".1+.8*exp(1+6*(u-.5))/(1+exp(1+6*(u-.5)))"}
if(fig==10){cens <- "Unif"}
par(mfrow = c(3, 1))
nn <- n
if(fig==9){DDATA <- "Data7.9"}else{DDATA <-"Data7.10"}
if(SIM==0){DATA <- read.table(DDATA); U <- DATA[,1]; T<-DATA[,2]
DeltaN<- DATA[,3];DeltaL <-(DeltaN==1);Y <- DATA[,4];A <-DATA[,5]; X <- DATA[,6]}
if(SIM==1){
FLAG <- 1; DATA <- NA
while(FLAG == 1){
X <- runif(nn)
if(trunc=="Unif"){TT <-runif(nn,min=ut,max=uT)}
else{TT <- rexp(nn,rate=1/lambdaT)}
if(cens=="Unif"){Z <-runif(nn,min=uc,max=uC)}
else{Z <- rexp(nn,rate=1/lambdaC)}
if(fig==10){BB <- rbinom(n=nn,size=1,p=censp);Z <-(1-BB)*Z+BB*uC;Z <- Z+TT}
U <- pmin(X,Z); DeltaL <- X <= Z; DeltaN <- 1*DeltaL
MATT <- cbind(U,TT,DeltaN); MAT <- MATT[U >= TT,]
if(is.na(DATA[1])){DATA <- MAT}else{DATA <- rbind(DATA,MAT)}
if(nrow(DATA) >=n){DATA <- DATA[1:nn,]; FLAG <- 0}
}
U <-DATA[,1]; T <- DATA[,2]; DeltaN <- DATA[,3]; DeltaL <- (DeltaN==1)
Y <- rexp(nn, rate=1/(a + dcornerf(cornerf=corn,Z=U)))
wU <- readw(fun=w,z=U); A <-rbinom(n,1,wU)
DATA <- cbind(DATA,Y,A,X)
if(WRITE){write(t(DATA), file=DDATA, ncol=6)}
}
z <- seq(0,1,len=knots)
# Diagram 1 Scattergram of (U,Y)
m <- a + dcornerf(cornerf=corn,Z=z)
UD <- U[DeltaL]; YD <- Y[DeltaL];
amin <- min(UD); amax <- max(UD)
USC <- (UD-amin)/(amax-amin);zSC <-seq(amin,amax,len=knots)
mSC <- a + dcornerf(cornerf=corn,Z=zSC)
mO.est <- estcregN(X = USC, Y = YD, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
mO.est[mO.est < 0] <- 0
ISEO <- signif(mean((mSC-mO.est)^2),2)
if(cens=="Unif"){subb <- paste("uc = ",uc,", uC = ",uC)}
else{subb <- paste("lambdaC = ", lambdaC)}
if(trunc=="Unif"){
subT <-paste(", ut = ",ut,", uT = ",uT);subb <-paste(subT,subb,sep=", ")
if(fig==10){subb<- paste(subb,", censp = ",censp)}}
else{
subT <-paste(", lambdaT = ",lambdaT);subb <-paste(subT,subb,sep=", ")
if(fig==10){subb<- paste(subb,", censp = ",censp)}}
mmain <- "Hidden LTRC Data, "
plot(z,m,type="l",lty = 1,ylim=range(c(0,Y[DeltaL])),
main=paste(mmain,
" n = ", nn,", N = ", sum(DeltaN),subb,", ISE= ",ISEO),
ylab="Y", xlab=expression(paste(paste("U[", Delta),"==1]",sep="")),
lwd=2, col=1)
lines(zSC,mO.est, type="l",lwd=2,lty=2, col=1+COL)
points(UD,YD,type="p")
#Diagram 2 Availability Likelihhod
UUSC <- (U-min(U))/(max(U)-min(U)); zz<- seq(min(U),max(U), len=knots)
w.est <- estcregN(X = UUSC, Y = A, Z=zz, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
w.est[w.est < 0] <- 0; w.est[w.est > 1] <- 1
w <- readw(fun=w,z=zz)
matplot(zz,cbind(w,w.est),type="l",lty = 1:2,ylim=range(c(0,1)),
main = "Availability Likelihood",
xlab="U", ylab="A", lwd=2, col=c(1,1+COL))
points(U,A,type="p")
#Diagram 3 MAR LTRC Data
AD <- A[DeltaL]; UDA <- UD[AD==1]; YDA <- YD[AD==1]
USC <- (UDA - min(UDA))/(max(UDA)-min(UDA))
zsc <- seq(min(UDA),max(UDA), len=knots)
m.est <- estcregN(X = USC, Y = YDA, Z=z, V = 1, FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
m.est[m.est < 0] <- 0
m <- a + dcornerf(cornerf=corn,Z=zsc)
ISE <- signif(mean((m-m.est)^2),2)
matplot(zsc,cbind(m,m.est),type="l",lty = c(1,2),ylim=range(c(0,YDA)),
main = paste("Data with MAR Response and LTRC Predictor, N =", sum(A),", M = ", sum(AD),
", ISE= ",ISE),
xlab=expression(paste(paste("U[", Delta),"==1]",sep="")),
ylab="AY", lwd=2, col=c(1,1+COL))
points(UDA,YDA,type="p")
points(UD[AD==0],rep(0,length(UD[AD==0])),type="p",pch=3)
}#End 7.9-10
} #End Ch7
################################################################################################################################################
# CHAPTER 8
##############################################################################
#######################################################################
ch8<-function(fig = 12, SIM=1,WRITE=F, COL=T, mu=3,corn=NA, aC=NA,bC=NA, sigmaC=NA,
alpha=NA,w=NA,beta=NA,k=NA,set.c=NA, LMIN=0.5,LMAX=2,A=.3,B=3,
lambda=NA,n=NA,batch=F,knots=50,sigma1=NA,lambdam=NA,lambdas=NA,
set.seas = c(1, 2, 6), a = NA, b =NA, sigma =NA, C=NA,
a0=NA, b0=NA,a1=NA,b1=NA,
sigmasc = 0.5, s0 = 0.5, s1 = 0.5, cJ0 = 4, cJ1 = 0.5, cJM = 6, cTH = 4, r = 2, cB = 2,
cJ0sp = 2, cJ1sp = 0.5, cJMsp = 6, cTHsp=4, 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 = NA,
sigma2 = 1, DELAY = 3, bP = 0.4, bS = 0.8, price0 = 1, sigmaP = 1, sigmaS = 0.5,
ManualPer = NA, seasest =
"c", DATA = hstart, FLAGNEG = 0, CFUN = list(NA, NA),sd = 1, jump = 0.8)
{
if(cJ0 == -99.9){ cJ0 <- 4
if(fig == 13) {cJ0 <- 1}
}
titel <- c("1. Uniform", "2. Normal", "3. Bimodal", "4. Strata")
if(!is.na(CFUN[[2]])) {
titel[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
##################################################################
################################################################
if(fig == 1) {
par(mfrow = c(3, 1))
DDATA <- "Data8.1"
if(is.na(a)){a <- -0.4}; if(is.na(b)){b <- -.6}; if(is.na(sigma)){sigma <- .5}
if(SIM==0){X <- read.table(DDATA); X<- X[,1]; n <- length(X)}
else{if(is.na(n)){n <- 120}
X <- sigma * arima.sim(n, model = list(ar = a, ma = b));
if(WRITE){write(t(X), file=DDATA, ncol=1)}}
plot(1:n, X, type = "p", pch = 0,
main = substitute(paste(bold("Time Series "),bold(X[t]),bold(" , n = "),nnn),list(nnn=n)),
xlab = "t", ylab = "")
lines(1:n, X, type = "l")
f <- spden.arma(ar = a, ma = b, knots = 100, sigma = sigma)
spect <- spec.pgram(X, taper = 0,plot=FALSE)
z <- seq(0, 1, len = length(spect$freq)) * pi
plot(z, (10^(spect$spec/10))/(2 * pi), type = "l",
main = "Periodogram", xlab = expression(lambda), ylab = "")
est.nonp <- estspden(X = X, knots = 100, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp)
matplot(seq(0,pi,len=100), cbind(t(f),est.nonp), type = "l", main = "Spectral Density and its Estimate", xlab = expression(lambda), ylab = "",
lwd=2, col=1+(0:1)*COL,)
}
if((fig == 2)|(fig==3)) {par(mfrow = c(3, 1))
if(is.na(n)){n <- 240}; if(is.na(a)){a <- 0.4}; if(is.na(b)){b <- .5}; if(is.na(sigma)){sigma <- .5}
if(is.na(alpha)){alpha <-0.4}; if(is.na(beta)){beta <- 0.8};if(is.na(lambda)){ lambda <-.5}
if(fig==2){DataName <- "Data8.2"; batch=FALSE}else{DataName <-"Data8.3";batch=TRUE}
if(SIM==0){DATA <- read.table(DataName); X <- DATA[,1]; A<-DATA[,2]; Y <- DATA[,3]; nn <- length(X)}
if(SIM==1){
nn <- n
X <- sigma * arima.sim(nn, model = list(ar = a, ma =b))
A <- amplmodul(nn=nn, alpha=alpha, beta=beta, lambda=lambda, batch=batch)
Y <- A*X
DATA <- cbind(X,A,Y)
if(WRITE){write(t(DATA), file=DataName, ncol=3)}
}
plot(1:nn, X, type = "p", pch = 0,
main = substitute(paste(bold("Hidden Time Series "),bold(X[t]),bold(" , n = "),nnn),
list(nnn=nn)),
xlab = "t", ylab = "")
lines(1:nn, X, type = "l")
f <- spden.arma(ar = a, ma = b, knots =knots, sigma = sigma)[1,]
z <- seq(0, 1, len = knots) * pi
ESTIM<- estspecden.mis(Y=Y,A=A,Z=z,FLAGNEG=0, cJ0 =cJ0sp, cJ1 =cJ1sp, cB = cBsp,cTH=cTHsp)
est.mis <- ESTIM$fest; NJ <- ESTIM$NJ
est.nonpY <- estspden(X = Y, knots = knots, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp)
est.nonpX <- estspden(X = X, knots = knots, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp)
#Diagram 2
mmain <- substitute(paste(bold("Observed Time Series "),bold(A[t]*X[t]),
bold(" , N = "),AA,bold(" , Nmin = "),NNJ),list(AA=sum(A),NNJ = min(NJ)))
plot(1:nn, Y, type = "p", pch = 0,
main = mmain,xlab = "t", ylab = "")
lines(1:nn, Y, type = "l")
#Diagram 3
matplot(z, cbind(f,est.mis,est.nonpY,est.nonpX), type = "l", lwd=2, col=1+(0:3)*COL,
main = "Spectral Density and its Estimates", xlab =expression(lambda),
ylab = "")
}
if((fig == 4)|(fig==5)) {
par(mfrow = c(3, 1))
if(is.na(n)){n <- 240}; if(is.na(a)){a <- 0.4}; if(is.na(b)){b <- .5}; if(is.na(sigma)){sigma <- .5};if(is.na(corn)){corn <- 2}
if(is.na(alpha)){alpha <-0.4}; if(is.na(beta)){beta <- 0.8};if(is.na(lambda)){ lambda <-1.5}
if(fig==4){DataName <- "Data8.4"; batch=FALSE}
else{DataName <-"Data8.5";batch=FALSE}
if(SIM==0){DATA <- read.table(DataName); X <- DATA[,1]; A<-DATA[,2]; Y <- DATA[,3]; U <- DATA[,4]; nn <- length(X)}
if(SIM==1){
nn <- n
X <- sigma * arima.sim(nn, model = list(ar = a, ma =b))
if(fig==4){A <- amplmodul(nn=nn, alpha=alpha, beta=beta, lambda=lambda, batch=batch); U <- rcornerf(corn=corn, n=nn)
U <- U *(mu/mean(U))}
else{A <- rpois(n=nn,lambda=lambda);Z <- rep(1,nn);U<-rep(1,nn)}
Y <- A*U*X
DATA <- cbind(X,A,Y,U)
if(WRITE){write(t(DATA), file=DataName, ncol=4)}
}
mmain <- substitute(paste(bold("Hidden Time Series "),bold(X[t]),
bold(" , n = "),nnn),list(nnn=nn))
plot(1:nn, X, type = "p", pch = 0,
main=mmain,xlab = "t", ylab = "")
lines(1:nn, X, type = "l")
f <- spden.arma(ar = a, ma = b, knots =knots, sigma = sigma)[1,]
z <- seq(0, 1, len = knots) * pi
ESTMIS<- estspecden.mis(Y=Y,A=A,Z=z,FLAGNEG=0, cJ0 =cJ0sp, cJ1 =cJ1sp, cB = cBsp,cTH=cTHsp)
est.mis <- ESTMIS$fest; NJ <-ESTMIS$NJ
if(fig==4){
subb <- substitute(paste("N = ", mmm, ", ", mu, " = ",
mum, " , ", corn," = ",ll),list(ll=corn, mum = mu,mmm=sum(A)))
mainl <-substitute(paste(bold("Observed Time Series "),bold(U[t]*A[t]*X[t]),
bold(" , N = "),AA,bold(", Nmin = "),NJJ),
list(AA=sum(A),NJJ=min(NJ))) }
if(fig==5){
mainl <-substitute(paste(bold("Observed Time Series "),bold(Z[t]*X[t]),
bold(" , N = "),AA,bold(", Nmin = "),NJJ),
list(AA=sum(A!=0),NJJ=min(NJ))) }
#Diagram 2
plot(1:nn, Y, type = "p", pch = 0,
main = mainl,xlab = "t", ylab = "")
lines(1:nn, Y, type = "l")
# plot(z,est.mis)
est.nonpY <- estspden(X = Y, knots = knots, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp)
est.nonpX <- estspden(X = X, knots = knots, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp)
if(fig==4){musqest <- (mean(U))^2
#Diagram 3
matplot(z, cbind(musqest*(f-mean(f)),est.mis-mean(est.mis),est.nonpY-mean(est.nonpY),musqest*(est.nonpX-mean(est.nonpX))),
type = "l", lwd=2, col=1+(0:3)*COL,main = "Scaled Shape of the Spectral Density and its Estimates",
xlab = expression(lambda), ylab = "")
}
else{lambda.est <- -log(mean(Y==0) +1/nn); lambdasq.est <- lambda.est + lambda.est^2
est.mis <- mean(est.nonpY)/lambdasq.est + (est.nonpY - mean(est.nonpY))/lambda.est^2
matplot(z, cbind(f,est.mis,est.nonpY,est.nonpX),
type = "l", lwd=2, col=1+(0:3)*COL,main = "Spectral Density and its Estimates",
xlab =expression(lambda), ylab = "")
}
}#End 8.4-5
if(fig ==6){ #This is new with C_t being iid
GVest = function(V=NA,Z=NA){
##Function calculates G^{V}(Z) at vector(Z)
V <- as.vector(V); Z <- as.vector(Z)
knots <- length(Z); nn <- length(V)
VM <- matrix(V,nrow=nn,ncol=knots, byrow=F)
ZM <- matrix(Z,nrow=nn,ncol=knots,byrow=T)
GVest <- apply((VM >= ZM),2,mean)
GVest
}
GCest= function(V=NA,Delta=NA,Z=NA){
##Function calculates G^{C}(Z) at vector(Z)
V <- as.vector(V); Z <- as.vector(Z); Delta <- as.vector(Delta)
knots <- length(Z); nn <- length(V)
GV <- GVest(V=V,Z=V)
PP1 <- (1-Delta)/GV
ZM <- matrix(Z,nrow=nn,ncol=knots,byrow=T)
HC <- PP1[1:nn]*(V[1:nn] <= ZM)
HCC <- apply(HC,2,mean)
exp(-HCC)
}
# GCestN=function(V=NA, Delta=NA){ #siomething is wrong
# V <- as.vector(V);Delta <- as.vector(Delta)
# nn <- length(V)
# g.est <- (nn-rank(V) +1)/nn
# HC.est <- apply((1-lower.tri(matrix(1,ncol=nn,nrow=nn)))*(1-Delta)/g.est,2,mean)
# GC.est <- exp(-HC.est)
# GC.est}
gammaXest.j = function(j=NA,V=NA,Delta=NA){
##Function calculates gamma^{X}(j) and Var(gamma^X(j))
V <- as.vector(V); Delta <- as.vector(Delta)
nn <- length(V)
GCestt <- GCest(V=V,Delta=Delta,Z=V)
#GCestt <- GCestN(V=V,Delta=Delta); GCestt[GCestt <= 1/log(nn)] <- 1/log(nn)
if(j > 0){
PP1 <- V[1:(nn-j)]*V[(1+j):nn]*Delta[1:(nn-j)]*Delta[(1+j):nn]/(GCestt[1:(nn-j)]*GCestt[(1+j):nn])
}
else{PP1 <- V^2*Delta/GCestt}
gammaj <- mean(PP1)
vargammaj <- var(PP1)
list(gammaj = gammaj, vargammaj = vargammaj)
}
estspecden.cens=function(V=NA,Delta=NA,Z=NA,cJ0 =cJ0sp, cJ1 = cJ1sp,cTH=cTHsp) {
#returns at Z
nn <- length(V)
JMAX <- ceiling(cJ0sp + cJ1sp * log(nn+ 20))
thetaC <- rep(-100,JMAX+1); varC <- rep(-100,JMAX+1)
for(j in 0:JMAX){
gammaj <- gammaXest.j(j=j,V=V,Delta=Delta)
thetaC[j+1] <- gammaj$gammaj; varC[j+1] <- gammaj$vargammaj
}
thetaC[1] <- thetaC[1]/2; varC[1] <- varC[1]/4
errC <- -cumsum(thetaC^2-2*varC/nn)
J <- order(errC)[1]
theta1 <- thetaC[1:J]
theta <- theta1
theta[theta^2 < cTH*varC[1:J]/nn] <- 0
if(J==1){Basis <- matrix(1/pi,ncol=1,nrow=length(Z))}
else{
Basis <-cbind(matrix(1,ncol=1,nrow=length(Z)),
cos(outer(Z, (1:(J-1)))))}
fest <- Basis%*%theta/pi
fest[fest < 0] <- 0
list(fest=fest,theta=theta,thetaC=thetaC)
}
par(mfrow = c(4, 1))
if(is.na(n)){n <- 240}; if(is.na(a)){a <- 0.4}; if(is.na(b)){b <- .5}; if(is.na(sigma)){sigma <- .5}
if(is.na(aC)){aC <- -0.3}; if(is.na(bC)){bC <- -.6}; if(is.na(sigmaC)){sigmaC <- 1}
###DATA CREATING
nn <- n; DataName <- "Data8.6"
if(SIM==0){DATA <- read.table(DataName); X <- DATA[,1]; C<-DATA[,2]; nn <- length(X)}
if(SIM==1){
X <- sigma * arima.sim(nn, model = list(ar = a, ma =b)); X <-as.vector(X)
C <- sigmaC * rnorm(nn)
DATA <- cbind(X,C)
if(WRITE){write(t(DATA), file=DataName, ncol=2)}
}
V <- pmin(X,C); Delta <- X <= C
#Testing
#GCCN.est <- GCestN(V=V,Delta=Delta)
# GCC.est <- GCest(V=V,Delta=Delta,Z=V)
# matplot(1:nn,cbind(pnorm(V,sd=sigmaC,lower.tail=F),GCC.est))
# browser()
#End Testing
# browser()
#Diagram 1
mmain <- substitute(paste(bold("Hidden Time Series "),bold(X[t]),
bold(" , n = "),nnn),list(nnn=nn))
plot(1:nn, X, type = "p", pch = 0, main = mmain,
xlab= "t", ylab = "")
lines(1:nn, X, type = "l")
#Diagram 2
plot(1:nn, C, type = "p", pch = 1,
main = expression(bold(paste("Underlying Censoring Time Series ",C[t]))),
xlab = "t", ylab = "")
lines(1:nn, C, type = "l")
#Diagram 3
mainl <-substitute(paste(bold("Observed Time Series "),bold(V[t]),
bold(" , N = "),AA),list(AA=sum(Delta)))
plot((1:nn)[Delta==0], V[Delta==0], type = "p", pch = 1,
main = mainl,
ylim=range(V), xlab="t",ylab="")
lines(1:nn, V, type = "l")
points((1:nn)[Delta==1],V[Delta==1],type="p", pch=0)
#Diagram 4
f <- spden.arma(ar = a, ma = b, knots = 100, sigma = sigma)
festNaive <- estspden(X = V, knots = 100, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp,
cB = cBsp)
fest <- estspecden.cens(V=V,Delta=Delta,Z=seq(0,pi,len=100),
cJ0 =cJ0sp, cJ1 = cJ1sp,cTH=cTHsp)$fest
matplot(seq(0,pi,len=100), cbind(t(f),fest,festNaive), type = "l",
main = "Spectral Density and its Estimates", xlab =expression(lambda),
ylab = "",lwd=2, lty=1:3, col=1+(0:2)*COL)
}
#End 8.6
if(fig==7){
if(is.na(a)){a <- -0.4}; if(is.na(b)){b <- -.6}; if(is.na(sigma)){sigma <- 1}
if(is.na(a1)){a1 <- 0.4}; if(is.na(b1)){b1 <- 0.5}; if(is.na(sigma1)){sigma1 <- 1}
par(mfcol = c(2, 2))
DDATA <- "Data8.7"
if(SIM==0){DD <- read.table(DDATA); X<- DD[,1]; nn <- length(X);n<- nn; Y <- DD[,2]}
else{if(is.na(n)){n <- 100}
nn <- n
X <- sigma * arima.sim(nn, model = list(ar = a, ma = b))
Y <- sigma1 * arima.sim(nn, model = list(ar = a1, ma = b1))
if(WRITE){write(t(cbind(X,Y)), file=DDATA, ncol=2)}
}
for(i in 1:2){
ssub <- paste(paste(paste("a = ", a,sep=""), paste("b = ", b,sep=""),
sep=", "),paste(paste("sigma = ", sigma),paste("n = ",nn), sep=", "),
sep=", ")
mmain <- expression(bold(paste("Time Series ",X[t])))
xxx <- "x"
if(i==2){X <- Y;a <- a1;b<- b1; sigma<- sigma1
ssub <- paste(paste(paste("a1 = ", a,sep=""), paste("b1 = ", b,sep=""),
sep=", "),paste(paste("sigma1 = ", sigma),paste("n = ",nn), sep=", "),
sep=", ")
mmain <- expression(bold(paste("Time Series ",Z[t])))
xxx <- "z" }
stdev <- sqrt(var(sigma * arima.sim(5*nn, model = list(ar = a, ma = b))))
plot(1:n, X, type = "p", pch = 0,
main = mmain,sub=ssub,xlab = "t", ylab = "")
lines(1:n, X, type = "l")
lines(c(1,nn),c(0,0),type="l", lty=2)
aa <- min(X); bb <- max(X) - min(X); XSC <- (X-aa)/bb
festt <- estcdenN(X = XSC,Z=seq(0,1,len=knots),FLAGNEG=1, cJ0 =cJ0, cJ1 =cJ1,cTH=cTH)$fest
fest <-festt/bb
mmm <- hist(X, plot = F, nclass = floor(n/5))$density
z <- seq(aa,aa+bb,len=knots)
f <- dnorm(z,mean=0,sd=stdev)
mmm <- max(c(mmm, fest, f))
hist(X, freq=F, nclass = floor(n/5), xlab =xxx,
main = "Density Estimate", xlim = c(aa, aa+bb), ylim = c(0, mmm))
lines(z, fest, type = "l", lty = 2, col = 1+COL,lwd=2)
lines(z, f, type = "l",col=1,lwd=2)
}
}#End 8.7
if(fig==8){
if(is.na(beta)){beta <- 0.4}; if(is.na(w)){w <- .6};if(is.na(sigma)){sigma <- 1}
stdev <- sqrt(var(fractgn(n=3000,alpha=beta)))
par(mfcol = c(4, 1))
DDATA <- "Data8.8"
if(SIM==0){DD <- read.table(DDATA); X<- DD[,1]; nn <- length(X);n<- nn; A <- DD[,2]}
else{if(is.na(n)){n <- 100}
nn <- n
X <- (sigma/stdev)*fractgn(n=nn,alpha=beta)
A <- rbinom(nn,size=1,prob=w)
if(WRITE){write(t(cbind(X,A)), file=DDATA, ncol=2)}
}
for(i in 1:2){
mmain <-substitute(paste(bold("Long-Memory Time Series "), bold(X[t]),", ",
bold(beta)," = ",bb,", ",bold(sigma)," = ",ss,", "," n = ",nnn),
list(bb=beta,ss=sigma,nnn=nn))
if(i==2){X <- A*X;a <- a1;b<- b1
mmain <-substitute(paste(bold("Long-Memory Time Series with Missing Observations "),
bold(A[t]*X[t]), ", w = ",ww, ", N = ",nnn),list(ww=w,nnn=sum(A))) }
plot(1:nn, X, type = "p", pch = 0,
main = mmain,xlab = "t", ylab = "")
lines(1:nn, X, type = "l")
lines(c(1,nn),c(0,0),type="l", lty=2)
if(i==2){X <- X[A==1]}
aa <- min(X); bb <- max(X) - min(X); XSC <- (X-aa)/bb
festt <- estcdenN(X = XSC,Z=seq(0,1,len=knots),FLAGNEG=1, cJ0 =cJ0, cJ1 =cJ1,cTH=cTH)$fest
fest <-festt/bb
mmm <- hist(X, plot = F, nclass = floor(n/5))$density
z <- seq(aa,aa+bb,len=knots)
f <- dnorm(z,mean=0,sd=stdev)
mmm <- max(c(mmm, fest, f))
hist(X, freq=F, nclass = floor(nn/5), xlab = "x",
main = "Density Estimate", xlim = c(aa, aa+bb), ylim = c(0, mmm))
lines(z, fest, type = "l", lty = 2, col = 1+COL,lwd=2)
lines(z, f, type = "l",col=1,lwd=2)
}
}
if(fig == 9) {
if(is.na(a)){a <- -0.3}; if(is.na(b)){b <- 0.6}; if(is.na(lambdas)){lambdas<-2}
if(is.na(a1)){a1 <- 0.5}; if(is.na(b1)){b1 <- 1};if(is.na(sigma)){sigma<- 1}
if(is.na(n)){n <- 240}; if(is.na(lambdam)){lambdam <- -2}
if(is.na(C)){C <- 3}
nn <- n; knots <- 100; DDATA <- "Data8.9"
par(mfrow = c(4, 1))
if(SIM==0){X <- read.table(DDATA); X<- X[,1]}
if(SIM==1){X <- runif(1)
XV <- X
eps <- arima.sim(n, model = list(ar = a, ma =b))
eps <- eps/(var(eps))^(1/2)
for(i in 1:n) {
Sigma <- a1+ b1*exp(lambdas*X)/(1+exp(lambdas*X))
X <- C*(exp(lambdam*X)/(1+exp(lambdam*X))-1/2) +Sigma* eps[i]
XV <- c(XV, X)
}
X <- XV[-1]
if(WRITE){write(t(X), file=DDATA, ncol=1)}
}
plot(1:nn, X, type = "p", pch=0,
main = paste("1. Nonparameteric Autoregression, n = ",nn), xlab = "t",
ylab = expression(X[t]))
lines(1:nn, X, type = "l")
plot(X[ - n], X[-1], type = "p",
main =
expression(bold(paste("2. Scattergram of ", X[t]," Versus ",X[t-1]))),
xlab = expression(X[t-1]), ylab = expression(X[t]))
Z <- X[ - n]; ZMIN <- min(Z); ZMAX <- max(Z);ZSC <- (Z - ZMIN)/(ZMAX - ZMIN)
m.est <- estcregm(X = ZSC, Y = X[-1], knots = knots, method = 4, s0 =.5, s1 =.5, cJ0 = cJ0, cJ1 = cJ1, cJM = 6, cT = 4, r = 2)
z <- seq(ZMIN, ZMAX, length = knots)
mmm <- C*(exp(lambdam*z)/(1+exp(lambdam*z))-1/2)
lines(z,mmm,type="l")
matplot(z, cbind(mmm,m.est), type = "l",
lty =1:2, main = "3. Estimate of m(x)", xlab = "x", ylab = "m(x)",
col=c(1,1+COL), lwd=2)
mX.est <- estcregm(X = ZSC, Y = X[-1], flagX = 1, method = 4, s0 = 0.5,
s1 =0.5, cJ0 = cJ0, cJ1 = cJ1, cJM = 6, cT = 4, r = 2)
Y <- X[-1] - mX.est
scale.est <- estcregm(X = ZSC, Y = Y^2, knots = knots, method = 4, s0 = 0.5,
s1 = 0.5, cJ0 = cJ0, cJ1 = cJ1, cJM = 6, cT = 4, r = 2)
scale.est[scale.est < 0] <- 0
scale.est <- scale.est^(1/2)
matplot(z, cbind(a1+ b1*exp(lambdas*z)/(1+exp(lambdas*z)),scale.est), type = "l",
lty = c(1, 2), main = "4. Estimate of Scale ", xlab = "x",
ylab = expression(paste(sigma,"(x)")),col=c(1,1+COL), lwd=2)
}
if(fig == 10) {
if(is.na(a)){a <- -0.3}; if(is.na(b)){b <- 0.6}; if(is.na(lambdas)){lambdas<-2}
if(is.na(a1)){a1 <- 0.5}; if(is.na(b1)){b1 <- 1};if(is.na(sigma)){sigma<- 1}
if(is.na(n)){n <- 240}; if(is.na(lambdam)){lambdam <- -2}
C <- 3
if(is.na(alpha)){alpha <-0.4}; if(is.na(beta)){beta <- 0.8}
nn <- n; knots <- 100; DDATA <- "Data8.10"
par(mfrow = c(4, 1))
if(SIM==0){YM <- read.table(DDATA); Y<- YM[,1]; A <-YM[,2]}
if(SIM==1){X <- runif(1)
XV <- X
eps <- arima.sim(n, model = list(ar = a, ma =b))
eps <- eps/(var(eps))^(1/2)
for(i in 1:n) {
Sigma <- a1+ b1*exp(lambdas*X)/(1+exp(lambdas*X))
X <- C*(exp(lambdam*X)/(1+exp(lambdam*X))-1/2) +Sigma* eps[i]
XV <- c(XV, X)
}
X <- XV[-1]
A <- amplmodul(nn=nn, alpha=alpha, beta=beta, lambda=NA, batch=FALSE)
Y <- A*X
if(WRITE){write(t(cbind(Y,A,X)), file=DDATA, ncol=3)}
}
plot(1:nn, Y, type = "p", pch=0,
main =
paste("1. Nonparameteric Autoregression with Missing Data, n = ",
nn, ", N = ", sum(A)), xlab = "t",
ylab = expression(A[t]*X[t]))
lines(1:nn, Y, type = "l")
lines(c(-20,nn+20), c(0,0), type="l")
#Diagram 2
Xa <- Y[-n];Xb <- Y[-1];Aa <- A[-n]; Ab <- A[-1]; Ua <--1000;Ub <- -1000
for(i in 1:(nn-1)){
if(Aa[i]&Ab[i]){Ua <- c(Ua,Xa[i]); Ub <- c(Ub,Xb[i])} }
Ua <- Ua[-1]; Ub <- Ub[-1]
plot(Ua, Ub, type = "p",
main= substitute(bold(paste("2. Scattergram of Available ", X[t],
" Versus Available ",X[t-1], ", M = ", mm)),list(mm=length(Ua))),
xlab = expression(X[t-1]), ylab = expression(X[t]))
#Diagram 3
Z <-Ua; ZMIN <- min(Z); ZMAX <- max(Z);ZSC <- (Z - ZMIN)/(ZMAX - ZMIN)
m.est <- estcregm(X = ZSC, Y = Ub, knots = knots, method = 4, s0 =.5, s1 =.5, cJ0 = cJ0, cJ1 = cJ1, cJM = 6, cT = 4, r = 2)
z <- seq(ZMIN, ZMAX, length = knots)
mmm <- C*(exp(lambdam*z)/(1+exp(lambdam*z))-1/2)
lines(z,mmm,type="l")
matplot(z, cbind(mmm,m.est), type = "l",
lty =1:2, main = "3. Estimate of m(x)", xlab = "x", ylab = "m(x)",
col=c(1,1+COL), lwd=2)
#Diagram 4
mX.est <- estcregm(X = ZSC, Y = Ub, flagX = 1, method = 4, s0 = 0.5,
s1 =0.5, cJ0 = cJ0, cJ1 = cJ1, cJM = 6, cT = 4, r = 2)
YY <- Ub - mX.est
scale.est <- estcregm(X = ZSC, Y = YY^2, knots = knots, method = 4, s0 = 0.5,
s1 = 0.5, cJ0 = cJ0, cJ1 = cJ1, cJM = 6, cT = 4, r = 2)
scale.est[scale.est < 0] <- 0
scale.est <- scale.est^(1/2)
matplot(z, cbind(a1+ b1*exp(lambdas*z)/(1+exp(lambdas*z)),scale.est), type = "l",
lty = c(1, 2), main = "4. Estimate of Scale ", xlab = "x",
ylab = expression(paste(sigma,"(x)")),col=c(1,1+COL), lwd=2)
}
}#End Chapter 8
################################################################################################################################################
# CHAPTER 9
##############################################################################
#######################################################################
ch9<-function(fig = 12, SIM=1,WRITE=F, COL=T, mu=3,corn=NA, aC=NA,bC=NA, sigmaC=NA,
alpha=NA,w=NA,beta=NA,k=NA,set.c=NA, LMIN=0.5,LMAX=2,A=.3,B=3,
lambda=NA,n=NA,batch=F,knots=50,sigma1=NA,lambdam=NA,lambdas=NA,
nsim=100,scalefun="2.8-10*(x-0.5)^2",dscale = 0,dden=0.2,
set.seas = c(1, 2, 6), a = NA, b =NA, sigma =NA, C=NA,eta=NA,
a0=NA, b0=NA,a1=NA,b1=NA,
sigmasc = 0.5, s0 = 0.5, s1 = 0.5, cJ0 = 4, cJ1 = 0.5, cJM = 6, cTH = 4, r = 2, cB = 2,
cJ0sp = 2, cJ1sp = 0.5, cJMsp = 6, cTHsp=4, 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 = NA,
sigma2 = 1, DELAY = 3, bP = 0.4, bS = 0.8, price0 = 1, sigmaP = 1, sigmaS = 0.5,
ManualPer = NA, seasest =
"c", DATA = hstart, FLAGNEG = 0, CFUN = list(NA, NA),sd = 1, jump = 0.8)
{
if(cJ0 == -99.9){ cJ0 <- 4
if(fig == 13) {cJ0 <- 1}
}
titel <- c("1. Uniform", "2. Normal", "3. Bimodal", "4. Strata")
if(!is.na(CFUN[[2]])) {
titel[CFUN[[1]]] <- paste(CFUN[[1]], " Custom", sep = ".")
}
##################################################################
################################################################
if(fig==1){
if(is.na(beta)){beta <- 0.2}; if(is.na(sigma)){sigma <- 1}; if(is.na(corn)){corn <- 3}
stdev <- sqrt(var(fractgn(n=3000,alpha=beta)))
par(mfcol = c(2, 2))
DDATA <- "Data9.1"
z <- seq(0,1,len=knots)
f <- dcornerf(c=corn, Z=z)
if(SIM==0){DD <- read.table(DDATA); X<- DD[,1]; nn <- length(X);n<- nn; Y <- DD[,2]
X1 <- DD[,3]; Y1 <- DD[,4];eps <- DD[,5]; eps1 <- DD[,6]}
else{if(is.na(n)){n <- 100}
nn <- n
eps<- (sigma/stdev)*fractgn(n=nn,alpha=beta)
eps1 <-(sigma/stdev)*fractgn(n=nn,alpha=beta)
X <- runif(nn); Y <- dcornerf(c=corn,Z=X) + sigma*eps
X1 <- runif(nn); Y1 <- dcornerf(c=corn,Z=X1) + sigma*eps1
if(WRITE){write(t(cbind(X,Y,X1,Y1,eps,eps1)), file=DDATA, ncol=6)}
}
for(j in 1:2){
if(j==2){X <- X1; Y <- Y1; eps <- eps1}
for(i in 1:2){
mmain = paste("Random Design, n = ",nn); xxlab <- "X"
if(i==2){mmain="Fixed Design"; xxlab <- "x";
X <- seq(0,1,len=nn); Y <-dcornerf(c=corn,Z=X) + sigma*eps}
f.est <- estcregN(X=X, Y = Y,V=NA,p=NA,H=1,Z=z,FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1,cTH=cTH,FLAGNEG=0)$fest
yylim <- range(c(Y,f,as.vector(f.est)))
matplot(z, cbind(f,f.est), type="l", main=mmain,xlab=xxlab,
ylab="Y",ylim=yylim,
col=c(1,1+COL), lwd=2)
points(X,Y,type="p")
}
}
}
if(fig == 2) {
if(is.na(sigma)){sigma <- 1}
if(is.na(k)){k <- 50}
knots <- 300
par(mfcol=c(2,2))
z <- seq(0, 1, len = knots)
DDATA <- "Data9.2"
z <- seq(0,1,len=knots)
if(SIM==0){DD <- read.table(DDATA); B<- DD[,1]; W <- DD[,2]
B1 <- DD[,3]; W1 <- DD[,4]}
else{
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)
noise <- sigma*rnorm(k)
B <- basB %*% matrix(noise, ncol = 1, nrow = k, byrow = F)
noise1 <- sigma*rnorm(k)
B1 <- basB %*% matrix(noise1, ncol = 1, nrow = k, byrow = F)
basW <- sqrt(2) * cos(arg)
basW <- cbind(matrix(rep(1, knots), ncol = 1, nrow = knots, byrow = F), basW)
W <- basW %*% matrix(noise, ncol = 1, nrow = k, byrow = F)
W1 <- basW %*% matrix(noise1, ncol = 1, nrow = k, byrow = F)
if(WRITE){write(t(cbind(B,W,B1,W1)), file=DDATA, ncol=4)}
}
for(j in 1:2){
if(j==2){B <- B1;W <- W1}
plot(z,B,type="l",xlab="t",ylab="",main="Brownian Motion")
plot(z,W,type="l",xlab="t",ylab="",main="White Noise")
}
}
if(fig == 3) {
if(is.na(sigma)){sigma <- 1};if(is.na(n)){n <-50;nn <- n}
if(is.na(k)){k <- 50};if(is.na(set.c[1])){set.c<-c(2,3)}
knots <- 300; nn <- n
par(mfcol=c(2,2))
z <- seq(0, 1, len = knots)
DDATA <- "Data9.3"
if(SIM==0){DD <- read.table(DDATA); Y<- DD[,1]; noise <- DD[,2][1:k];
Y1 <- DD[,3]; noise1 <- DD[,4][1:k]}
else{
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)
noise <- (sigma/sqrt(nn))*rnorm(k)
B <- basB %*% matrix(noise, ncol = 1, nrow = k, byrow = F)
Y <- knots^(-1)*cumsum(dcornerf(c=set.c[1],Z=z))+sigma*B
noise1 <- (sigma/sqrt(nn))*rnorm(k)
B1 <- basB %*% matrix(noise1, ncol = 1, nrow = k, byrow = F)
Y1 <- knots^(-1)*cumsum(dcornerf(c=set.c[1],Z=z))+B1
if(WRITE){write(t(cbind(Y,c(noise,rep(1,knots-k)),Y1,
c(noise1,rep(1,knots-k)))), file=DDATA, ncol=4)}
}
for(j in 1:2){
mmain <-"Filtering Signal From Brownian Motion"
ssub <- paste("sigma = ",sigma,", n = ",nn)
if(j==2){Y <- Y1; noise <- noise1; mmain="";xxlab=""}
theta <- trigcaprN(f = dcornerf(c = set.c[j], Z=z,CFUN = CFUN),
level = (k - 1))$fcoef
hat.theta <- theta + noise
f.est <- estfiltN(hat.theta = hat.theta, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cT = cTH)
f <- dcornerf(c = set.c[j], Z= z, CFUN = CFUN)
plot(z,Y,xlab="t",ylab="Y(t)",type="l",lwd=2, main="Noisy Signal",sub=ssub)
matplot(z, cbind(f,f.est), type = "l",
lty =1:2, col=c(1,1+COL),xlab="t",ylab="m(t)", lwd = 2,main="Filtering")
}
}
if(fig == 4) {
if(is.na(sigma)){sigma <- 1};if(is.na(n)){n <-50;nn <- n}
if(is.na(k)){k <- 50};if(is.na(set.c[1])){set.c<-c(2,3)}
if(is.na(corn)){corn <- 3}
knots <- 300; nn <- n
par(mfcol=c(2,1))
z <- seq(0, 1, len = knots)
DDATA <- "Data9.4"
if(SIM==0){DD <- read.table(DDATA); Y<- DD[,1]; noise <- DD[,2][1:k]}
else{
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)
noise <- (sigma/sqrt(nn))*rnorm(k)
B <- basB %*% matrix(noise, ncol = 1, nrow = k, byrow = F)
Y <- knots^(-1)*cumsum(dcornerf(c=corn,Z=z))+sigma*B
if(WRITE){write(t(cbind(Y,c(noise,rep(1,knots-k)))),file=DDATA,
ncol=2)}
}
ssub <- paste("sigma = ",sigma,", n = ",nn)
theta <- trigcaprN(f = dcornerf(c = corn, Z=z,CFUN = CFUN),
level = (k - 1))$fcoef
hat.theta <- theta + noise
f.est <- estfiltN(hat.theta = hat.theta, knots = knots, cJ0 = cJ0, cJ1 = cJ1, cT = cTH)
f <- dcornerf(c = corn, Z= z, CFUN = CFUN)
Ind1 <- 1:120; Ind2 <- 180:300
yylim <- range(c(f,as.vector(f.est)))
plot(z[Ind1],Y[Ind1],xlab="t",ylab="Y(t)",type="l",lwd=2,xlim=c(0,1),
main="Missing In Noisy Signal",sub=ssub,ylim=range(Y))
lines(z[Ind2],Y[Ind2],type="l", lwd=2)
matplot(z[Ind1], cbind(f,f.est)[Ind1,], type = "l", ylim=yylim,xlim=c(0,1),
lty =1:2, col=c(1,1+COL),xlab="t",ylab="m(t)", lwd = 2,main="Filtering")
lines(z,f,type="l", lwd=2)
lines(z[Ind2],f[Ind2],type="l", lwd=2)
lines(z[Ind2],f.est[Ind2],type="l",lty=2, lwd=2, col=1+COL)
}
else if(fig == 6) {
if(is.na(ManualPer)){ManualPer <- F}
if(is.na(n)){n <- 200}; if(is.na(a)){a <- -0.4}
if(is.na(b)){b <- -.5}
if(is.na(alpha)){alpha <-0.4}; if(is.na(beta)){beta <- 0.8}
if(is.na(lambda)){lambda<-1.5}
knots <- 1000; cT=4;cB=2
par(mfrow = c(5, 2))
if(SIM==0){par(mfrow=c(2,2))}
nn <- n
zz <- seq(0,1,len=nn)
ZZ <- 1:nn
DDATA <- "Data9.6"
if(SIM==0){DATA <- read.table(DDATA)
X <- DATA[,1]; A<-DATA[,2]; Y <- DATA[,3];nn <- length(X)}
if(SIM==1){
A <- amplmodul(nn=nn, alpha=alpha, beta=beta,
lambda=lambda,batch=batch)
ff <- dcornerf(c=trendf,Z=zz,CFUN=CFUN)
qq <- ff + ss * sin((2 * pi * ZZ)/Tseas)
+ sc * cos((2 * pi * ZZ)/Tseas)
scale <- 1 + dcornerf(c = scalef, Z = zz,CFUN = CFUN)
eps <- arima.sim(nn, model = list(ar = a, ma =b))
eps <- eps/(var(eps))^(1/2)
X <- sigmasc*eps
Y <- A*(qq + scale * X)
DATA <- cbind(X,A,Y)
if(WRITE){write(t(DATA), file=DDATA, ncol=3)}
}
JMAX <- floor((2 * nn)/TMAX)
plot(ZZ,X, type = "p",pch=3,
main = expression(bold(paste("1. Underlying Time Series ",X[t]))),
xlab =paste("n = ",n), ylab = "")
lines(c(-40,nn+40),c(0,0),type="l",lty=1, col=1+COL)
plot(1:n, Y,
main = expression(bold(paste("2. Observed Time Series ",A[t]* Y[t]))),
ylab = "",pch=3, xlab=paste("N = ",sum(A)))
lines(c(-40,nn+40),c(0,0),type="l",lty=1, col=1+COL)
f.est <- estcregm(X =zz[A==1], Y = Y[A==1], knots = nn,
method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM,
cT = cT, r = r, JJMAX = JMAX)
ff <- dcornerf(c = trendf, Z = zz, CFUN = CFUN)
matplot(ZZ, cbind(ff, f.est), type = "l", lty = c(1, 2),
main = "3. Estimated Trend", xlab = "", ylab = "", col=c(1,1+COL),lwd=2)
res <- Y - f.est
res <- res - mean(res[A == 1])
plot(ZZ[A==1], res[A==1], main = "4. Detrended Data",
xlab = "", ylab = "",type="p",pch=3)
lines(c(-40,nn+40),c(0,0),type="l",lty=1, col=1+COL)
if(SIM==0){par(mfrow=c(3,2))
browser()}
estsp.mis<- estspecden.mis(Y=A*res,A=A,Z=(seq(0, 1, len = knots) * pi),
FLAGNEG=0, cJ0 =cJ0sp,cJ1 =cJ1sp, cB = cBsp,cTH=cTHsp)$fest
nn1 <- 1 + floor((knots * set.lambda[1])/pi)
nn2 <- floor((knots * set.lambda[2])/pi)
period1 <- (2 * pi)/((pi * order(estsp.mis[nn1:nn2])[nn2 - nn1])/knots)
plot(seq(0, pi, l = knots), estsp.mis, type = "l",
main = "5. Spectral Density of Detrended Data", xlab = "", ylab = "",
sub = paste("THE ESTIMATED PERIOD = ",
round(period1, digits = 2), sep = ""),lwd=2)
period <- round(period1)
if(ManualPer == T) {
period <- scan()
}
if(period >= set.period[1] & period <= set.period[2]) {
seas <- matrix((res * A)[1:(period*floor(nn/period))], ncol = period,
nrow = floor(nn/period), byrow = T)
seas <- apply(seas, 2, mean); kkk <- floor(n/period)
nnn <- matrix(A[1:(period*kkk)], ncol = period, nrow = floor(n/period), byrow = T)
nnn <- apply(nnn, 2, mean)
seas <- seas/nnn
season <- ss * sin((2 * pi * (1:Tseas))/Tseas)
+ sc * cos((2 * pi * (1:Tseas))/Tseas)
plot(1:period, seas, type = "p", pch = 1, cex = 1.5,
main = "6. The Estimated Seasonal Component", xlab = "", ylab = "",
sub = paste("THE USED PERIOD = ", period, sep = ""))
if(Tseas==period){points(1:Tseas,season,type="p",pch=2,cex=1.5,col=1+COL)}
res <- res - rep(seas,floor(n/3))[1:n]
plot(ZZ[A==1], res[A==1],main = "7. Detrended and Deseasonalized Data",
xlab = "", ylab = "")
lines(c(-40,nn+40),c(0,0),type="l",lty=1, col=1+COL)
}
else {warning("Estimated period is beyond the assigned interval")}
scale.est <- estcregm(X = ZZ[A==1]/n, Y = (res[A==1])^2,
knots = nn, 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)
scale <- 1 + dcornerf(c = scalef, Z = zz,CFUN = CFUN)
matplot(1:nn, cbind(scale * sigmasc, scale.est), type = "l", lty = c(1, 2),
main = "8. Estimated Scale Function", xlab = "", ylab = "",col=c(1,1+COL),
lwd=2)
res <- res/(scale.est + 0.01)
res <- res - mean(res[A == 1])
plot(ZZ[A==1], res[A == 1], main = "9. Rescaled Residuals", xlab = "", ylab = "")
lines(c(-40,nn+40),c(0,0),type="l",lty=1, col=1+COL)
estsp.mis<- estspecden.mis(Y=A*res,A=A,Z=(seq(0, 1, len =50) * pi),
FLAGNEG=0, cJ0 =cJ0sp,cJ1 =cJ1sp, cB = cBsp,cTH=cTHsp)$fest
f <- spden.arma(ar = a, ma = b, knots =50)
f <- matrix(f, ncol = 1)
eps <- arima.sim(nn, model = list(ar = a, ma =b))
f <- f/var(eps)
estsp.mis <- matrix(estsp.mis, ncol = 1)
matplot(seq(0, pi, len = 50), cbind(f, estsp.mis),col=c(1,1+COL),
type = "l", lty = c(1, 2), main = "10. Spectral Density of Rescaled Residuals", xlab = "", ylab = "",lwd=2)
}
else if(fig == 8) {
if(is.na(ManualPer)){ManualPer <- T}
if(is.na(n)){n <- 300}; if(is.na(a)){a <- -0.4}
if(is.na(b)){b <- -.5}
if(is.na(lambda)){lambda<-1.5}
knots <- 1000; cT=4;cB=2
par(mfrow = c(5, 2))
if(SIM==0){par(mfrow=c(2,2))}
nn <- n
zz <- seq(0,1,len=nn)
ZZ <- 1:nn
DDATA <- "Data9.8"
if(SIM==0){DATA <- read.table(DDATA)
X <- DATA[,1]; U<-DATA[,2]; Y <- DATA[,3];nn <- length(X)}
if(SIM==1){
U <- rpois(n=nn,lambda=lambda)
ff <- dcornerf(c=trendf,Z=zz,CFUN=CFUN)
qq <- ff + ss * sin((2 * pi * ZZ)/Tseas)
+ sc * cos((2 * pi * ZZ)/Tseas)
scale <- 1 + dcornerf(c = scalef, Z = zz,CFUN = CFUN)
eps <- arima.sim(nn, model = list(ar = a, ma =b))
eps <- eps/(var(eps))^(1/2)
X <- sigmasc*eps
Y <- U*(qq + scale * X)
DATA <- cbind(X,U,Y)
if(WRITE){write(t(DATA), file=DDATA, ncol=3)}
}
A <- 1*(Y != 0);
lambda.est <- -log(mean(Y==0) +1/nn);lambdasq.est <- lambda.est + lambda.est^2
YSC <- Y/lambda.est
JMAX <- floor((2 * nn)/TMAX)
plot(ZZ,X, type = "p",pch=3,
main = expression(bold(paste("1. Underlying Time Series ",X[t]))),
xlab =paste("n = ",n), ylab = "")
lines(c(-40,nn+40),c(0,0),type="l",lty=1, col=1+COL)
plot(1:n, Y,
main = expression(bold(paste("2. Observed Time Series ",U[t]* Y[t]))),
ylab = "",pch=3, xlab=paste("N = ",sum(A)))
lines(c(-40,nn+40),c(0,0),type="l",lty=1, col=1+COL)
f.est <- estcregm(X =zz[A==1], Y = (1-exp(-lambda.est))*YSC[A==1], knots = nn,
method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM,
cT = cT, r = r, JJMAX = JMAX)
ff <- dcornerf(c = trendf, Z = zz, CFUN = CFUN)
matplot(ZZ, cbind(ff, f.est), type = "l", lty = c(1, 2),
main = "3. Estimated Trend", xlab = "", ylab = "", col=c(1,1+COL),lwd=2)
res <- YSC-f.est
res <- res - mean(res[A == 1])
plot(ZZ[A==1], res[A==1], main = "4. Detrended Data",
xlab = "", ylab = "",type="p",pch=3)
lines(c(-40,nn+40),c(0,0),type="l",lty=1, col=1+COL)
if(SIM==0){par(mfrow=c(3,2))
browser()}
est.nonpY <- estspden(X = A*lambda.est*res, knots = knots,
cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp)
estsp.mis <- mean(est.nonpY)/lambdasq.est+ (est.nonpY - mean(est.nonpY))/lambda.est^2
nn1 <- 1 + floor((knots * set.lambda[1])/pi)
nn2 <- floor((knots * set.lambda[2])/pi)
period1 <- (2 * pi)/((pi * order(estsp.mis[nn1:nn2])[nn2 - nn1])/knots)
plot(seq(0, pi, len = knots), estsp.mis, type = "l",
main = "5. Spectral Density of Detrended Data", xlab = "", ylab = "",
sub = paste("THE ESTIMATED PERIOD = ",
round(period1, digits = 2), sep = ""),lwd=2)
period <- round(period1)
if(ManualPer == T) {
period <- scan()
}
if(period >= set.period[1] & period <= set.period[2]) {
seas <- matrix((res * A)[1:(period*floor(nn/period))], ncol = period,
nrow = floor(nn/period), byrow = T)
seas <- apply(seas, 2, mean)
nnn <- matrix(A[1:(period*floor(n/period))], ncol = period, nrow = floor(n/period), byrow = T)
nnn <- apply(nnn, 2, mean)
seas <- seas/nnn
seas <- (1-exp(-lambda.est))*seas
season <- ss * sin((2 * pi * (1:Tseas))/Tseas)
+ sc * cos((2 * pi * (1:Tseas))/Tseas)
plot(1:period, seas, type = "p", pch = 1, cex = 1.5,
main = "6. The Estimated Seasonal Component", xlab = "", ylab = "",
sub = paste("THE USED PERIOD = ", period, sep = ""))
if(Tseas==period){points(1:Tseas,season,type="p",pch=2,cex=1.5,col=1+COL)}
res <- res - rep(seas,floor(n/3))[1:n]
plot(ZZ[A==1], res[A==1],main = "7. Detrended and Deseasonalized Data",
xlab = "", ylab = "")
lines(c(-40,nn+40),c(0,0),type="l",lty=1, col=1+COL)
}
else {warning("Estimated period is beyond the assigned interval")}
scale.est <- estcregm(X = ZZ[A==1]/n,
Y = ((1-exp(-lambda.est))/(1+1/lambda.est))*(res[A==1])^2,
knots = nn, 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)
scale <- 1 + dcornerf(c = scalef, Z = zz,CFUN = CFUN)
matplot(1:nn, cbind(scale * sigmasc, scale.est), type = "l", lty = c(1, 2),
main = "8. Estimated Scale Function", xlab = "", ylab = "",col=c(1,1+COL),
lwd=2)
res <- res/(scale.est + 0.01)
res <- res - mean(res[A == 1])
plot(ZZ[A==1], res[A == 1], main = "9. Rescaled Residuals", xlab = "", ylab = "")
lines(c(-40,nn+40),c(0,0),type="l",lty=1, col=1+COL)
est.nonpY <- estspden(X = A*lambda.est*res, knots = 50,
cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp)
estsp.mis <- mean(est.nonpY)/lambdasq.est+ (est.nonpY - mean(est.nonpY))/lambda.est^2
EEstsp.mis<- estspecden.mis(Y=A*res,A=A,Z=(seq(0, 1, len =50) * pi),
FLAGNEG=0, cJ0 =cJ0sp,cJ1 =cJ1sp, cB = cBsp,cTH=cTHsp)$fest
f <- spden.arma(ar = a, ma = b, knots =50)
f <- matrix(f, ncol = 1)
eps <- arima.sim(nn, model = list(ar = a, ma =b))
f <- f/var(eps)
estsp.mis <- matrix(estsp.mis, ncol = 1)
matplot(seq(0, pi, len = 50),
cbind(f, estsp.mis,EEstsp.mis),col=c(1,1+COL),
type = "l", lty = c(1, 2), main = "10. Spectral Density of Rescaled Residuals", xlab = "", ylab = "",lwd=2)
}#End fig9.8
########################
if(fig == 9) {
par(mfcol=c(2,2))
if(is.na(n)){n <- 240}; if(is.na(a)){a <- 0.4}; if(is.na(b)){b <- .5}; if(is.na(sigma)){sigma <- .5}
DDATA <- "Data9.9"; nn <- n;
lambda <- A + B*seq(0,1,len=nn)
lambda[lambda < LMIN] <- LMIN; lambda[lambda > LMAX] <- LMAX
if(SIM==0){DATA <- read.table(DDATA);
X <- DATA[,1]; U<-DATA[,2]; Y <- DATA[,3]; nn <- length(X)}
if(SIM==1){
X <- sigma * arima.sim(nn, model = list(ar = a, ma =b))
U <- rpois(n=nn,lambda=lambda);Z <- rep(1,nn)
Y <- U*X
DATA <- cbind(X,U,Y)
if(WRITE){write(t(DATA), file=DDATA, ncol=3)}
}
plot(seq(0,1,len=nn), X, type = "p", pch = 0,
main = expression(bold(paste("1. Underlying Time Series ",X[t]))),
xlab= paste("n = ", nn), ylab = "")
lines(seq(0,1,len=nn), X, type = "l")
lines(c(-.1,1.1),c(0,0),type="l")
#Diagram 2
A <- (Y!=0)
subb <- paste("N = ", sum(Y!=0))
mainl <- expression(bold(paste("2. Observed Time Series ", U[t]*X[t])))
plot(seq(0,1,len=nn)[A], Y[A], type = "p", pch = 1, main = mainl, #sub=subb,
xlab = subb, ylab = "")
lines(seq(0,1,len=nn)[A], Y[A], type = "l")
lines(c(-.1,1.1),c(0,0),type="l")
#Diagram 3
m.est <- estcregN(X=seq(0,1,len=nn), Y = (Y==0),V=1,p=1,H=1,
Z=seq(0,1,len=nn),FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cB = 2,cTH=cTH,FLAGNEG=0)$fest
m.est[m.est < 0] <- 0; m.est[m.est > 1] <- 1;mm <- exp(-lambda)
lambda.est <- -log(m.est)
ylimm <- range(c(mm,m.est,0,1))
matplot(seq(0,1,len=nn),cbind(mm,m.est), type="l", lty=1:2,ylim=ylimm,
xlab="",ylab="",main="3. Estimation of m(t)",col=c(1,1+COL), lwd=2)
points(seq(0,1,len=nn),Y==0,type="p")
#Diagram 4
f <- spden.arma(ar = a, ma = b, knots =knots, sigma = sigma)[1,]
z <- seq(0, 1, len = knots) * pi
est.nonpY <- estspden(X = Y, knots = knots, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp)
est.nonpX <- estspden(X = X, knots = knots, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp)
A1 <- mean(lambda.est^2); A2 <- mean(lambda.est+lambda.est^2)
est.mis <- mean(est.nonpY)/A2 + (est.nonpY - mean(est.nonpY))/A1
matplot(z, cbind(f,est.mis,est.nonpY,est.nonpX),
type = "l", lwd=2, col=1+(0:3)*COL,main = "4. Spectral Density",
xlab = "", ylab = "")
}#End 9.9
#################
if(fig == 10) {
if(is.na(a0)){a0 <- -0.3}; if(is.na(b0)){b0 <- -.6}
if(is.na(a1)){a1 <- 0.4}; if(is.na(b1)){b1 <- 0.5}; if(is.na(sigma)){sigma <- 1}
if(is.na(n)){n <- 240}
nn <- n; DDATA <- "Data9.10"
par(mfrow = c(3, 1))
if(SIM==0){X <- read.table(DDATA); X<- X[,1]}
else{X <- dynamarma(n=nn,a0=a0,b0=b0,a1=a1,b1=b1,sigma=sigma)
if(WRITE){write(t(X), file=DDATA, ncol=1)} }
plot(seq(0,1,len=nn), X, type = "p", pch = 0,
main=substitute(paste(bold("Nonstationary Time Series "),bold(X[t]),bold(", n = "),nnn),
list(nnn=nn)),
xlab = "t", ylab = "")
lines(seq(0,1,len=nn), X, type = "l")
f0 <- spden.arma(ar = a0, ma = b0, knots = 100, sigma = sigma)
f1 <- spden.arma(ar = a1, ma = b1, knots = 100, sigma = sigma)
spect <- spec.pgram(X, taper = 0,plot=FALSE)
z <- seq(0, 1, len = length(spect$freq)) * pi
plot(z, (10^(spect$spec/10))/(2 * pi), type = "l",
main = "Periodogram", xlab = expression(lambda), ylab = "")
est.nonp <- estspden(X = X, knots = 100, cJ0 = cJ0sp, cJ1 = cJ1sp, cJM = cJMsp, cT = cTsp, cB = cBsp)
matplot(seq(0,pi,len=100), cbind(t(f0),t(f1),est.nonp), type = "l",
lty=c(1,3,2),main = "Spectral Density", xlab = expression(lambda), ylab = "",
lwd=2, col=1+(0:2)*COL,)
}
if(fig == 11) {
if(is.na(a0)){a0 <- -0.3}; if(is.na(b0)){b0 <- -.6}
if(is.na(a1)){a1 <- 0.4}; if(is.na(b1)){b1 <- 0.5}; if(is.na(sigma)){sigma <- 1}
if(is.na(n)){n <- 240}
nn <- n; DDATA <- "Data9.11"
par(mfrow = c(4, 1))
if(SIM==0){X <- read.table(DDATA); X<- X[,1]}
else{X <- dynamarma(n=nn,a0=a0,b0=b0,a1=a1,b1=b1,sigma=sigma)
if(WRITE){write(t(X), file=DDATA, ncol=1)} }
a <- seq(a0,a1,len=nn); b<- seq(b0,b1,len=nn)
MM <- Mshiftprod(X=X,J=3)
#Diagram 1
plot(seq(0,1,len=nn), X, type = "p", pch = 0,
main=substitute(paste(bold("Nonstationary Time Series "),bold(X[t]),bold(", n = "),nnn),
list(nnn=nn)),
xlab = "t", ylab = "")
lines(seq(0,1,len=nn), X, type = "l")
#Diagrams 2-4
Mgamma<- cbind(sigma^2*((a+b)^2 + 1-a^2)/(1-a^2), sigma^2*(a+b)*(1+a*b)/(1-a^2),
a*sigma^2*(a+b)*(1+a*b)/(1-a^2),a*a*sigma^2*(a+b)*(1+a*b)/(1-a^2))
mmain <- c(expression(bold(paste("Autocovariance ", gamma[t]^X*(0)))),
expression(bold(paste("Autocovariance ",gamma[t]^X*(1)))),
expression(bold(paste("Autocovariance ",gamma[t]^X*(2)))),
expression(bold(paste("Autocovariance ",gamma[t]^X*(3)))))
for(i in 1:3){
Y <- MM[i:nn,i]
gamma.est <- estcregN(X=seq(0,1,len=nn-i+1), Y =Y,V=1,p=1,H=1,
Z=seq(0,1,len=nn),FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cB = 2,cTH=cTH,FLAGNEG=0)$fest
matplot(seq(0,1,len=nn), cbind(Mgamma[,i],gamma.est), type = "l",
lty=1:2,main = mmain[i], xlab = "t", ylab = "",
lwd=2, col=c(1,1+COL))
}
}#End fig9.11
##########
if(fig==12){
if(is.na(n)){n <- 100}; if(is.na(k)){k <- 10};if(is.na(sigma)){sigma <- .1}
if(is.na(eta)){eta <- .4};if(is.na(a)){a <- .8};if(is.na(b)){b <- .2};
nn <- n; DDATA <- "Data9.12"
par(mfrow = c(3, 1))
if(SIM==0){DD <- read.table(DDATA); Y<- DD[,2];X <- DD[,1]; nn <- length(X)/2
XA <- X[1:nn];XB <- X[(nn+1):(2*nn)];YA <- Y[1:nn];YB <- Y[(nn+1):(2*nn)]
Field <- DD[,3]; FieldA <- Field[1:nn]; FieldB <- Field[(nn+1):(2*nn)]
}
else{
XA <- runif(nn); XB <- runif(nn); X <- c(XA,XB)
arg <- outer(X, pi * (1:(k - 1)))
noise <- sigma*rnorm(k)
basW <- sqrt(2) * cos(arg)
basW <- cbind(rep(1, nn), basW)
W <- basW %*% matrix(noise, ncol = 1, nrow = k, byrow = F)
FieldA <-rbinom(nn,size=1,p=a)
FieldB <-rbinom(nn,size=1,p=b)
Field <- c(FieldA,FieldB)
YA <- 2 + XA + FieldA*(1+2*XA) + W[1:nn]+eta*rnorm(n)
YB <- 2 + 1.2*XB + FieldB*(1+3*XB) + W[(nn+1):(2*nn)]+eta*rnorm(n)
Y <- c(YA,YB)
Y <- (Y - min(Y))/(max(Y)- min(Y))
YA <- Y[1:nn]
YB <- Y[(nn+1):(2*nn)]
if(WRITE){write(t(cbind(X,Y,Field)), file=DDATA, ncol=3)}
}
par(mfrow=c(1,2))
plot(XA,YA, xlab="GPA",ylab="Salary",ylim=c(0,1),xlim=c(0,1),
main="A Graduates",
sub=paste("Mean Salary = ",signif(mean(YA),dig=2)))
abline(lm(YA~XA))
plot(XB,YB, xlab="GPA",ylab="Salary",ylim=c(0,1),xlim=c(0,1),
main="B Graduates",sub=paste("Mean Salary = ",
signif(mean(YB),dig=2)))
abline(lm(YB~XB))
browser()
par(mfrow=c(2,2))
plot(XA[FieldA==1],YA[FieldA==1],
xlab="GPA",ylab="Salary",ylim=c(0,1),xlim=c(0,1),main="A Engineers",
sub=paste("Mean Salary = ",signif(mean(YA[FieldA==1]),dig=2)))
abline(lm(YA[FieldA==1]~XA[FieldA==1]))
plot(XA[FieldA==0],YA[FieldA==0],
xlab="GPA",ylab="Salary",ylim=c(0,1),xlim=c(0,1),main="A Scientists",
sub=paste("Mean Salary = ",signif(mean(YA[FieldA==0]),dig=2)))
abline(lm(YA[FieldA==0]~XA[FieldA==0]))
plot(XB[FieldB==1],YB[FieldB==1],
xlab="GPA",ylab="Salary",ylim=c(0,1),xlim=c(0,1),main="B Engineers",
sub=paste("Mean Salary = ",signif(mean(YB[FieldB==1]),dig=2)))
abline(lm(YB[FieldB==1]~XB[FieldB==1]))
plot(XB[FieldB==0],YB[FieldB==0],
xlab="GPA",ylab="Salary",ylim=c(0,1),xlim=c(0,1),main="B Scientists",
sub=paste("Mean Salary = ",signif(mean(YB[FieldB==0]),dig=2)))
abline(lm(YB[FieldB==0]~XB[FieldB==0]))
browser()
########Figure 3
par(mfcol=c(2,2))
z <- seq(0,1,len=knots)
f.est <- estcden.cond(X = XA, Y = YA, knots = knots, cJ0 = cJ0, cJ1 =.5,
cJM = .5, cT = 1, cB = 1, s0 =.5, s1 = .5)
persp(z, z, f.est, xlab = "GPA", ylab = "Salary",theta=250,phi=20,
zlab = " ",main = "A Graduate" )
persp(z, z, f.est, xlab = "GPA", ylab = "Salary",theta=-50,phi=20,zlab="")
f.est <- estcden.cond(X = XB, Y = YB, knots = knots, cJ0 = cJ0, cJ1 =.5,
cJM = .5, cT = 1, cB = 2, s0 =.5, s1 = .5)
persp(z, z, f.est, xlab = "GPA", theta=250, phi=20, ylab = "Salary",
zlab =" ", main="B Graduate")
persp(z, z, f.est, xlab = "GPA", theta=-50, phi=20,
ylab = "Salary",zlab =" ")
}#End f9.14
if(fig==15){
if(is.na(n)) {n <- 50}; if(is.na(corn)){corn <- 2}; if(is.na(sigma)){sigma <-.1}
if(is.na(a)){a <- 3}
nn <- n; knots <- 50; DDATA <- "Data9.15"
par(mfcol = c(2, 1)); z <- seq(0, 1, l = knots)
f <- dcornerf(c=corn,Z=z,CFUN=CFUN)
ISE1 <- rep(-100,nsim); ISE2 <- ISE1
for(i in 1:nsim) {
X1<- runif(nn)
X2 <-rgenN(n=nn,den=scalefun,d=dden,
denAct =a+dcornerf(c=2,Z=seq(0,1,len=nn+100),CFUN=CFUN) )
scale1 <-a+ dcornerf(c=2,Z=X1,CFUN=CFUN); scale2 <- a+dcornerf(c=2,Z=X2,CFUN=CFUN)
m1 <- dcornerf(c =corn,Z =X1,CFUN=CFUN); m2<-dcornerf(c=corn,Z =X2,CFUN=CFUN)
eps <- rnorm(nn); Y1 <- m1 + sigma*scale1* eps; Y2 <- m2 + sigma*scale2*eps
if(WRITE&(i==nsim)){DATA <- cbind(X1,Y1,X2,Y2);write(t(DATA),file=DDATA,ncol=4)}
if((SIM==0)&(i==nsim)){DATA <- read.table(DDATA)
X1 <- DATA[,1];Y1 <-DATA[,2]; X2 <- DATA[,3];Y2 <-DATA[,4]}
for(j in 1:2){
if(j==1){X <- X1;Y <- Y1}
if(j==2){X <- X2; Y <- Y2}
fest <- estcregm(X =X, Y = Y, knots = knots,
method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM,
cT = cTH, r = r)
fest <- negden(fest,FLAGBUMP=1,cB=2)
ss <- a + dcornerf(c=2,Z=seq(0,1,len=100),CFUN=CFUN)
rr <- signif(100*sum(ss^2)/(sum(ss))^2,3)
fM <- cbind(f,fest)
ISE <- signif(mean((f-fest)^2),2)
if(j==1){ISE1[i] <- ISE; AISE <- signif(mean(ISE1),2)}
if(j==2){ISE2[i] <- ISE; AISE <- signif(mean(ISE2),2)}
if(i==nsim){
llim <- range(fM)
llim <- range(c(llim, range(Y)))
ttitle <-c(paste("Uniform Design, ISE = ", ISE, ", AISE = ", AISE,", n = ",nn),
paste("Optimal Design, ISE = ", ISE, ", AISE = ", AISE,", n = ",nn,", R = ",rr))
matplot(z, fM, type = "l", lty = 1:2,col=c(1,1+COL), #sub=paste("n = ",nn),
xlab = "X", ylab = "Y", main =ttitle[j],
ylim = llim,lwd=2)
lines(X, Y, type = "p", pch = 1)
}
}
}
}#End f9.15
####################
if(fig==16){
if(is.na(n)) {n <- 100}; if(is.na(corn)){corn <- 2}; if(is.na(sigma)){sigma <-.1}
if(is.na(a)){a <- 3}; if(is.na(b)){b <-.5}
nn <- n; k <- floor(nn*b) ; knots <- 50; DDATA <- "Data9.16"
par(mfcol = c(3, 1)); z <- seq(0, 1, len = knots)
f <- dcornerf(c=corn,Z=z,CFUN=CFUN)
ISE1 <- rep(-100,nsim); ISE2 <- ISE1
for(i in 1:nsim) {
X1<- runif(nn); scale1 <-a+ dcornerf(c=2,Z=X1,CFUN=CFUN)
m1 <- dcornerf(c =corn,Z =X1,CFUN=CFUN)
eps <- rnorm(nn); Y1 <- m1 + sigma*scale1* eps
X2I <- X1[1:k]; Y2I <- Y1[1:k]
festI <- estcregm(X =X2I, Y = Y2I, knots = knots, flagX=1,method = 4, s0 = s0,
s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM,cT = cTH, r = r)
Res <- Y2I - festI;
scalesq.est <- estcregm(X =X2I, Y = Res^2, knots = nn+100, flagX=0,method = 4,
s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM,cT = cTH, r = r)
scalesq.est[scalesq.est < 0] <- 0; scale.est <- scalesq.est^(1/2)
X2R <-rgenN(n=nn-k,den=NA,d=dden,denAct = scale.est)
X2 <- c(X2I,X2R)
scale2R <- a+dcornerf(c=2,Z=X2R,CFUN=CFUN)
m2R<-dcornerf(c=corn,Z =X2R,CFUN=CFUN)
Y2R <- m2R + sigma*scale2R* eps[(k+1):nn]; Y2 <- c(Y2I,Y2R)
if(WRITE&(i==nsim)){DATA <- cbind(X1,Y1,X2,Y2);write(t(DATA),file=DDATA,ncol=4)}
if((SIM==0)&(i==nsim)){DATA <- read.table(DDATA)
X1 <- DATA[,1];Y1 <-DATA[,2]; X2 <- DATA[,3];Y2 <-DATA[,4]}
for(j in 1:2){
if(j==1){X <- X1;Y <- Y1}
if(j==2){X <- X2; Y <- Y2}
fest <- estcregm(X =X, Y = Y, knots = knots,
method = 4, s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM,
cT = cTH, r = r)
fest <- negden(fest,FLAGBUMP=1,cB=2)
fM <- cbind(f,fest)
ISE <- signif(mean((f-fest)^2),2)
if(j==1){ISE1[i] <- ISE; AISE <- signif(mean(ISE1),2)}
if(j==2){ISE2[i] <- ISE; AISE <- signif(mean(ISE2),2)}
if(i==nsim){
llim <- range(fM)
llim <- range(c(llim, range(Y)))
ttitle <-
c(paste("Uniform Design, ISE = ", ISE, ", AISE = ", AISE,", n = ",nn),
paste("Sequential Design, ISE = ", ISE, ", AISE = ", AISE,", n = ",nn))
if(j==2){
scaleF <- sigma*(a+dcornerf(c=2,Z=z,CFUN=CFUN))
festII <- estcregm(X =X[1:k], Y = Y[1:k], knots = knots, flagX=1,method = 4, s0 = s0,
s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM,cT = cTH, r = r)
Res <- Y2[1:k] - festII;
scalesqI.est <- estcregm(X =X2[1:k], Res^2,
knots =knots, flagX=0,method = 4,
s0 = s0, s1 = s1, cJ0 = cJ0, cJ1 = cJ1, cJM = cJM,cT = cTH, r = r)
scalesqI.est[scalesqI.est < 0] <- 0; scale.est <- scalesqI.est^(1/2)
matplot(z,cbind(scaleF,scale.est), type = "l", lty = 1:2,col=c(1,1+COL),
xlab = "X", ylab = "", main =paste("Scale Function, k = ",k),lwd=2)
}
matplot(z, fM, type = "l", lty = 1:2,col=c(1,1+COL),
xlab = "X", ylab = "Y", main=ttitle[j], ylim = llim,lwd=2)
lines(X, Y, type = "p", pch = 1)
lines(X[1:k], Y[1:k], type = "p", pch = 4)
}
}
}
}#End f9.16
}#End Chapter 9
#############################################################################################################################
####################################################################################################
##CHAPTER 10 #################
############################################
#############################################
ch10<-function(fig = 1,SIM=1, sigma=NA,n=NA,WRITE=FALSE, CFUN = list(NA, NA),
set.c =NA, COL=1, CH=.1,cJ0 = 3, cJ1 = NA, cTH = 4,b=0.2,m =50,
w=NA,dwL=NA,dwU=NA,cB=2,set.beta=NA,
cens="Unif",uC=NA,lambdaC=NA,corn=NA,alpha=0.05,
a1=0.1,a2=0.6,c= 1, set.n = NA,
d=NA,
v=NA,dscale=0,dden =0.2,lbden =NA,
set.B = NA,set.corn =NA, bound.set =NA,scalefun =2,
muzeta=NA,sdzeta=NA,muxi=NA,sdxi=NA,
set.k=NA,setw.cJ0=NA,setw.cJ1=NA,
desden="1+0.5*x",
knots=50,
h = NA,c11=1,c12=2,c21=2,c22=3,knots1=20)
{
ttle <- c("Uniform", "Normal", "Bimodal","Strata")
if(is.na(cJ1)){cJ1 <- 0.8
if(fig==10){cJ1 <- 0} }
#################
if((fig==1)){
if(is.na(sigma)){sigma <-.3};if(is.na(n)){n<- 100}
if(is.na(set.c[1])){set.c <- c(1,2)}
if(is.na(corn)){corn <- 2}
nn <- n
par(mfcol = c(2, 2))
knots <- 100; z <- seq(0,1,len=knots);
DDATA <- "Data10.1"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 4,nrow=nn)
eps <- sigma*rnorm(nn)
DATA[,1] <- rcornerf(c=set.c[1],n=nn,CFUN = CFUN)
DATA[,2] <- DATA[,1]+eps
DATA[,3] <- rcornerf(c=set.c[2],n=nn,CFUN = CFUN)
DATA[,4] <- DATA[,3]+eps
if(WRITE){write(t(DATA), file=DDATA, ncol=4)}
}
for(i in (1:2)){
f <- dcornerf(c=set.c[i],Z=z)
mmm <- hist(DATA[,2*(i-1)+1], plot=F,nclass = floor(nn/8))$density
hist(DATA[,2*(i-1)+1], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,mmm)),
xlim=c(0,1), xlab="X",
main=paste(ttle[set.c[i]],", n = ", nn))
lines(z,f,lwd=2)
mmm <- hist(DATA[,2*(i-1)+2], plot=F,nclass = floor(nn/8))$density
hist(DATA[,2*(i-1)+2], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,mmm)),
xlab="Y, x",
main=paste("Convolution"))
lines(z,f,lwd=2)
}
}
if((fig==2)){
if(is.na(sigma)){sigma <-.3};if(is.na(n)){n<- 100}
if(is.na(set.c[1])){set.c <- c(2,3)}
nn <- n
par(mfcol = c(2, 2))
knots <- 100; z <- seq(0,1,len=knots);
DDATA <- "Data10.2"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 4,nrow=nn)
BB <- rbinom(nn,size=1,prob=0.5)
eps <- 2*(BB-0.5)*rexp(nn,rate=1/b)
DATA[,1] <- rcornerf(c=set.c[1],n=nn,CFUN = CFUN)
DATA[,2] <- DATA[,1]+eps
DATA[,3] <- rcornerf(c=set.c[2],n=nn,CFUN = CFUN)
DATA[,4] <- DATA[,3]+eps
if(WRITE){write(t(DATA), file=DDATA, ncol=4)}
}
for(i in c(1,2)){
f <- dcornerf(c=set.c[i],Z=z)
f.est <- estcdenGEN(X =DATA[,2*(i-1)+1], V=NA, H=NA,Z=z,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
mmm <- hist(DATA[,2*(i-1)+1], plot=F,nclass = floor(nn/8))$density
ISE <- signif(mean((f.est-f)^2),dig=2)
hist(DATA[,2*(i-1)+1], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm)),
xlim=c(0,1), xlab="X",
main=paste(ttle[set.c[i]],", n = ", nn,", ISE = ",ISE))
lines(z,f,lwd=2)
lines(z,f.est,col=1+COL,lty=2,lwd=2)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))-1
H <- (1+b^2*(pi*(0:JMAX))^2)^(-1)
H[H^2 < CH*n^(-1)*log(n)] <- 10^5
fME.est <- estcdenGEN(X =DATA[,2*(i-1)+2], V=NA, H=H,Z=z, FLAGNEG=1,
FLAGBUMP=0,theta0=1,cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
ISE <- signif(mean((f - fME.est)^2),digit = 2)
mmm <- hist(DATA[,2*(i-1)+2], plot=F, nclass = floor(nn/8))$density
hist(DATA[,2*(i-1)+2], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,fME.est,mmm)),
xlab="Y, x",
main=paste("Convolution, ISE = ",ISE ))
lines(z,f,lwd=2)
lines(z,fME.est,lty=2,col=1+COL,lwd=2)
}
}
if((fig==3)){
if(is.na(sigma)){sigma <-.3};if(is.na(n)){n<- 100}
if(is.na(set.c[1])){set.c <- c(2,3)}
nn <- n
par(mfcol = c(3, 2))
knots <- 100; z <- seq(0,1,len=knots);
DDATA <- "Data10.3"
if(SIM==0){DATA <- read.table(DDATA);eps.sim <- DATA[1:m,5:6];}
if(SIM==1){DATA <- matrix(-10,ncol= 6,nrow=nn)
BB <- rbinom(nn,size=1,prob=0.5)
eps <- 2*(BB-0.5)*rexp(nn,rate=1/b)
DATA[,1] <- rcornerf(c=set.c[1],n=nn,CFUN = CFUN)
DATA[,2] <- DATA[,1]+eps
DATA[,3] <- rcornerf(c=set.c[2],n=nn,CFUN = CFUN)
DATA[,4] <- DATA[,3]+eps
DATA[,5] <- 2*(BB-0.5)*rexp(n,rate=1/b)
DATA[,6] <- 2*(BB-0.5)*rexp(n,rate=1/b)
if(WRITE){write(t(DATA), file=DDATA, ncol=6)
eps.sim <- DATA[1:m,5:6]}
else{eps.sim <- matrix(2*(BB-0.5)*rexp(2*m,rate=1/b),nrow=m,ncol=2)}
}
for(i in c(1,2)){
f <- dcornerf(c=set.c[i],Z=z)
f.est <- estcdenGEN(X =DATA[,2*(i-1)+1], V=NA, H=NA,Z=z,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
mmm <- hist(DATA[,2*(i-1)+1], plot=F,nclass = floor(nn/8))$density
ISE <- signif(mean((f.est-f)^2),dig=2)
hist(DATA[,2*(i-1)+1], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm)),
xlim=c(0,1), xlab="X",
main=paste(ttle[set.c[i]],", n = ", nn, ", ISE = ", ISE))
lines(z,f,lwd=2)
lines(z,f.est,col=1+COL,lty=2,lwd=2)
zzz <- seq(min(eps.sim[,i])-.2,max(eps.sim[,i])+.2,len=100)
ff <- dexp(abs(zzz),rate=1/b)/2
mmm <- c(0,ff,hist(eps.sim[,i],plot=F,nclass=floor(m/3))$density)
par(cex.sub=2)
hist(eps.sim[,i], freq=F,ylim=range(mmm),nclass=floor(m/3),
xlab="", sub=expression(epsilon), xlim=range(zzz),
main=paste("Extra Measurement Errors, m = ", m))
par(cex.sub=1)
lines(zzz,ff,lwd=2)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))-1
H <- (1+b^2*(pi*(0:JMAX))^2)^(-1)
H.est <- apply(cos(outer(eps.sim[,i],pi*(0:JMAX))),2,mean)
H.est[H.est^2 < CH*m^(-1)*log(m)] <- 10^5
fME.est <- estcdenGEN(X =DATA[,2*(i-1)+2], V=NA, H=H.est,Z=z, FLAGNEG=1,
FLAGBUMP=0,theta0=1,cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
ISE <- signif(mean((f - fME.est)^2),digit = 2)
mmm <- hist(DATA[,2*(i-1)+2], plot=F, nclass = floor(nn/8))$density
hist(DATA[,2*(i-1)+2], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,fME.est,mmm)),
xlab="Y, x",
main=paste("Convolution, ISE = ",ISE))
lines(z,f,lwd=2)
lines(z,fME.est,lty=2,col=1+COL,lwd=2)
}
}
if((fig==4)){
if(is.na(n)){n<- 100}
if(is.na(set.c[1])){set.c <- c(2,4)}
if(is.na(w)){w <- ".3+.5*exp(1+4*y)/(1+exp(1+4*y))"}
if(is.na(dwL)){dwL <- .3}
if(is.na(dwU)){dwU <- .9}
nn <- n
par(mfcol = c(3, 2))
knots <- 100; z <- seq(0,1,len=knots);
DDATA <- "Data10.4"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 6,nrow=nn)
BB <- rbinom(nn,size=1,prob=0.5)
eps <- 2*(BB-0.5)*rexp(nn,rate=1/b)
DATA[,1] <- rcornerf(c=set.c[1],n=nn,CFUN = CFUN)
DATA[,2] <- DATA[,1]+eps
y <- DATA[,2]
eval(parse(text=paste("wY <- ",w)))
wY[wY >dwU] <- dwU; wY[wY < dwL] <- dwL
A <-rbinom(n,1,wY)
DATA[,3] <-A
DATA[,4] <- rcornerf(c=set.c[2],n=nn,CFUN = CFUN)
DATA[,5] <- DATA[,4]+eps
y <- DATA[,5]
eval(parse(text=paste("wY <- ",w)))
wY[wY >dwU] <- dwU; wY[wY < dwL] <- dwL
A <-rbinom(n,1,wY)
DATA[,6] <-A
if(WRITE){write(t(DATA), file=DDATA, ncol=6)}
}
for(i in c(1,2)){
f <- dcornerf(c=set.c[i],Z=z)
f.est <- estcdenGEN(X =DATA[,3*(i-1)+1], V=NA, H=NA,Z=z,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
mmm <- hist(DATA[,3*(i-1)+1], plot=F,nclass = floor(nn/8))$density
ISE <- signif(mean((f.est-f)^2),dig=2)
hist(DATA[,3*(i-1)+1], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm)),
xlim=c(0,1), xlab="X",
main=paste(ttle[set.c[i]],", n = ", nn,", ISE = ",ISE))
lines(z,f,lwd=2)
lines(z,f.est,col=1+COL,lty=2,lwd=2)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))-1
H <- (1+b^2*(pi*(0:JMAX))^2)^(-1)
H[H^2 < CH*n^(-1)*log(n)] <- 10^5
fME.est <- estcdenGEN(X =DATA[,3*(i-1)+2], V=NA, H=H,Z=z, FLAGNEG=1,
FLAGBUMP=0,theta0=1,cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
ISE <- signif(mean((f - fME.est)^2),digit = 2)
mmm <- hist(DATA[,3*(i-1)+2], plot=F, nclass = floor(nn/8))$density
hist(DATA[,3*(i-1)+2], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,fME.est,mmm)),
xlab="Y, x",
main=paste("Convolution, ISE = ",ISE))
lines(z,f,lwd=2)
lines(z,fME.est,lty=2,col=1+COL,lwd=2)
Y <- DATA[,3*(i-1)+2]; A <- DATA[,3*(i-1)+3]; AY <-Y[A==1]
y <- Y
eval(parse(text=paste("wY <- ",w)))
wY[wY >dwU] <- dwU; wY[wY < dwL] <- dwL
wAY <- wY[A==1]
fMME.est <- estcdenGEN(X =AY, V=1/wAY, nn = length(A),d=1,H=H,Z=z, FLAGNEG=1,
FLAGBUMP=0,theta0=1,cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
ISE <- signif(mean((f - fMME.est)^2),digit = 2)
mmm <- hist(AY, plot=F, nclass = floor(length(AY)/8))$density
hist(AY, freq=F, nclass = floor(length(AY)/8),
ylim=c(0,max(f,fMME.est,mmm)),
xlab="Y[A==1], x",
main=paste("M-sample, N = ", sum(A),", ISE = ",ISE))
lines(z,f,lwd=2)
lines(z,fMME.est,lty=2,col=1+COL,lwd=2)
}
}
if((fig==5)){
if(is.na(n)){n<- 100}
if(is.na(set.c[1])){set.c <- c(2,4)}
if(is.na(w)){w <- ".3+.5*x"}
if(is.na(dwL)){dwL <- .3}
if(is.na(dwU)){dwU <- .9}
nn <- n
par(mfcol = c(3, 2))
knots <- 100; z <- seq(0,1,len=knots);
DDATA <- "Data10.5"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 6,nrow=nn)
BB <- rbinom(nn,size=1,prob=0.5)
eps <- 2*(BB-0.5)*rexp(nn,rate=1/b)
DATA[,1] <- rcornerf(c=set.c[1],n=nn,CFUN = CFUN)
DATA[,2] <- DATA[,1]+eps
x <- DATA[,1]
eval(parse(text=paste("wX <- ",w)))
wX[wX >dwU] <- dwU; wX[wX < dwL] <- dwL
A <-rbinom(n,1,wX)
DATA[,3] <-A
DATA[,4] <- rcornerf(c=set.c[2],n=nn,CFUN = CFUN)
DATA[,5] <- DATA[,4]+eps
x <- DATA[,4]
eval(parse(text=paste("wX <- ",w)))
wX[wX >dwU] <- dwU; wX[wX < dwL] <- dwL
A <-rbinom(n,1,wX)
DATA[,6] <-A
if(WRITE){write(t(DATA), file=DDATA, ncol=6)}
}
for(i in c(1,2)){
f <- dcornerf(c=set.c[i],Z=z)
f.est <- estcdenGEN(X =DATA[,3*(i-1)+1], V=NA, H=NA,Z=z,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
mmm <- hist(DATA[,3*(i-1)+1], plot=F,nclass = floor(nn/8))$density
ISE <- signif(mean((f.est-f)^2),dig=2)
hist(DATA[,3*(i-1)+1], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm)),
xlim=c(0,1), xlab="X",
main=paste(ttle[set.c[i]],", n = ", nn,", ISE = ", ISE))
lines(z,f,lwd=2)
lines(z,f.est,col=1+COL,lty=2,lwd=2)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))-1
H <- (1+b^2*(pi*(0:JMAX))^2)^(-1)
H[H^2 < CH*n^(-1)*log(n)] <- 10^5
fME.est <- estcdenGEN(X =DATA[,3*(i-1)+2], V=NA, H=H,Z=z, FLAGNEG=1,
FLAGBUMP=0,theta0=1,cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
ISE <- signif(mean((f - fME.est)^2),digit = 2)
mmm <- hist(DATA[,3*(i-1)+2], plot=F, nclass = floor(nn/8))$density
hist(DATA[,3*(i-1)+2], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,fME.est,mmm)),
xlab="Y, x",
main=paste("Convolution, ISE = ",ISE))
lines(z,f,lwd=2)
lines(z,fME.est,lty=2,col=1+COL,lwd=2)
Y <- DATA[,3*(i-1)+2];
A <- DATA[,3*(i-1)+3]; AY <-Y[A==1]
gMME.est <- estcdenGEN(X =A*Y, V=A, d=1,H=H,Z=z, FLAGNEG=1,
FLAGBUMP=0,theta0=0,cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
x <- z
eval(parse(text=paste("wz <- ",w)))
wz[wz >dwU] <- dwU; wz[wz < dwL] <- dwL
fMME.est <- gMME.est/wz
ISE <- signif(mean((f - fMME.est)^2),digit = 2)
mmm <- hist(AY, plot=F, nclass = floor(length(AY)/8))$density
hist(AY, freq=F, nclass = floor(length(AY)/8),
ylim=c(0,max(f,fMME.est,mmm)),
xlab="Y[A==1], x",
main=paste("M-sample, N = ", sum(A), ", ISE = ", ISE))
lines(z,f,lwd=2)
lines(z,fMME.est,lty=2,col=1+COL,lwd=2)
}
}#End 10.5
if((fig==6)){
if(is.na(n)){n<- 100}
if(is.na(set.c[1])){set.c <- c(2,4)}
if(is.na(w)){w <- ".3+.5*exp(1+4*z)/(1+exp(1+4*z))"}
if(is.na(dwL)){dwL <- .3}
if(is.na(dwU)){dwU <- .9}
if(is.na(set.beta[1])){set.beta=c(.2,.4)}
if(is.na(sigma)){sigma <- 1}
nn <- n
par(mfcol = c(3, 2))
knots <- 100; zz <- seq(0,1,len=knots)
DDATA <- "Data10.6"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 8,nrow=nn)
BB <- rbinom(nn,size=1,prob=0.5)
eps <- 2*(BB-0.5)*rexp(nn,rate=1/b)
DATA[,1] <- rcornerf(c=set.c[1],n=nn,CFUN = CFUN)
DATA[,2] <- DATA[,1]+eps
z <- set.beta[1] + set.beta[2]*DATA[,1] + sigma*rnorm(nn)
DATA[,3] <- z
eval(parse(text=paste("wZ <- ",w)))
wZ[wZ >dwU] <- dwU; wZ[wZ < dwL] <- dwL
A <-rbinom(n,1,wZ)
DATA[,4] <-A
DATA[,5] <- rcornerf(c=set.c[2],n=nn,CFUN = CFUN)
DATA[,6] <- DATA[,4]+eps
z <- set.beta[1] + set.beta[2]*DATA[,1] + sigma*rnorm(nn)
DATA[,7] <- z
eval(parse(text=paste("wZ <- ",w)))
wZ[wZ >dwU] <- dwU; wZ[wZ < dwL] <- dwL
A <-rbinom(n,1,wZ)
DATA[,8] <- A
if(WRITE){write(t(DATA), file=DDATA, ncol=8)}
}
for(i in c(1,2)){
f <- dcornerf(c=set.c[i],Z=zz)
f.est <- estcdenGEN(X =DATA[,4*(i-1)+1], V=NA, H=NA,Z=zz,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
mmm <- hist(DATA[,4*(i-1)+1], plot=F,nclass = floor(nn/8))$density
ISE <- signif(mean((f.est-f)^2),dig=2)
hist(DATA[,4*(i-1)+1], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm)),
xlim=c(0,1), xlab="X",
main=paste(ttle[set.c[i]],", n = ", nn,", ISE = ",ISE))
lines(zz,f,lwd=2)
lines(zz,f.est,col=1+COL,lty=2,lwd=2)
A <- DATA[,4*(i-1)+4]; Z <- DATA[,4*(i-1)+3]
ZSC <- (Z-min(Z))/(max(Z) - min(Z))
w.est <- estcregN(X=ZSC, Y = A,Z=ZSC,FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH,FLAGNEG=0)$fest
w.est[w.est > 1] <- 1
w.est[w.est < 1/log(length(A)+20)] <- 1/log(length(A)+20)
plot(Z,A,type="p",main=paste("Estimation of w(Z), n =",length(A),sep=""),
xlab="Z", ylab="A")
z <- Z
eval(parse(text=paste("wZ <- ",w)))
wZ[wZ >dwU] <- dwU; wZ[wZ < dwL] <- dwL
points(Z[A==1],wZ[A==1],type="p",pch=2,col=1+2*COL)
points(Z[A==1],w.est[A==1],type="p",pch=4,col=1+3*COL)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))-1
H <- (1+b^2*(pi*(0:JMAX))^2)^(-1)
H[H^2 < CH*n^(-1)*log(n)] <- 10^5
Y <- DATA[,4*(i-1)+2];
fMME.est <- estcdenGEN(X =A*Y, V=A/w.est, d=1,H=H,Z=zz, FLAGNEG=1,
FLAGBUMP=0,theta0=1,cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
ISE <- signif(mean((f - fMME.est)^2),digit = 2)
mmm <- hist(Y[A==1], plot=F, nclass = floor(length(Y)/8))$density
hist(Y[A==1], freq=F, nclass = floor(length(Y)/8),
ylim=c(0,max(f,fMME.est,mmm)),
xlab="Y[A==1], x",
main=paste("M-sample, N = ", sum(A),", ISE = ", ISE))
lines(zz,f,lwd=2)
lines(zz,fMME.est,lty=2,col=1+COL,lwd=2)
lines(rep(0,10),seq(0,fMME.est[1],len=10),lty=2,col=1+COL,lwd=2)
lines(rep(1,10),seq(0,fMME.est[knots],len=10),lty=2,col=1+COL,lwd=2)
}
}
if((fig==7)){
if(is.na(n)){n<- 100}
if(is.na(corn)){corn <- 2}
if(is.na(uC)){uC <- 1.5}
if(is.na(lambdaC)){lambdaC<-1.5}
if(cens=="Unif"){param=paste(", uC = ",uC)}
else{param=paste(", lambdaC = ",lambdaC)}
nn <- n
par(mfcol = c(4, 1))
knots <- 100; z <- seq(0,1,len=knots)
DDATA <- "Data10.7"
if(SIM==0){DATA <- read.table(DDATA)
X <- DATA[,1];Y <- DATA[,2];
V <- DATA[,3]; DeltaL <- DATA[,4];DeltaN <- 1*DeltaL}
if(SIM==1){DATA <- matrix(-10,ncol= 4,nrow=nn)
BB <- rbinom(nn,size=1,prob=0.5)
eps <- 2*(BB-0.5)*rexp(nn,rate=1/b)
DATA[,1] <- rcornerf(c=corn,n=nn,CFUN = CFUN); X <- DATA[,1]
DATA[,2] <- X+eps; Y <- DATA[,2]
if(cens=="Unif"){Z <- runif(nn,max=uC)}else{Z <- rexp(nn,rate=1/lambdaC)}
DATA[,3] <- pmin(Y,Z); V <- DATA[,3]
DATA[,4] <- (Y <= Z); DeltaL <-DATA[,4]; DeltaN <- 1*DeltaL
if(WRITE){write(t(DATA), file=DDATA, ncol=4)}
}
f <- dcornerf(c=corn,Z=z)
f.est <- estcdenGEN(X =X, V=NA, H=NA,Z=z,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
mmm <- hist(X, plot=F,nclass = floor(nn/8))$density
ISE <- signif(mean((f.est-f)^2),dig=2)
hist(X, freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm)),
xlim=c(0,1), xlab="X",
main=paste("1. Hidden Sample from ",ttle[corn],", n = ", nn,", ISE = ",ISE))
lines(z,f,lwd=2)
lines(z,f.est,col=1+COL,lty=2,lwd=2)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))-1
H <- (1+b^2*(pi*(0:JMAX))^2)^(-1)
H[H^2 < CH*n^(-1)*log(n)] <- 10^5
fME.est <- estcdenGEN(X =Y, V=NA, H=H,Z=z, FLAGNEG=1,
FLAGBUMP=0,theta0=1,cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
ISE <- signif(mean((f - fME.est)^2),digit = 2)
mmm <- hist(Y, plot=F, nclass = floor(nn/8))$density
hist(Y, freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,fME.est,mmm)),
xlab="Y, x",
main=paste("2. Hidden Sample Contaminated by Measurement Errors, ISE = ",ISE))
lines(z,f,lwd=2)
lines(z,fME.est,lty=2,col=1+COL,lwd=2)
r <- order(V)
V <- V[r]
Delta <- DeltaN[r]
#Diagram3
plot(V,Delta, type="p",xlab="V",ylab=expression(Delta),ylim=c(-.1,1.1),
main=paste("3. Censored Data, cens = ",cens, ", n = ", nn, ", N = ",sum(Delta),param))
#Diagram4old with Survival Function
GY <-hGcornerf(c=corn,Z=V)$G
if(cens=="Unif"){GC <- punif(V,max=uC,lower.tail=F)}
else{GC <- pexp(V,rate=1/lambdaC,lower.tail=F)}
GV <-GY*GC
g.est <- (nn-rank(V) +1)/nn
HC.est <- apply((1-lower.tri(matrix(1,ncol=nn,nrow=nn)))*(1-Delta)/g.est,2,mean)
GC.est <- exp(-HC.est)
##Diagram 5
z <- seq(0,1,len=knots)
GC.est[GC.est < c/log(nn)] <- c/log(nn)
VVV <- Delta/GC.est
f.estF <-estcdenGEN(X = V, V=VVV, H=H,Z=z,Zconf=z, alpha=alpha,
NSimConfInt=100,
theta0=-10,FLAGNEG=1, cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)
f.est <- f.estF$fest
Margin <- f.estF$Margin
MarginSim <- f.estF$MarginSim
f <- dcornerf(c=corn,Z=z)
ISEM <- signif(mean((f-f.est)^2),2)
d.est <- mean(VVV^2)
matplot(z,cbind(f,f.est,f.est+Margin,f.est-Margin,f.est-MarginSim,f.est+MarginSim),
type="l",lty=c(1,2,3,3,4,4),col=c(1,1+COL,1+COL*2,1+COL*2,1+COL*3,
1+COL*3),lwd=2,
main=paste("4. E-estimate and Confidence Bands, ISE = ",ISEM),
ylab="Density",xlab="X")
}
if((fig==8)|(fig==9)){
if(is.na(n)){n<- 100}
if(is.na(corn)){corn <- 2}
par(mfrow=c(2,1))
nn <- n
knots <- 100; zz <- seq(0,1,len=knots)
DDATA <- "Data10.8"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <-matrix(-10,ncol= 2,nrow=nn)
DATA[,1] <- rcornerf(c=corn,n=nn,CFUN = CFUN)
DATA[,2] <- runif(nn)
if(WRITE){write(t(DATA), file=DDATA, ncol=2)}
}
X <-DATA[,1]
Z <- DATA[,2]
Z <- 1*Z
Delta <- (X <= Z)
f <- dcornerf(c=corn,Z=zz)
FF <-cumsum(f)/length(zz)
if(fig==8){
f.est <- estcdenGEN(X =X, V=NA, H=NA,Z=zz,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
f <- dcornerf(c=corn,Z=zz)
ISE <- signif(mean((f.est-f)^2),dig=2)
FF.est <- ecdf(X)
FF.est <- FF.est(zz)
ISEF <- signif(mean((FF.est-FF)^2),dig=2)
mmm <- hist(X, plot=F,nclass = floor(nn/8))$density
hist(X, freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm,1)),xlim=c(0,1),
xlab="X",
main=paste("Direct Sample from X, n = ", nn, ", ISE = ",ISE,", ISEF = ",ISEF))
lines(zz,f,lwd=2)
lines(zz,f.est, lty=2,col=1+COL,lwd=2)
lines(zz,FF, lty=3,col=1+2*COL,lwd=2)
lines(zz,FF.est,lty=4,lwd=2,col=1+COL*3)
lines(c(0,1),c(1,1))
#second diagram
fZ.est <- estcdenGEN(X =Z, V=NA, H=NA,Z=Z,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
fZzz.est <- estcdenGEN(X =Z, V=NA, H=NA,Z=zz,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
fZ.est[fZ.est < 1/log(nn+20)] <- 1/log(nn+20)
f.est <- estcdenCURSTAT(X =Z,Delta=Delta,fX=fZ.est,FLAGM=2,Z=zz,theta0=1,
FLAGNEG=1, cJ0 =cJ0, cJ1 =cJ1, cB =cB,cTH=cTH)$fest
ISE <- signif(mean((f.est-f)^2),dig=2)
mmm <- hist(Z, plot=F,nclass = floor(nn/8))$density
hist(Z, freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm)),xlim=c(0,1),
xlab="Z, x",
main=paste("CSC Data, n = ", nn, ", ISE = ",ISE))
lines(zz,f,lwd=2)
lines(zz,f.est, lty=2,col=1+COL,lwd=2)
lines(zz,fZzz.est, lty=3,col=1+2*COL,lwd=3)
points(Z,Delta)
}
if(fig==9){
f.est <- estcdenCURSTAT(X =Z,Delta=Delta,fX=rep(1,n),FLAGM=0,Z=zz,theta0=1,
FLAGNEG=1, cJ0 =cJ0, cJ1 =cJ1, cB =cB,cTH=cTH)$fest
ISE <- signif(mean((f.est-f)^2),dig=2)
fZ.est <- estcdenGEN(X =Z[Delta==1], V=NA, H=NA,Z=zz,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
FF.est <- fZ.est*sum(Delta)/nn
ISEF <- signif(mean((FF.est-FF)^2),dig=2)
mmm <- hist(Z[Delta==1], plot=F,nclass = floor(nn/8))$density
hist(Z[Delta==1], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm)),xlim=c(0,1),
xlab=expression(paste(paste("Z[", Delta),"==1], x",sep="")),
main=paste("Missing CSC, n = ", nn, ", N = ", sum(Delta),", ISE = ",ISE,", ISEF = ",ISEF))
lines(zz,f,lwd=2)
lines(zz,f.est, lty=2,col=1+COL,lwd=2)
lines(zz,FF, lty=3,col=1+2*COL,lwd=2)
lines(zz,FF.est,lty=4,lwd=2,col=1+COL*3)
lines(c(0,1),c(1,1))
##Second diagram
f.est <- estcdenCURSTAT(X =Z,Delta=Delta,fX=rep(1,n),FLAGM=1,Z=zz,theta0=1,
FLAGNEG=1, cJ0 =cJ0, cJ1 =cJ1, cB =cB,cTH=cTH)$fest
ISE <- signif(mean((f.est-f)^2),dig=2)
fZ.est <- estcdenGEN(X =Z[Delta==0], V=NA, H=NA,Z=zz,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
FF.est <- 1-fZ.est*sum(Delta)/nn
ISEF <- signif(mean((FF.est-FF)^2),dig=2)
mmm <- hist(Z[Delta==0], plot=F,nclass = floor(nn/8))$density
hist(Z[Delta==0], freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm)),xlim=c(0,1),
xlab=expression(paste(paste("Z[", Delta),"==0], x",sep="")),
main=paste("Missing CSC, n = ", nn, ", N = ",sum(1-Delta),", ISE = ",ISE,", ISEF = ",ISEF))
lines(zz,f,lwd=2)
lines(zz,f.est, lty=2,col=1+COL,lwd=2)
lines(zz,FF, lty=3,col=1+2*COL,lwd=2)
lines(zz,FF.est,lty=4,lwd=2,col=1+COL*3)
lines(c(0,1),c(1,1))
}
}
if(fig==10){
if(is.na(n)){n<- 200}
if(is.na(corn)){corn <- 4}
par(mfrow=c(2,1))
nn <- n
knots <- 100;
DDATA <- "Data10.10"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <-matrix(-10,ncol= 2,nrow=nn)
DATA[,1] <- rcornerf(c=corn,n=nn,CFUN = CFUN)
DATA[,2] <- a1 +(a2-a1)*runif(nn)
if(WRITE){write(t(DATA), file=DDATA, ncol=2)}
}
X <-DATA[,1]
Z <- DATA[,2]
Delta <- (X <= Z)
ZA <- Z[Delta==1]
aa1 <- min(ZA);aa2 <- max(ZA)
zz <- seq(aa1,aa2,len=knots)
f <- dcornerf(c=corn,Z=zz)
fT.est <- estcdenCURSTATGEN(X = Z,Delta=Delta,fX=rep(1,nn),fXZ = rep(1,knots),Z=zz,FLAGM=0,
FLAGNEG=1, cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)
f.est <- fT.est$fest
F.est <- fT.est$Fest
FF.est <- F.est; FF.est[FF.est > 1] <- 1
F1 <- cumsum(dcornerf(c=corn,CFUN=CFUN,Z=seq(0,1,len=4*knots)))/(4*knots)
FF <- F1[floor(aa1*4*knots)]+ (aa2-aa1)*cumsum(dcornerf(c=corn,CFUN=CFUN,Z=zz))/knots
plot(seq(0,1,len=knots), dcornerf(c=corn,Z=seq(0,1,len=knots)),type="l",xlab="Z, x",
ylab=expression(Delta),
main=paste("Hidden CSC, a1 = ",a1,", a2 = ",a2,", n = ",nn),lwd=2)
points(Z,Delta)
lines(c(a1,a1),c(0,1),lty=2)
lines(c(a2,a2),c(0,1),lty=2)
mmm <- hist(ZA, plot=F,nclass = floor(nn/8))$density
hist(ZA, freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm,1)),xlim=c(aa1,aa2),
xlab="Z, x",
main=paste("Missing CSC, N = ",sum(Delta)))
lines(zz,f,lwd=2)
lines(zz,f.est, lty=2,col=1+COL,lwd=2)
FFLAG <- 1
if(FFLAG ==0){
#second diagram
Z <- sort(Z)
ZSC <- (Z-beta1)/(beta2-beta1)
fZ.est <- estcdenGEN(X =ZSC, V=NA, H=NA,Z=ZSC,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
fZ.est <- fZ.est/(beta2-beta1)
fZ.est[fZ.est < 1/log(nn+20)] <- 1/log(nn+20)
f.est <-estcdenCURSTAT(X =ZSC,Delta=Delta,fX=fZ.est,FLAGM=2,
Z=seq(0,1,len=knotszzz),theta0=1,FLAGNEG=1, cJ0 =cJ0, cJ1 =cJ1,
cB =cB,cTH=cTH)$fest
f.est <- f.est/(beta2-beta1)
ISE <- signif(mean((f.est-ff)^2),dig=2)
mmm <- hist(Z, plot=F,nclass = floor(nn/8))$density
hist(Z, freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm)),xlim=c(a1,a2),
xlab="Z, x",
main=paste("CSC Data, n = ", nn, ", ISE = ",ISE))
lines(zz,f,lwd=2)
lines(zzz,f.est, lty=2,col=1+COL,lwd=2)
lines(beta1+ZSC*(beta2-beta1),fZ.est, lty=3,col=1+2*COL,lwd=3)
points(Z,Delta)
}
}
if((fig==11)){
if(is.na(n)){n<- 100}
if(is.na(corn)){corn <- 3}
if(is.na(sigma)){sigma<- 1}
nn <- n
par(mfcol = c(2,2))
knots <- 100; z <- seq(0,1,len=knots);
DDATA <- "Data10.11"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 3,nrow=nn)
BB <- rbinom(nn,size=1,prob=0.5)
eps <- 2*(BB-0.5)*rexp(nn,rate=1/b)
DATA[,1] <- runif(nn)
DATA[,2] <- dcornerf(c=corn,Z=DATA[,1],CFUN=CFUN) + sigma*rnorm(nn)
DATA[,3] <- DATA[,1] + eps
if(WRITE){write(t(DATA), file=DDATA, ncol=3)}
}
X <- DATA[,1]; Y <- DATA[,2]; U <- DATA[,3]
z <- seq(0, 1, l = knots)
f <- dcornerf(c = corn, Z = z, CFUN = CFUN)
fest <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
fM <- cbind(f,fest)
ISE <- signif(mean((f-fest)^2),2)
llim <- range(fM)
llim <- range(c(llim, range(Y)))
matplot(z, fM, type = "l", lty = 1:2,col=c(1,1+COL),sub=paste("n = ",nn),
main=paste("Hidden Regression, ", "ISE = ",ISE),
xlab = "X", ylab = "Y", ylim = llim,lwd=2)
lines(X, Y, type = "p", pch = 1)
##second diagram
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))-1
H <- (1+b^2*(pi*(0:JMAX))^2)^(-1)
H[H^2 < CH*n^(-1)*log(n)] <- 10^5
gNest<- estcregN(X=U, Y = Y,V=NA,p=rep(1,length(Y)),H=H,Z=z,FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH,FLAGNEG=0)$fest
gNest <- negden(gNest,FLAGBUMP=1,cB=2)
fM <- cbind(f,gNest)
ISEN <- signif(mean((f-gNest)^2),2)
llim <- range(fM)
llim <- range(c(llim, range(Y)))
matplot(z, fM, type = "l", lty = 1:2,col=c(1,1+COL),
main=paste("Estimation of g(x)"),
xlab = "U, x", ylab = "Y", ylim = llim,xlim=range(U),lwd=2)#
lines(U, Y, type = "p", pch = 1)
##third diagram
dens.est <- estcdenGEN(X =U, V=NA, H=H,Z=z, FLAGNEG=1,
FLAGBUMP=0,theta0=1,cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
mmm <- hist(U, plot=F, nclass = floor(nn/8))$density
hist(U, freq=F, nclass = floor(nn/8),
ylim=c(0,max(1,dens.est,mmm)),xlab="U, x",
main=paste("Estimation of Design Density"))
lines(z,dcornerf(corn=1,Z=z),lwd=2)
lines(z,dens.est,lty=2,col=1+COL,lwd=2)
####fourth diagram
dens.est[dens.est < c/log(nn+20)] <- c/log(nn+20)
fest <- gNest/dens.est
fM1 <- cbind(f,fest)
ISE <- signif(mean((f-fest)^2),2)
llim <- range(fM1)
llim <- range(c(llim, range(Y)))
matplot(z, fM1, type = "l", lty = 1:2,col=c(1,1+COL),
main=paste("MEP Regression, ISE = ",ISE),
xlab = "U, x", ylab = "Y", ylim = llim,xlim=range(U),lwd=2)
lines(U, Y, type = "p", pch = 1)
}
if((fig==12)){
if(is.na(n)){n<- 100}
if(is.na(corn)){corn <- 2}
if(is.na(sigma)){sigma<- 1}
if(is.na(w)){w <- ".3+.5*exp(1+4*u)/(1+exp(1+4*u))"}
if(is.na(dwL)){dwL <- .3}
if(is.na(dwU)){dwU <- .9}
nn <- n
par(mfcol = c(2,2))
knots <- 100; z <- seq(0,1,len=knots);
DDATA <- "Data10.12"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 5,nrow=nn)
BB <- rbinom(nn,size=1,prob=0.5)
eps <- 2*(BB-0.5)*rexp(nn,rate=1/b)
DATA[,1] <- runif(nn)
DATA[,2] <- dcornerf(c=corn,Z=DATA[,1],CFUN=CFUN) + sigma*rnorm(nn)
DATA[,3] <- DATA[,1] + eps
u <- DATA[,3]
eval(parse(text=paste("wU <- ",w)))
wU[wU >dwU] <- dwU; wU[wU < dwL] <- dwL
DATA[,4] <-rbinom(n,1,wU)
DATA[,5] <- wU
if(WRITE){write(t(DATA), file=DDATA, ncol=5)}
}
X <- DATA[,1];Y <- DATA[,2]; U <-DATA[,3]; A <- DATA[,4];wU <- DATA[,5]
#Diagram 1 Regular regression
f <- dcornerf(c = corn, Z = z, CFUN = CFUN)
fest <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0,
FLAGSUBTR=1, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
fM <- cbind(f,fest)
ISE <- signif(mean((f-fest)^2),2)
llim <- range(fM)
llim <- range(c(llim, range(Y)))
matplot(z, fM, type = "l", lty = 1:2,col=c(1,1+COL),sub=paste("n = ",nn),
main=paste("Hidden Regression, ", "ISE = ",ISE),
xlab = "X", ylab = "Y", ylim = llim,lwd=2)
lines(X, Y, type = "p", pch = 1)
#Diagram 2 Estimation of w(U)
a1 <- min(U);b1 <- max(U); USC <- (U-a1)/(b1-a1)
w.est<- estcregN(X=USC, Y = A,V=NA,p=NA,H=1,Z=USC,FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH,FLAGNEG=0)$fest
w.est[w.est < c/log(nn)] <- c/log(nn);w.est[w.est > 1] <- 1
matplot(U,cbind(A,wU,w.est), xlab="U",ylab="A",type="p",pch=1:3,
main=paste("Availability Likelihood, N = ",sum(A)),
col=c(1,1+COL,1+2*COL))
#Diagram 3 Estimation f^X
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))-1
H <- (1+b^2*(pi*(0:JMAX))^2)^(-1)
H[H^2 < CH*n^(-1)*log(n)] <- 10^5
dens.est <- estcdenGEN(X =U, V=NA, H=H,Z=z, FLAGNEG=1,
FLAGBUMP=0,theta0=1,cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
mmm <- hist(U, plot=F, nclass = floor(nn/8))$density
hist(U, freq=F, nclass = floor(nn/8),
ylim=c(0,max(1,dens.est,mmm)),xlab="U, x",
main=paste("Estimation of Design Density"))
lines(z,dcornerf(corn=1,Z=z),lwd=2)
lines(z,dens.est,lty=2,col=1+COL,lwd=2)
#Diagram 4 Regression
gNest<- estcregN(X=U, Y = Y,V=NA,p=rep(1,length(Y)),H=H,Z=z,FLAGSUBTR=1,
cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH,FLAGNEG=0)$fest
gNest <- negden(gNest,FLAGBUMP=1,cB=2)
dens.est[dens.est < c/log(nn+20)] <- c/log(nn+20)
fest <- gNest/dens.est
f <- dcornerf(c = corn, Z = z, CFUN = CFUN)
fM <- cbind(f,fest)
ISE <- signif(mean((f-fest)^2),2)
llim <- range(fM)
llim <- range(c(llim, range(Y)))
matplot(z, fM, type = "l", lty = 1:2,col=c(1,1+COL),
main=paste("Missing MEP Regression, ISE = ",ISE),
xlab = "U, x", ylab = "AY", ylim = llim,xlim=range(U),lwd=2)
lines(U, A*Y, type = "p", pch = 2-A)
}
if((fig==13)){
if(is.na(n)){n<- 100}
if(is.na(corn)){corn <- 2}
if(is.na(sigma)){sigma<- 1}
if(is.na(w)){w <- ".1 + .9*x"}
if(is.na(dwL)){dwL <- .2}
if(is.na(dwU)){dwU <- .9}
nn <- n
par(mfcol = c(2,2))
knots <- 100; z <- seq(0,1,len=knots);
DDATA <- "Data10.13"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 5,nrow=nn)
BB <- rbinom(nn,size=1,prob=0.5)
eps <- 2*(BB-0.5)*rexp(nn,rate=1/b)
DATA[,1] <- runif(nn)
DATA[,2] <- dcornerf(c=corn,Z=DATA[,1],CFUN=CFUN) + sigma*rnorm(nn)
DATA[,3] <- DATA[,1] + eps
x <- DATA[,1]
eval(parse(text=paste("wX <- ",w)))
wX[wX >dwU] <- dwU; wX[wX < dwL] <- dwL
DATA[,4] <-rbinom(n,1,wX)
DATA[,5] <- wX
if(WRITE){write(t(DATA), file=DDATA, ncol=5)}
}
X <- DATA[,1];Y <- DATA[,2]; U <-DATA[,3]; A <- DATA[,4];wX <- DATA[,5]
#Diagram 1 Regular regression
f <- dcornerf(c = corn, Z = z, CFUN = CFUN)
fest <- estcregN(X = X, Y = Y, Z=z, cJ0 = cJ0,
FLAGSUBTR=1, cJ1 = cJ1, cTH = cTH,cB = cB)$fest
fest <- negden(fest,FLAGBUMP=1,cB=2)
fM <- cbind(f,fest)
ISE <- signif(mean((f-fest)^2),2)
llim <- range(fM)
llim <- range(c(llim, range(Y)))
matplot(z, fM, type = "l", lty = 1:2,col=c(1,1+COL),sub=paste("n = ",nn),
main=paste("Hidden Regression, ", "ISE = ",ISE),
xlab = "X", ylab = "Y", ylim = llim,lwd=2)
lines(X, Y, type = "p", pch = 1)
#Diagram 2 Estimation of q(x)
JMAX <- ceiling(cJ0 + cJ1 * log(nn+ 20))-1
H <- (1+b^2*(pi*(0:JMAX))^2)^(-1)
H[H^2 < CH*n^(-1)*log(n)] <- 10^5
q.est<- estcregN(X=U, Y = A*Y,V=NA,p=rep(1,length(U)),H=H,Z=z,
FLAGSUBTR=0,
cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH,FLAGNEG=0)$fest
q.est[q.est < 0] <-0
x <- z
eval(parse(text=paste("wz <- ",w)))
wz[wz >dwU] <- dwU; wz[wz < dwL] <- dwL
q <- wz*dcornerf(c=corn, Z=z, CFUN=CFUN)
matplot(z,cbind(q,q.est,wz),
xlab="x",ylab="q",type="l",lty=1:3,lwd=2,
main=paste("Estimation of q(x), N = ",sum(A)),col=c(1,1+COL,1+2*COL))
#Diagram 3 Estimation f^{X|A}(x|1)
dens.est <- estcdenGEN(X =U[A==1], V=NA, H=H,Z=z, FLAGNEG=1,
FLAGBUMP=0,theta0=1,cJ0 = cJ0, cJ1 = cJ1, cB = cB,cTH=cTH)$fest
mmm <- hist(U[A==1], plot=F, nclass = floor(nn/8))$density
pp <- dcornerf(corn=1,Z=z)*wz; ppp <- pp/mean(pp)
hist(U[A==1], freq=F, nclass = floor(nn/8),
ylim=c(0,max(c(1,dens.est,ppp,mmm))),xlab="U[A==1], x",
main=paste("Conditional Density"))
lines(z,ppp,lwd=2)
lines(z,dens.est,lty=2,col=1+COL,lwd=2)
#Diagram 4 Regression
dens.est[dens.est < c/log(nn+20)] <- c/log(nn+20)
fest <- n*q.est/(dens.est*sum(A))
fM <- cbind(f,fest,q/pp)
ISE <- signif(mean((f-fest)^2),2)
llim <- range(fM)
llim <- range(c(llim, range(Y)))
matplot(z, fM, type = "l", lty = 1:3,col=c(1,1+COL,1+2*COL),
main=paste("Missing MEP Regression, ISE = ",ISE),
xlab = "U, x", ylab = "AY", ylim = llim,xlim=range(U),lwd=2)
lines(U, A*Y, type = "p", pch = 2-A)
}
if((fig==14)){
if(is.na(set.c[1])){set.c <- c(2,3)}
if(is.na(set.n[1])){set.n <- c(100,200)}
nn <- max(set.n)
par(mfcol = c(3, 2))
knots <- 600; z <- seq(0,1,len=knots)
DDATA <- "Data10.14"
if(SIM==0){DATA <- read.table(DDATA)}
if(SIM==1){DATA <- matrix(-10,ncol= 2,nrow=nn)
DATA[,1] <- rcornerf(c=set.c[1],n=nn,CFUN = CFUN)
DATA[,2] <- rcornerf(c=set.c[2],n=nn,CFUN = CFUN)
if(WRITE){write(t(DATA), file=DDATA, ncol=2)}
}
for(i in c(1,2)){
nnn <-set.n[i]
X <- DATA[,i]; X <-X[1:nnn]; X <- sort(X)
f <- dcornerf(c=set.c[i],Z=z);
##Diagram1
FF <-cumsum(f)/length(z)
FF.est <- ecdf(X)
FF.est <- FF.est(z)
ISEF <- signif(mean((FF.est-FF)^2),dig=2)
mmm <- hist(X, plot=F,nclass = floor(nn/8))$density
hist(X, freq=F, nclass = floor(nn/8),
ylim=c(0,max(c(1,mmm))),
xlim=c(0,1), xlab="X", ylab="",
main=paste("CDF, n = ", nnn,", ISE = ",ISEF))
lines(z,FF,lwd=2)
lines(z,FF.est,col=1+COL,lty=2,lwd=2)
#Diagram2
f.est <- estcdenGEN(X=X, V=NA, H=NA,Z=z,
FLAGNEG=1,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
mmm <- hist(X, plot=F,nclass = floor(nn/8))$density
ISE <- signif(mean((f.est-f)^2),dig=2)
hist(X, freq=F, nclass = floor(nn/8),
ylim=c(0,max(f,f.est,mmm)),
xlim=c(0,1), xlab="X",
main=paste("Density, ISE = ",ISE))
lines(z,f,lwd=2)
lines(z,f.est,col=1+COL,lty=2,lwd=2)
#Diagram 3
f.estN <- estcdenGEN(X=X, V=NA, H=NA,Z=z,
FLAGNEG=0,theta0=1,cJ0 = cJ0, cJ1 =cJ1, cB = cB,cTH=cTH)$fest
fD <- (f[2:knots]-f[1:(knots-1)])*knots; fD<- c(fD[1],fD)
fD.est <- (f.estN[2:knots]-f.estN[1:(knots-1)])*knots
fD.est<- c(fD.est[1],fD.est)
ISE <- signif(mean((fD.est-fD)^2),dig=2)
matplot(z,cbind(fD,fD.est),type="l", lty=1:2, lwd=2,ylab="q(x)",col=c(1,1+COL),
xlab="x", main=paste("Derivative of Density, ISE = ",ISE))
}
}
}
###END CHAPTER 10
################################################################################
#END OF CHAPTERS
##############################################################################
##################################################################
ab.vec<-function(f = NA)
{
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)
{
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
}
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
}
dcornerf<-function(cornerf = 2, Z= NA, CFUN = list(NA, NA),shape1=shape1,shape2=shape2)
{
z <- Z
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) {
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 == 6) {
f <- dnorm(z, 2, 0.8)/(sum(dnorm(seq(0, 1, len = 1000), 2, 0.8))/1000)
}
else if(cornerf==7){
zz <- 0.9*z+0.05
f <- 0.9* dbeta(zz,shape1=shape1,shape2=shape2)/(pbeta(0.95,shape1=shape1,
shape2=shape2)-pbeta(0.05,shape1=shape1,shape2=shape2))
}
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))
{
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)
{
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]
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 <- (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
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)
{
m <- matrix(1, nrow = J, ncol = J)
m[row(m) > col(m)] <- 0
m
}
#############################################################################################################################
#############################################################################################################################
estcden.int<-function(X = NA, knots = 100, cJ0 = 4, cJ1 = 0.5, cJM = 6, cT = 4, cB = 2, FLAGNNEG = 1, a = 0, b = 1)
{
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)
{
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)
{
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))
}
}
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)
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(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
}
#############################################################################################################################
#############################################################################################################################
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)
{
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)
{
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)
{
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)
{
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)
{
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)
{
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)
{
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)
{
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)
{
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")
}
}
#############################################################################################################################
#############################################################################################################################
ffractgn<-function(n = 10, alpha = 0.5)
{
H <- 1 - alpha/2
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)
{
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)
{
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)
{
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)
}
#############################################################################################################################
#############################################################################################################################
legapr<-function(f = NA, z = NA, level = 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)
{
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))
{
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")
{
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)
{
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
}
#############################################################################################################################
#############################################################################################################################
#############################################################################################################################
rcornerf<-function(cornerf = 2, n = 1000, CFUN = list(NA, NA), shape1=shape1,shape2=shape2)
{
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) {
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 == 6) {
nn <- n
while(flag == 1) {
s <- rnorm(5*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 == 7) {
while(flag ==1){
s <- rbeta(5*n + 1, shape1=shape1,shape2=shape2)
sampl <- c(s[(s >= 0.05) & (s <= 0.95)], sampl)
if(length(sampl) >n) {
flag <- 0
sampl <- (sampl[1:n]-0.05)/0.9
}
}
}
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)
{
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)
{
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)
{
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))
{
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) {
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)
{
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)
{
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)
{
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.der<-function(X = NA, knots = NA, cJ0 = NA, cJ1 = NA, cJM = NA, cT = NA, cTP = NA, cB = NA)
{
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.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)
{
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 <- 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
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<-illp.heat1fcgh
#################################################################################
################################################################################
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
}