https://github.com/cran/quantreg
Raw File
Tip revision: d90516ef8fb8d7c848eb685f443359b2a267a100 authored by Roger Koenker on 18 September 2004, 00:00:00 UTC
version 3.52
Tip revision: d90516e
khmal.R
"khmaladze.test" <-
function(fit, nullH = "location-scale", trim = c(0.25, 0.75) ) 
{
    # Compute Khmaladze test statistics:  fit is produced by rqProcess()
    J <- standardize(fit, nullH)
    Vtilde <- khmaladzize(fit$taus, fit$coef[1,], J$Vhat, nullH)
    vtilde <- khmaladzize(fit$taus, fit$coef[1,], J$vhat, nullH)
    trim <- ( fit$taus >= trim[1] & fit$taus <= trim[2] )	
    if(nullH == "location-scale") {
        Tvtilde <- (vtilde-vtilde[,2])/sqrt(max(fit$taus)-min(fit$taus))
        Tn <- max( apply(abs(Vtilde-Vtilde[,2])/
		 sqrt(max(fit$taus)-min(fit$taus)), 2,"sum")[trim] )
        THn <- apply(abs(Tvtilde[,trim]),1,max)
    	}
    else if( nullH ==  "location"){
        Tn <- max( apply( abs(Vtilde-Vtilde[,2])/
                sqrt(max(fit$taus)-min(fit$taus)), 2,"sum")[trim] )
        THn <- apply(abs((vtilde[,trim]-vtilde[,2])/
                sqrt(max(fit$taus)-min(fit$taus))),1,max)
        }
    x <- list(nullH = nullH, Tn = Tn, THn = THn)
    class(x) <- "khmaladze"
    x
}
"standardize" <-
function (fit, nullH = "location-scale") 
{
    Vhat <- fit$coefs
    vhat <- fit$coefs
    p <- nrow(vhat)
    if (nullH == "location-scale") {
	b <- matrix(0,2,p)
	ER <- fit$coefs
        for (i in 2:p) {
            er <- lm(fit$coefs[i, ] ~ fit$coefs[1, ])
            b[, i] <- er$coef
            ER[i, ] <- er$resid
	   }
        for (j in 1:length(fit$taus)) {
            V <- fit$Hinv[, , j] %*% fit$J %*% fit$Hinv[, , j]
            v <- V[-1, -1] + V[1, 1] * outer(b[2, -1], b[2, -1]) - 
                outer(V[-1, 1], b[2, -1]) - t(outer(V[-1, 1], b[2, -1]))
            v <- solve(v)
            v <- chol(0.5 * (v + t(v)))
            Vhat[-1, j] <- v %*% ER[-1, j]
            for (i in 2:dim(V)[1]) {
                v <- V[i, i] + V[1, 1] * b[2, i]^2 - 2 * V[i, 1] * b[2, i]
                vhat[i, j] <- ER[i, j]/sqrt(v)
                }
            }
        }
    else if (nullH == "location") {
        b <- apply(fit$coefs, 1, mean)
        ER <- fit$coefs - b
        for (j in 1:length(fit$taus)) {
            V <- fit$Hinv[, , j] %*% fit$J %*% fit$Hinv[, , j]
            v <- V[-1, -1]
            v <- solve(v)
            v <- chol(0.5 * (v + t(v)))
            Vhat[-1, j] <- v %*% ER[-1, j]
            for (i in 2:dim(fit$Hinv)[1]) {
                v <- V[i, i]
                vhat[i, j] <- ER[i, j]/sqrt(v)
                }
            }
        }
    else stop(paste("unrecognized nullH: ",nullH)) 
    list(Vhat=Vhat, vhat=vhat)
}
"khmaladzize" <-
function(tau, atau, Z, nullH)
{
	p <- diff( tau )
	p <- c( p[1], p )
	score <- akj(atau, atau, p)  
	L <- length(tau)
	gdot2 <- -score$psi
	gdot <- cbind(rep(1,L),gdot2)
	if(nullH == "location-scale")
	{
		gdot3 <- gdot2 * atau
		gdot <- cbind(gdot, gdot3)
	}
	kmin <- 0
	p <- nrow(Z)
	# the v process 
	for (i in 1:p) 
	{
		v <- Z[i,]
		dtau <- diff(tau)
		dtau <- c(dtau[1], dtau)
		dv <- c(0,diff(v))
		x1 <- gdot*sqrt(dtau)
		x1 <- x1[L:1,]
		y1 <- rev(dv/sqrt(dtau))
		bhat <- lm.fit.recursive(x1,y1,int=FALSE)
		bhat <- bhat[,L:1]
		dvhat <- diag(gdot%*%bhat)*dtau
		vhat <- cumsum(dvhat)
		v <- v[kmin:L-kmin]
		vhat <- vhat[kmin:L-kmin]
		Z[i,] <- v-vhat
	}
	return(Z)
}
"rqProcess" <-
function(formula, data, taus=seq(0.2,0.8,by=0.1) ) 
{
	z <- summary(lm(formula, data=data))
	ols <- z$coef
	vars <- names(z$coef[,1])
	p <- length(z$coefficients[,1])
	J <- solve(z$cov.unscaled)
	#
	# Compute RQ process 
	#
	ntaus <- length( taus )
	coefs<- matrix( 0, p, ntaus )
	Hinv <- array( 0, c(p, p, ntaus) )
	cat("taus: ")
	for(i in 1:ntaus)
	{
		cat(taus[i]," ")
		z <- summary(rq(formula,tau=taus[i],method="fn", data=data), se = "nid", hs=FALSE)
		coefs[,i] <- z$coefficients[,1]
		Hinv[,,i] <- z$Hinv
	}
    dimnames(coefs) <- list(vars,NULL)
    x <- list(taus = taus, coefs=coefs, J=J, Hinv=Hinv)
    class(x) <- "rqProcess"
    x
}
back to top