##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[fdU] <-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 }