.packageName <- "quantreg"
"anova.rq" <-
function (object, ...) 
{
    if (length(list(object, ...)) > 1) {
        return(anova.rqlist(object, ...))
    }
    stop("Anova is only defined (yet) for sequences of rq objects")
}
"anova.rqlist" <-
function (object, ..., test = "Wald", score = "tau") 
{
    objects <- list(object, ...)
    responses <- as.character(lapply(objects, function(x) formula(x)[[2]]))
    sameresp <- responses == responses[1]
    if (!all(sameresp)) 
        stop("Models don't all have the same response variable")
    n <- length(objects[[1]]$y)
    models <- as.character(lapply(objects, function(x) formula(x)))
    nobjects <- length(objects)
    dimp <- lapply(objects, function(x) length(coef(x)))
    objects <- objects[order(-unlist(dimp))]
    models <- as.character(lapply(objects, function(x) formula(x)))
    taus <- unlist(lapply(objects, function(x) x$tau))
    names <- lapply(objects, function(x) names(coef(x)))
    if (test == "Wald") 
        objects <- lapply(objects, function(x) summary(x,se="nid"))
    sametaus <- taus == taus[[1]]
    if (all(sametaus)) {
        Tn <- rep(0, nobjects - 1)
        ndf <- Tn
        ddf <- Tn
        pvalue <- Tn
        topnote <- paste("Model ", format(1:nobjects), ": ", 
            models, sep = "", collapse = "\n")
        if (test == "rank") {
            x1 <- as.matrix(objects[[1]]$x)
            y <- objects[[1]]$y
            for (i in 2:nobjects) {
                if (!all(names[[i]] %in% names[[1]])) 
                  stop("Models aren't nested")
                nullH <- is.na(match(names[[1]], names[[i]]))
                X1 <- as.matrix(x1[, nullH])
                X0 <- as.matrix(objects[[i]]$x)
                Htest <- rq.test.rank(X0, X1, y, score = score, 
                  taus[[1]])
                ndf[i - 1] <- Htest$ndf
                Tn[i - 1] <- Htest$Tn/ndf[i - 1]
                ddf[i - 1] <- Htest$ddf
                pvalue[i - 1] <- Htest$pvalue
            }
        }
        else if (test == "Wald") {
            V <- lapply(objects, function(x) x$cov)
            coef <- lapply(objects, function(x) coef(x)[,1])
            for (i in 2:nobjects) {
                if (!all(names[[i]] %in% names[[1]])) 
                  stop("Models aren't nested")
                nullH <- is.na(match(names[[1]], names[[i]]))
                ndf[i - 1] <- sum(nullH)
		browser()
                Tn[i - 1] <- t((coef[[1]])[nullH]) %*% solve((V[[1]])[nullH, 
                  nullH], (coef[[1]])[nullH])/ndf[i - 1]
                ddf[i - 1] <- n - length(names[[1]])
                pvalue[i - 1] <- 1 - pf(Tn[i - 1], ndf[i - 1], 
                  ddf[i - 1])
            }
        }
        else stop("Mode test only defined for Wald and rank")
    }
    else {
        m <- length(taus)
        for (i in 2:m) {
            if (!setequal(names[[i]], names[[1]])) 
                stop("Models with common tau don't have same X")
        }
        if (names[[1]][1] != "(Intercept)") 
            stop("Intercept required in common tau testing")
        Omega <- outer(taus, taus, pmin) - outer(taus, taus)
        J <- objects[[1]]$J
        p <- dim(J)[1]
        H <- array(unlist(lapply(objects, function(x) x$Hinv)), 
            c(p, p, m))
        H <- matrix(aperm(H, c(1, 3, 2)), p * m, p) %*% t(chol(J))
        W <- (H %*% t(H)) * (kronecker(Omega, outer(rep(1, p), 
            rep(1, p))))
        coef <- unlist(lapply(objects, function(x) coef(x)[,1]))
        D <- kronecker(diff(diag(m)), cbind(0, diag(p - 1)))
        ndf <- (p - 1) * (m - 1)
        Tn <- t(D %*% coef) %*% solve(D %*% W %*% t(D), D %*% 
            coef)/ndf
        ddf <- n * m - p * (m - 1)
        pvalue <- 1 - pf(Tn, ndf, ddf)
        nobjects <- 1
        tnote1 <- paste("Model: ", models[[1]], "\n", sep = "")
        tnote2 <- paste("Test of Equality of Slopes: tau in { ", 
            paste(taus, collapse = " "), " }\n")
        topnote <- paste(tnote1, tnote2, sep = "")
    }
    table <- data.frame(ndf, ddf, Tn, pvalue)
    dimnames(table)[[2]] <- c("Df", "Resid Df", "F value", "Pr(>F)")
    title <- "Quantile Regression Analysis of Variance Table\n"
    a <- structure(table, heading = c(title, topnote), class = c("anova", 
        "data.frame"))
    print(a)
}
"rq.test.rank" <-
function (x0, x1, y, score = "wilcoxon",tau=tau) 
{
    v <- rq(y ~ x0 - 1, tau = -1)
    r <- ranks(v, score,tau)
    x1hat <- as.matrix(qr.resid(qr(cbind(1, x0)), x1))
    Tn <- as.matrix(t(x1hat) %*% r$ranks)
    Tn <- t(Tn) %*% solve(crossprod(x1hat)) %*% Tn/r$A2
    ndf <- ncol(x1)
    Tn <- Tn/ndf
    ddf <- length(y) - ncol(x0)
    pvalue <- 1 - pf(Tn, ndf, ddf)
    list(Tn=Tn, ndf=ndf, ddf=ddf, pvalue=pvalue)
}
"boot.rq"<-
function (x, y, tau = 0.5, R = 200, bsmethod = "xy", mofn = length(y), ...)
{
    n <- length(y)
    x <- as.matrix(x)
    p <- ncol(x) 
    B <- matrix(0, R, p)
    if (bsmethod == "xy") {
	if(mofn < p || mofn > n) stop("mofn is out of range")
        s <- matrix(sample(n, mofn * R, replace = TRUE), mofn, R)
        B <- sqrt(mofn/n)*boot.rq.xy(x, y, s, tau)
    }   
    else if (bsmethod == "pwy") {
        U <- t(x) %*% matrix(((runif(n * R) > tau) - tau), n,
            R)
        B <- boot.rq.pwy(U, x, y, tau)
    }
    else if (bsmethod == "mcmb") {
        B <- boot.rq.mcmb(x, y, tau = tau, R = R)
    }
    else stop("your chosen bootstrap method is not allowed")
    #cat(paste("Bootstrap standard errors based on ",R," replications"))
    B
}
"boot.rq.mcmb" <-
function (x, y, tau = 0.5, R = 200) 
{
	n <- length(y)
	p <- ncol(x)
	if(n < 2000)
		fit <- rq(y~x - 1, tau = tau, ci = FALSE)
	else
		fit <- rq(y~x - 1, tau = tau, method = "fn")
	coef <- fit$coef
	svdx <- svd(x)
	condx <- svdx$d[1]/svdx$d[p]
	Ainv <- svdx$v %*% diag(svdx$d) %*% t(svdx$v) 
	coefTilda <-  Ainv %*% coef
	A <- svdx$v %*% diag(1/svdx$d) %*% t(svdx$v) 
	r <- fit$resid
    	psi <- signr <- sign(r)
    	psi[signr > 0] <- tau
    	psi[signr < 0] <- tau - 1
	psimat <- matrix(psi, nrow = n, ncol = p, byrow = FALSE)
	x <- x %*% A
	ZTilda <- x * psimat
	sumxij <- apply(x, 2, sum)
	sumabsxij <- apply(abs(x), 2, sum)
	zstar <- .C("bootnp", as.double(t(x)), as.double(y), 
		as.double(tau), as.double(coefTilda), 
		as.double(t(A)), as.double(ZTilda), 
		as.double(sumxij), as.double(sumabsxij), 
		as.integer(n), as.integer(p), success = as.integer(1), 
		theta = as.double(rep(0, R * p + p), as.integer(c(p, R + 1))), 
		as.integer(R), PACKAGE = "quantreg")
	if (zstar$success == 0) 
		return(list(success = 0))
	else{
		B <- matrix(zstar$theta,p,R+1)[,-1]
		B <- t(A %*% B)
		}
	B
}

"boot.rq.xy"<-
function(x, y, s, tau = 0.5, tol = 0.0001)
{
#function to compute xypairs bootstrap for regression quantiles 
#stripped down for monte-carlo purposes
	x <- as.matrix(x)
	p <- ncol(x)
	n <- nrow(x)
	R <- ncol(s)
	m <- nrow(s)
	z <- .Fortran("xys",
		as.integer(m),
		as.integer(n),
		as.integer(p),
		as.integer(R),
		as.integer(m + 5),
		as.integer(p + 2),
		as.double(x),
		as.double(y),
		as.double(tau),
		as.double(tol),
		flag = as.integer(1),
		coef = double(p * R),
		resid = double(m),
		integer(m),
		double((m + 5) * (p + 2)),
		double(m),
		as.integer(1),
		sol = double((p + 2)),
		dsol = double(m),
		lsol = as.integer(0),
		xx = double(m * p),
		yy = double(m),
		as.integer(s),
		PACKAGE = "quantreg")
	return(t(matrix(z$coef, p, R)))
}
"boot.rq.pwy"<-
function(U,X, y, tau = 0.5, tol=1e-4)
{
#resampling method of parzen,wei,ying for quantile regression
#NB. x should be full design matrix including intercept
	n <- length(y)
	p <- ncol(X)
	R <- ncol(U)
	Y <- c(y,500000)
	x <- rbind(X,0)
	xu <- t(U)/tau
	n <- n+1
	z<-.Fortran("pwy",
		as.integer(n),
		as.integer(p),
		as.integer(R),
		as.integer(n + 5),
		as.integer(p + 2),
		as.double(xu),
		as.double(x),
		as.double(Y),
		as.double(tau),
		as.double(tol),
		flag = as.integer(1),
		coef = double(p * R),
		resid = double(n),
		integer(n),
		double((n + 5) * (p + 2)),
		double(n),
		as.integer(1),
		sol = double((p + 2)),
		dsol = double(n),
		lsol = as.integer(0),
		PACKAGE = "quantreg")
	return(t(matrix(z$coef, p, R)))
}
".First.lib" <-
function(lib, pkg) {
   library.dynam("quantreg", pkg, lib)
   print("quantreg library loaded")}

"bandwidth.rq" <-
function(p, n, hs = TRUE, alpha = 0.05)
{
	# Bandwidth selection for sparsity estimation two flavors:
	#	Hall and Sheather(1988, JRSS(B)) rate = O(n^{-1/3})
	#	Bofinger (1975, Aus. J. Stat)  -- rate = O(n^{-1/5})
	# Generally speaking, default method, hs=TRUE is preferred.
	PI <- pi
	x0 <- qnorm(p)
	f0 <- (1/sqrt(2 * PI)) * exp( - ((x0^2/2)))
	if(hs == TRUE)
		n^(-1/3) * qnorm(1 - alpha/2)^(2/3) * ((1.5 * f0^2)/(2 * x0^
			2 + 1))^(1/3)
	else n^-0.2 * ((4.5 * f0^4)/(2 * x0^2 + 1)^2)^ 0.2
}


"plot.rq.process" <-
# Function to plot estimated quantile regression  process
function(x, nrow = 3, ncol = 2, ...)
{
	tdim <- dim(x$sol)
	p <- tdim[1] - 3
	m <- tdim[2]
	par(mfrow = c(nrow, ncol))
	ylab <- dimnames(x$sol)[[1]]
	for(i in 1:p) {
		plot(x$sol[1,], x$sol[3 + i,  ], xlab = "tau", ylab = ylab[3 +
			i], type = "l")
	}
}


"print.rq" <-
function(x, ...)
{
	if(!is.null(cl <- x$call)) {
		cat("Call:\n")
		dput(cl)
	}
	coef <- coef(x)
	cat("\nCoefficients:\n")
	print(coef, ...)
	rank <- x$rank
	nobs <- length(residuals(x))
	if(is.matrix(coef))
		p <- dim(coef)[1]
	else p <- length(coef)
	rdf <- nobs - p
	cat("\nDegrees of freedom:", nobs, "total;", rdf, "residual\n")
	if(!is.null(attr(x, "na.message")))
		cat(attr(x, "na.message"), "\n")
	invisible(x)
}

"print.summary.rq" <-
function(x, digits = max(5, .Options$digits - 2), ...)
{
	cat("\nCall: ")
	dput(x$call)
	coef <- x$coef
	df <- x$df
	rdf <- x$rdf
	tau <- x$tau
	cat("\nCoefficients:\n")
	print(format(round(coef, digits = digits)), quote = FALSE, ...)
	invisible(x)
}

"ranks" <-
function(v, score = "wilcoxon", tau = 0.5)
{
	A2 <- 1
	if(score == "wilcoxon") {
		J <- ncol(v$sol)
		dt <- v$sol[1, 2:J] - v$sol[1, 1:(J - 1)]
		ranks <- as.vector((0.5 * (v$dsol[, 2:J] + v$dsol[, 1:(J - 1)]) %*%
			dt) - 0.5)
		A2 <- 1/12
		return(list(ranks=ranks, A2=A2))
	}
	else if(score == "normal") {
		J <- ncol(v$sol)
		dt <- v$sol[1, 2:J] - v$sol[1, 1:(J - 1)]
		dphi <- c(0, dnorm(qnorm(v$sol[1, 2:(J - 1)])), 0)
		dphi <- diff(dphi)
		ranks <- as.vector((((v$dsol[, 2:J] - v$dsol[, 1:(J - 1)]))) %*%
			(dphi/dt))
		return(list(ranks=ranks, A2=A2))
	}
	else if(score == "sign") {
		j.5 <- sum(v$sol[1,  ] < 0.5)
		w <- (0.5 - v$sol[1, j.5])/(v$sol[1, j.5 + 1] - v$sol[1, j.5])
		r <- w * v$dsol[, j.5 + 1] + (1 - w) * v$dsol[, j.5]
		ranks <- 2 * r - 1
		return(list(ranks=ranks, A2=A2))
	}
	else if(score == "tau") {
		j.tau <- sum(v$sol[1,  ] < tau)
		w <- (tau - v$sol[1, j.tau])/(v$sol[1, j.tau + 1] - v$sol[
			1, j.tau])
		r <- w * v$dsol[, j.tau + 1] + (1 - w) * v$dsol[, j.tau]
		ranks <- r - (1-tau)
        	A2 <- tau * (1-tau)
		return(list(ranks=ranks, A2=A2))
	}
	else if(score == "interquartile") {
		j.25 <- sum(v$sol[1,  ] < 0.25)
		w <- (0.25 - v$sol[1, j.25])/(v$sol[1, j.25 + 1] - v$sol[1,
			j.25])
		r.25 <- w * v$dsol[, j.25 + 1] + (1 - w) * v$dsol[, j.25]
		j.75 <- sum(v$sol[1,  ] < 0.75)
		w <- (0.75 - v$sol[1, j.75])/(v$sol[1, j.75 + 1] - v$sol[1,
			j.75])
		r.75 <- w * v$dsol[, j.75 + 1] + (1 - w) * v$dsol[, j.75]
		ranks <- 0.5 + r.75 - r.25
		A2 <- 1/4
		return(list(ranks=ranks, A2=A2))
	}
	else stop("invalid score function")
}

"rq" <-
function(formula, tau = 0.5, data, weights, na.action, method = "br", contrasts
	 = NULL, ...)
{
	call <- match.call()
	m <- match.call(expand = FALSE)
	m$method <- m$model <- m$x <- m$y <- m$contrasts <- m$tau <- m$... <-
		NULL
	m[[1]] <- as.name("model.frame")
	m <- eval(m, sys.frame(sys.parent()))
	if(method == "model.frame")
		return(m)
	Terms <- attr(m, "terms")
	weights <- model.extract(m, weights)
	Y <- model.extract(m, response)
	X <- model.matrix(Terms, m, contrasts)
	process <- (tau < 0 || tau > 1)
	fit <- {
		if(length(weights))
			rq.wfit(X, Y, tau = tau, weights, method, ...)
		else rq.fit(X, Y, tau = tau, method, ...)
	}
	fit$formula <- formula
	fit$terms <- Terms
	fit$call <- call
	fit$tau <- tau
	attr(fit, "na.message") <- attr(m, "na.message")
	class(fit) <- ifelse(process, "rq.process", "rq")
	fit
}

"rq.fit" <-
function(x, y, tau = 0.5, method = "br", ...)
{
	#if(!is.numeric(x)) stop("model matrix must be numeric")
	#if(!is.numeric(y)) stop("response must be numeric")
	fit <- switch(method,
		fn = rq.fit.fn(x, y, tau = tau, ...),
		fnb = rq.fit.fnb(x, y, tau = tau, ...),
		fnc = rq.fit.fnc(x, y, tau = tau, ...),
		pfn = rq.fit.pfn(x, y, tau = tau, ...),
		br = rq.fit.br(x, y, tau = tau, ...),
		{
			what <- paste("rq.fit.", method, sep = "")
			if(exists(what, mode = "function"))
				(get(what, mode = "function"))(x, y, ...)
			else stop(paste("unimplemented method:", method))
		}
		)
	fit$contrasts <- attr(x, "contrasts")
	fit
}

"rq.fit.br" <-
# Function to compute regression quantiles using original simplex approach
# of Barrodale-Roberts/Koenker-d'Orey.  There are several options.
# The options are somewhat different than those available for the Frisch-
# Newton version of the algorithm, reflecting the different natures of the
# problems typically solved.  Succintly BR for "small" problems, FN for
# "large" ones.  Obviously, these terms are conditioned by available hardware.
#
# Basically there are two modes of use:
# 1.  For Single Quantiles:
#
#       if tau is between 0 and 1 then only one quantile solution is computed.
#
#       if ci = FALSE  then just the point estimate and residuals are returned
#		If the column dimension of x is 1 then ci is set to FALSE since
#		since the rank inversion method has no proper null model.
#       if ci = TRUE  then there are two options for confidence intervals:
#
#               1.  if iid = TRUE we get the original version of the rank
#                       inversion intervals as in Koenker (1994)
#               2.  if iid = FALSE we get the new version of the rank inversion
#                       intervals which accounts for heterogeneity across
#                       observations in the conditional density of the response.
#                       The theory of this is described in Koenker-Machado(1999)
#               Both approaches involve solving a parametric linear programming
#               problem, the difference is only in the factor qn which
#               determines how far the PP goes.  In either case one can
#               specify two other options:
#                       1. interp = FALSE returns two intervals an upper and a
#                               lower corresponding to a level slightly
#                               above and slightly below the one specified
#                               by the parameter alpha and dictated by the
#                               essential discreteness in the test statistic.
#				interp = TRUE  returns a single interval based on
#                               linear interpolation of the two intervals
#                               returned:  c.values and p.values which give
#                               the critical values and p.values of the
#                               upper and lower intervals. Default: interp = TRUE.
#                       2.  tcrit = TRUE uses Student t critical values while
#                               tcrit = FALSE uses normal theory ones.
# 2. For Multiple Quantiles:
#
#       if tau < 0 or tau >1 then it is presumed that the user wants to find
#       all of the rq solutions in tau, and the program computes the whole
#	quantile regression solution as a process in tau, the resulting arrays
#	containing the primal and dual solutions, betahat(tau), ahat(tau)
#       are called sol and dsol.  These arrays aren't printed by the default
#       function print.rq but they are available as attributes.
#       It should be emphasized that this form of the solution can be
#	both memory and cpu quite intensive.  On typical machines it is
#	not recommended for problems with n > 10,000.
#	In large problems a grid of solutions is probably sufficient.
#
function(x, y, tau = 0.5, alpha = 0.10000000000000001, ci = FALSE, 
	iid = TRUE, interp = TRUE, tcrit = TRUE)
{
	tol <- .Machine$double.eps^(2/3)
	eps <- tol
	big <- .Machine$double.xmax
	x <- as.matrix(x)
	p <- ncol(x)
	n <- nrow(x)
	nsol <- 2
	ndsol <- 2
	if(tau < 0 || tau > 1) {
		nsol <- 3 * n
		ndsol <- 3 * n
		lci1 <- FALSE
		qn <- rep(0, p)
		cutoff <- 0
		tau <- -1
	}
	else {
		if(p==1) ci <- FALSE
		if(ci) {
			lci1 <- TRUE
			if(tcrit)
				cutoff <- qt(1 - alpha/2, n - p)
			else cutoff <- qnorm(1 - alpha/2)
			if(!iid) {
				h <- bandwidth.rq(tau, n, hs = TRUE)
				bhi <- rq.fit.br(x, y, tau + h, ci = FALSE)
				bhi <- coefficients(bhi)
				blo <- rq.fit.br(x, y, tau - h, ci = FALSE)
				blo <- coefficients(blo)
				dyhat <- x %*% (bhi - blo)
				if(any(dyhat <= 0)) {
					pfis <- (100 * sum(dyhat <= 0))/n
					warning(paste(pfis, "percent fis <=0"))
				}
				f <- pmax(eps, (2 * h)/(dyhat - eps))
				qn <- rep(0, p)
				for(j in 1:p) {
					qnj <- lm(x[, j] ~ x[,  - j] - 1,
						weights = f)$resid
					qn[j] <- sum(qnj * qnj)
				}
			}
			else qn <- 1/diag(solve(crossprod(x)))
		}
		else {
			lci1 <- FALSE
			qn <- rep(0, p)
			cutoff <- 0
		}
	}
	assign <- attr(x, "assign")
	z <- .Fortran("rqbr",
		as.integer(n),
		as.integer(p),
		as.integer(n + 5),
		as.integer(p + 3),
		as.integer(p + 4),
		as.double(x),
		as.double(y),
		as.double(tau),
		as.double(tol),
		flag = as.integer(1),
		coef = double(p),
		resid = double(n),
		integer(n),
		double((n + 5) * (p + 4)),
		double(n),
		as.integer(nsol),
		as.integer(ndsol),
		sol = double((p + 3) * nsol),
		dsol = double(n * ndsol),
		lsol = as.integer(0),
		h = integer(p * nsol),
		qn = as.double(qn),
		cutoff = as.double(cutoff),
		ci = double(4 * p),
		tnmat = double(4 * p),
		as.double(big),
		as.logical(lci1),
		PACKAGE = "quantreg")
	if(z$flag != 0)
		warning(switch(z$flag,
			"Solution may be nonunique",
			"Premature end - possible conditioning problem in x"))
	if(tau < 0 || tau > 1) {
		sol <- matrix(z$sol[1:((p + 3) * z$lsol)], p + 3)
		dsol <- matrix(z$dsol[1:(n * z$lsol)], n)
		vnames <- dimnames(x)[[2]]
		dimnames(sol) <- list(c("tau", "Qbar", "Obj.Fun", vnames),
			NULL)
		return(list(sol=sol, dsol=dsol))
	}
	if(!ci) {
		coef <- z$coef
		names(coef) <- dimnames(x)[[2]]
		return(list(coefficients=coef, x=x, y=y, residuals=z$resid))
	}
	if(interp) {
		Tn <- matrix(z$tnmat, nrow = 4)
		Tci <- matrix(z$ci, nrow = 4)
		Tci[3,  ] <- Tci[3,  ] + (abs(Tci[4,  ] - Tci[3,  ]) * (cutoff -
			abs(Tn[3,  ])))/abs(Tn[4,  ] - Tn[3,  ])
		Tci[2,  ] <- Tci[2,  ] - (abs(Tci[1,  ] - Tci[2,  ]) * (cutoff -
			abs(Tn[2,  ])))/abs(Tn[1,  ] - Tn[2,  ])
		Tci[2,  ][is.na(Tci[2,  ])] <-  - big
		Tci[3,  ][is.na(Tci[3,  ])] <- big
		coefficients <- cbind(z$coef, t(Tci[2:3,  ]))
		vnames <- dimnames(x)[[2]]
		cnames <- c("coefficients", "lower bd", "upper bd")
		dimnames(coefficients) <- list(vnames, cnames)
		residuals <- z$resid
		return(list(coefficients=coefficients, x=x, y=y, 
			residuals=residuals, assign=assign))
	}
	else {
		Tci <- matrix(z$ci, nrow = 4)
		coefficients <- cbind(z$coef, t(Tci))
		residuals <- z$resid
		vnames <- dimnames(x)[[2]]
		cnames <- c("coefficients", "lower bound", "Lower Bound",
			"upper bd", "Upper Bound")
		dimnames(coefficients) <- list(vnames, cnames)
		c.values <- t(matrix(z$tnmat, nrow = 4))
		c.values <- c.values[, 4:1]
		dimnames(c.values) <- list(vnames, cnames[-1])
		p.values <- if(tcrit) matrix(pt(c.values, n - p), ncol = 4)
			    else matrix(pnorm(c.values), ncol = 4)
		dimnames(p.values) <- list(vnames, cnames[-1])
		list(coefficients=coefficients, x=x, y=y, residuals=residuals, 
			c.values=c.values, p.values=p.values)
	}
}

"rq.fit.fn" <-
function (x, y, tau = 0.5, beta = 0.99995, eps = 1e-06)
{
    n <- length(y)
    p <- ncol(x)
    if (n != nrow(x))
        stop("x and y don't match n")
    if (tau < eps || tau > 1 - eps)
        stop("No parametric Frisch-Newton method.  Set tau in (0,1)")
    rhs <- (1 - tau) * apply(x, 2, sum)
    d   <- rep(1,n)
    u   <- rep(1,n)
    wn <- rep(0,10*n)
    wn[1:n] <- (1-tau) #initial value of dual solution
    z <- .Fortran("rqfn", as.integer(n), as.integer(p), a = as.double(t(as.matrix(x))),
        c = as.double(-y), rhs = as.double(rhs), d = as.double(d),as.double(u),
        beta = as.double(beta), eps = as.double(eps), 
        wn = as.double(wn), wp = double((p + 3) * p), aa = double(p *
            p), it.count = integer(2), info = integer(1),PACKAGE= "quantreg")
    if (z$info != 0)
        stop(paste("Error info = ", z$info, "in stepy: singular design"))
    coefficients <- -z$wp[1:p]
    names(coefficients) <- dimnames(x)[[2]]
    residuals <- y - x %*% coefficients
    list(coefficients=coefficients, x=x, y=y, tau=tau, residuals=residuals)
}

"rq.fit.fnb" <-
function (x, y, tau = 0.5, beta = 0.99995, eps = 1e-06)
{
    n <- length(y)
    p <- ncol(x)
    if (n != nrow(x))
        stop("x and y don't match n")
    if (tau < eps || tau > 1 - eps)
        stop("No parametric Frisch-Newton method.  Set tau in (0,1)")
    rhs <- (1 - tau) * apply(x, 2, sum)
    d   <- rep(1,n)
    u   <- rep(1,n)
    wn <- rep(0,10*n)
    wn[1:n] <- (1-tau) #initial value of dual solution
    z <- .Fortran("rqfnb", as.integer(n), as.integer(p), a = as.double(t(as.matrix(x))),
        c = as.double(-y), rhs = as.double(rhs), d = as.double(d),as.double(u),
        beta = as.double(beta), eps = as.double(eps), 
        wn = as.double(wn), wp = double((p + 3) * p), 
        it.count = integer(2), info = integer(1),PACKAGE= "quantreg")
    if (z$info != 0)
        stop(paste("Error info = ", z$info, "in stepy: singular design"))
    coefficients <- -z$wp[1:p]
    names(coefficients) <- dimnames(x)[[2]]
    residuals <- y - x %*% coefficients
    list(coefficients=coefficients, x=x, y=y, tau=tau, residuals=residuals)
}

"rq.fit.fnc" <-
function (x, y, R, r, tau = 0.5, beta = 0.9995, eps = 1e-06) 
{
    n1 <- length(y)
    n2 <- length(r)
    p <- ncol(x)
    if (n1 != nrow(x)) 
        stop("x and y don't match n1")
    if (n2 != nrow(R)) 
        stop("R and r don't match n2")
    if (p != ncol(R)) 
        stop("R and x don't match p")
    if (tau < eps || tau > 1 - eps) 
        stop("No parametric Frisch-Newton method.  Set tau in (0,1)")
    rhs <- (1 - tau) * apply(x, 2, sum)
    u <- rep(1, n1) #upper bound vector
    wn1 <- rep(0, 9 * n1)
    wn1[1:n1] <- (1 - tau) #store the values of x1
    wn2 <- rep(0, 6 * n2) 
    wn2[1:n2] <- 1 #store the values of x2
    z <- .Fortran("rqfnc", as.integer(n1), as.integer(n2), as.integer(p), 
	a1 = as.double(t(as.matrix(x))), c1 = as.double(-y), 
	a2 = as.double(t(as.matrix(R))), c2 = as.double(-r), 
	rhs = as.double(rhs), d1 = double(n1), d2 = double(n2),
	as.double(u), beta = as.double(beta), eps = as.double(eps), 
	wn1 = as.double(wn1), wn2 = as.double(wn2), wp = double((p + 3) * p), 
	it.count = integer(2), info = integer(1),PACKAGE= "quantreg")
    if (z$info != 0) 
        stop(paste("Error info = ", z$info, "in stepy2: singular design"))
    coefficients <- -z$wp[1:p]
    names(coefficients) <- dimnames(x)[[2]]
    residuals <- y - x %*% coefficients
    it.count <- z$it.count
    list(coefficients=coefficients, x=x, y=y, tau=tau, residuals=residuals)
}


"rq.fit.pfn" <-
# This is an implementation (purely in R) of the preprocessing phase
# of the rq algorithm described in Portnoy and Koenker, Statistical
# Science, (1997) 279-300.  In this implementation it can be used
# as an alternative method for rq() by specifying method="pfn"
# It should probably be used only on very large problems and then
# only with some caution.  Very large in this context means roughly
# n > 100,000.  The options are described in the paper, and more
# explicitly in the code.  Again, it would be nice perhaps to have
# this recoded in a lower level language, but in fact this doesn't
# seem to make a huge difference in this case since most of the work
# is already done in the rq.fit.fn calls.
#
function(x, y, tau = 0.5,  Mm.factor = 0.8,
	max.bad.fixup = 3, eps = 1e-6)
{
	#rq function for n large --
	n <- length(y)
	if(nrow(x) != n)
		stop("x and y don't match n")
	if(tau < 0 | tau > 1)
		stop("tau outside (0,1)")
	p <- ncol(x)
	m <- round(((p + 1) * n)^(2/3))
	not.optimal <- TRUE
	while(not.optimal) {
		if(m < n)
			s <- sample(n, m)
		else {
			z <- rq.fit.fn(x, y, tau = tau,  eps = eps)
			list(coef = z$coef)
		}
		xx <- x[s,  ]
		yy <- y[s]
		z <- rq.fit.fn(xx, yy, tau = tau,  eps = eps)
		xxinv <- solve(chol(crossprod(xx)))
		band <- sqrt(((x %*% xxinv)^2) %*% rep(1, p))
		#sqrt(h<-ii)
		r <- y - x %*% z$coef
		M <- Mm.factor * m
		lo.q <- max(1/n, tau - M/(2 * n))
		hi.q <- min(tau + M/(2 * n), (n - 1)/n)
		kappa <- quantile(r/pmax(eps, band), c(lo.q, hi.q))
		sl <- r < band * kappa[1]
		su <- r > band * kappa[2]
		bad.fixup <- 0
		while(not.optimal & (bad.fixup < max.bad.fixup)) {
			xx <- x[!su & !sl,  ]
			yy <- y[!su & !sl]
			if(any(sl)) {
				glob.x <- c(t(x[sl,  , drop = FALSE]) %*% rep(
					1, sum(sl)))
				glob.y <- sum(y[sl])
				xx <- rbind(xx, glob.x)
				yy <- c(yy, glob.y)
			}
			if(any(su)) {
				ghib.x <- c(t(x[su,  , drop = FALSE]) %*% rep(
					1, sum(su)))
				ghib.y <- sum(y[su])
				xx <- rbind(xx, ghib.x)
				yy <- c(yy, ghib.y)
			}
			z <- rq.fit.fn(xx, yy, tau = tau,  eps = eps)
			b <- z$coef
			r <- y - x %*% b
			su.bad <- (r < 0) & su
			sl.bad <- (r > 0) & sl
			if(any(c(su.bad, sl.bad))) {
				if(sum(su.bad | sl.bad) > 0.10000000000000001 *
					M) {
					warning("Too many fixups:  doubling m")
					m <- 2 * m
					break
				}
				su <- su & !su.bad
				sl <- sl & !sl.bad
				bad.fixup <- bad.fixup + 1
			}
			else not.optimal <- FALSE
		}
	}
	coefficients <- b
	names(coefficients) <- dimnames(x)[[2]]
	residuals <- y - x %*% b
	return(list(coefficients=coefficients, x=x, y=y, tau=tau, 
		residuals=residuals))
}

"rq.wfit" <-
function(x, y, tau = 0.5, weights, method = "br",  ...)
{
	if(!is.numeric(x))
		stop("model matrix must be numeric")
	if(!is.numeric(y))
		stop("response must be numeric")
	if(any(weights < 0))
		stop("negative weights not allowed")
	contr <- attr(x, "contrasts")
	x <- x * weights
	y <- y * weights
	fit <- switch(method,
		fn = rq.fit.fn(x, y, tau = tau, ...),
		br = rq.fit.br(x, y, tau = tau, ...),
		{
			what <- paste("rq.fit.", method, sep = "")
			if(exists(what, mode = "function"))
				(get(what, mode = "function"))(x, y, ...)
			else stop(paste("unimplemented method:", method))
		}
		)
	fit$contrasts <- attr(x, "contrasts")
	fit
}

"rrs.test" <-
function(x0, x1, y, v, score = "wilcoxon")
{
	if(missing(v) || is.null(v$dsol))
		v <- rq(y ~ x0, tau = -1)
	r <- ranks(v, score)
	x1hat <- as.matrix(qr.resid(qr(cbind(1, x0)), x1))
	sn <- as.matrix(t(x1hat) %*% r$ranks)
	sn <- t(sn) %*% solve(crossprod(x1hat)) %*% sn/r$A2
	ranks <- r$ranks
	return(list(sn=sn, ranks=ranks))
}

"summary.rq" <-
# This function provides  methods for summarizing the output of the
# rq command. In this instance, "summarizing" means essentially provision
# of either standard errors, or confidence intervals for the rq coefficents.
# Since the preferred method for confidence intervals is currently the
# rank inversion method available directly from rq() by setting ci=TRUE, with br=TRUE.
# these summary methods are intended primarily for comparison purposes
# and for use on large problems where the parametric programming methods
# of rank inversion are prohibitively memory/time consuming.  Eventually
# iterative versions of rank inversion should be developed that would
# employ the Frisch-Newton approach.
#
# Object is the result of a call to rq(), and the function returns a
# table of coefficients, standard errors, "t-statistics", and p-values, and, if
# covariance=TRUE a structure describing the covariance matrix of the coefficients,
# i.e. the components of the Huber sandwich.
#
# There are five options for "se":
#
#	1.  "rank" strictly speaking this doesn't produce a "standard error"
#		at all instead it produces a coefficient table with confidence
#		intervals for the coefficients based on inversion of the
#		rank test described in GJKP and Koenker (1994).  
#	2.  "iid" which presumes that the errors are iid and computes
#		an estimate of the asymptotic covariance matrix as in KB(1978).
#	3.  "nid" which presumes local (in tau) linearity (in x) of the
#		the conditional quantile functions and computes a Huber
#		sandwich estimate using a local estimate of the sparsity.
#	4.  "ker" which uses a kernel estimate of the sandwich as proposed
#		by Powell.
#	5.  "boot" which uses a bootstrap method:
#		"xy"	uses xy-pair method 
#		"pwy"	uses the parzen-wei-ying method 
#		"mcmb"	uses the Markov chain marginal bootstrap method 
#
#
function(object, se = "nid", covariance = TRUE, hs = TRUE, ...)
{
	x <- object$x
	y <- object$y
	tau <- object$tau
	formula <- object$formula
	eps <- .Machine$double.eps^(2/3)
	wt <- object$weights
	coef <- coefficients(object)
	if(is.matrix(coef))
		coef <- coef[, 1]
	vnames <- dimnames(x)[[2]]
	resid <- object$residuals
	n <- length(resid)
	p <- length(coef)
	rdf <- n - p
	if(!is.null(wt)) {
		resid <- resid * wt
		x <- x * wt
		y <- y * wt
	}
	if(missing(se)){
		if(n < 1001) se <- "rank"
		else  se <- "nid"
		}
	if(se == "rank"){
		f <- rq(formula, tau = tau, ci = TRUE, ...)
		return(f)
		}
	#quick and dirty se's in three flavors: iid, nid, and ker
	if(se == "iid") {
		xxinv <- diag(p)
		xxinv <- backsolve(qr(x)$qr[1:p, 1:p], xxinv)
		xxinv <- xxinv %*% t(xxinv)
		pz <- sum(abs(resid) < eps)
		h <- max(p + 1, ceiling(n * bandwidth.rq(tau, n, hs = hs)))
		ir <- (pz + 1):(h + pz + 1)
		ord.resid <- sort(resid[order(abs(resid))][ir])
		xt <- ir/(n-p)
		sparsity <- rq(ord.resid~xt)$coef[2,1]
		cov <- sparsity^2 * xxinv * tau * (1 - tau)
		serr <- sqrt(diag(cov))
	}
	else if(se == "nid") {
		h <- bandwidth.rq(tau, n, hs = hs)
		if(tau+h>1)stop("tau + h > 1:  error in summary.rq")
        	if(tau-h<0)stop("tau - h < 0:  error in summary.rq")
		bhi <- rq.fit.fn(x, y, tau = tau + h)$coef
		blo <- rq.fit.fn(x, y, tau = tau - h)$coef
		dyhat <- x %*% (bhi - blo)
		if(any(dyhat <= 0))
			warning(paste(sum(dyhat <= 0), "non-positive fis"))
		f <- pmax(0, (2 * h)/(dyhat - eps))
		fxxinv <- diag(p)
		fxxinv <- backsolve(qr(sqrt(f) * x)$qr[1:p, 1:p], fxxinv)
		fxxinv <- fxxinv %*% t(fxxinv)
		cov <- tau * (1 - tau) * fxxinv %*% crossprod(x) %*% fxxinv
		serr <- sqrt(diag(cov))
	}
	else if(se == "ker") {
		h <- bandwidth.rq(tau, n, hs = hs)
		if(tau+h>1)stop("tau + h > 1:  error in summary.rq")
        	if(tau-h<0)stop("tau - h < 0:  error in summary.rq")
		h <- qnorm(tau + h) -  qnorm(tau - h)
		uhat <- c(y - x %*% coef)
		f <- dnorm(uhat/h)/h
		fxxinv <- diag(p)
		fxxinv <- backsolve(qr(sqrt(f) * x)$qr[1:p, 1:p], fxxinv)
		fxxinv <- fxxinv %*% t(fxxinv)
		cov <- tau * (1 - tau) * fxxinv %*% crossprod(x) %*% fxxinv
		serr <- sqrt(diag(cov))
	}
	else if(se == "boot"){
		B <- boot.rq(x,y,tau, ...)
		cov <- cov(B)
		serr <- sqrt(diag(cov))
		}
	coef <- array(coef, c(p, 4))
	dimnames(coef) <- list(vnames, c("Value", "Std. Error", "t value",
		"Pr(>|t|)"))
	coef[, 2] <- serr
	coef[, 3] <- coef[, 1]/coef[, 2]
	coef[, 4] <- if(rdf > 0) 2 * (1 - pt(abs(coef[, 3]), rdf)) else NA
#	object <- object[c("call", "terms", "assign")]
	object <- object[c("call", "terms")]
	if(covariance == TRUE) {
		object$cov <- cov
		if(se %in% c("nid","ker")) {
			object$Hinv <- fxxinv
			object$J <- crossprod(x)
			}
		else if(se == "boot"){
			object$B <- B
			}
		}
	object$coefficients <- coef
	object$rdf <- rdf
	object$tau <- tau
	class(object) <- "summary.rq"
	object
}


"akj" <-
function(x, z = seq(min(x), max(x),  , 2 * length(x)), 
	p = rep(1, length(x))/ length(x), h = 0, alpha = 0.5, kappa = 0.9, 
	iker1 = 1, iker2 = 1)
{
        nx <- length(x)
        nz <- length(z)
        x <- sort(x)
        A <- .Fortran("akj",
                as.double(x),
                as.double(z),
                as.double(p),
                as.integer(iker1),
                dens = double(nz),
                psi = double(nz),
                score = double(nz),
                as.integer(nx),
                as.integer(nz),
                h = as.double(h),
                as.double(alpha),
                as.double(kappa),
                double(nx),
		PACKAGE = "quantreg")
        dens <- A$dens
        psi <- A$psi
        score <- A$score
        h <- A$h
        return(list(dens=dens, psi=psi, score=score, h=h))
}
"lm.fit.recursive" <-
function(X, y, int = TRUE)
{
	if(int)
		X <- cbind(1, X)
	p <- ncol(X)
	n <- nrow(X)
	D <- qr(X[1:p,  ])
	A <- qr.coef(D, diag(p))
	A[is.na(A)] <- 0
	A <- crossprod(t(A))
	Ax <- rep(0, p)
	b <- matrix(0, p, n)
	b[, p] <- qr.coef(D, y[1:p])
	b[is.na(b)] <- 0
	z <- .Fortran( "rls",
		as.integer(n),
		as.integer(p),
		as.double(t(X)),
		as.double(y),
		b = as.double(b),
		as.double(A),
		as.double(Ax), 
		PACKAGE = "quantreg")
	bhat <- matrix(z$b, p, n)
	return(bhat)
}
"latex.table.rq" <-
function (object, transpose = FALSE, caption = "caption goes here.", digits = 3,
    file = as.character(substitute(object)), ...)
{
    a <- format(round(object$a, digits))
    taus <- format(round(object$taus, digits))
    tdim <- dim(a)
    p <- tdim[1] 
    k <- tdim[2]
    m <- tdim[3]
    table <- matrix("", p, m)
    for (i in 1:m) {
        for (j in 1:p) {
            if (k == 3) {
                table[j, i] <- paste("$\\underset{(", a[j, 2,
                  i], ",", a[j, 3, i], ")}{", a[j, 1, i], "}$",sep="")
            }
            else if (k == 4) {
                table[j, i] <- paste("$\\underset{(", a[j,2,i] , ")}{", 
			a[j,1, i], "}$",sep="")
            }
        }
    }
    rlab <- dimnames(a)[[1]]
    clab <- taus
    rowlabel <- "Covariates"
    dimnames(table) <- list(rlab, clab)
    if(transpose) {
        table=t(table)
        rowlabel <- "Quantiles"
        }
    latex.table(table, caption = caption, rowlabel = rowlabel,
        file = file)
    invisible()
}
"plot.table.rq" <-
function (x, nrow = 3, ncol = 2, alpha= .1, ...) 
{
#x is an object of class table.rq created by table.rq()
    tdim <- dim(x$a)
    p <- tdim[1]
    k <- tdim[2]
    m <- tdim[3]
    par(mfrow = c(nrow, ncol))
    ylab <- dimnames(x$a)[[1]]
    xx <- x$taus
    zalpha <- qnorm(1-alpha/2)
    for (i in 1:p) {
	if(x$method == "fn"){
		b  <- x$a[i,1,] 
		bl <- x$a[i,1,] - x$a[i,2,]*zalpha
		bu <- x$a[i,1,] + x$a[i,2,]*zalpha
		}
	else {
		b  <- x$a[i,1,] 
		bl <- x$a[i,2,]
		bu <- x$a[i,3,] 
		}
        plot(rep(xx, 2), c(bl,bu), xlab = "tau", ylab = ylab[i], type = "n")
	polygon(c(xx,rev(xx)),c(bl,rev(bu)),col="grey")
        points(xx, b, pch = "o")
        lines(xx, b)
        #lines(xx, bl, lty = 2)
        #lines(xx, bu, lty = 2)
    }
}
"latex.table" <-
function (x, file = as.character(substitute(x)), rowlabel = file, 
    rowlabel.just = "l", cgroup, n.cgroup, rgroup, n.rgroup = NULL, 
    digits, dec, rdec, cdec, append = FALSE, dcolumn = FALSE, cdot = FALSE, 
    longtable = FALSE, table.env = TRUE, lines.page = 40, caption, caption.lot, 
    label = file, double.slash = FALSE, ...) 
{
    nc <- ncol(x)
    nr <- nrow(x)
    if (missing(caption) & !missing(caption.lot)) 
        warning("caption.lot is ignored unless caption is specified")
    if (!longtable & !table.env & !missing(caption)) 
        stop("you must have table.env=TRUE if caption is given")
    if (!missing(digits)) 
        .Options$digits <- digits
    sl <- if (double.slash) 
        "\\\\"
    else "\\"
    rlj <- if (rowlabel.just == "l") 
        "l"
    else "c"
    if (!missing(dec)) {
        if (length(dec) == 1) 
            x <- round(x, dec)
        else {
            if (!is.matrix(dec) || nrow(dec) != nrow(x) || ncol(dec) != 
                ncol(x)) 
                stop("dimensions of dec do not match those of x")
            for (i in 1:nr) for (j in 1:nc) x[i, j] <- round(x[i, 
                j], dec[i, j])
        }
        cx <- format(x)
    }
    else if (!missing(rdec)) {
        cx <- NULL
        for (i in 1:nr) {
            x[i, ] <- round(x[i, ], rdec[i])
            cx <- rbind(cx, format(x[i, ]))
        }
    }
    else if (!missing(cdec)) {
        cx <- NULL
        for (j in 1:nc) {
            x[, j] <- round(x[, j], cdec[j])
            cx <- cbind(cx, format(x[, j]))
        }
    }
    else cx <- format(x)
    cx[is.na(x)] <- ""
    if (dcolumn) 
        sep <- "."
    else {
        #cx <- translate(cx, " ", "~")
        cx <- matrix(chartr(" ", "~", cx), nrow=nr)
        if (cdot) {
            #cx <- translate(cx, "[.]", "\\\\cdot", multichar = TRUE)
            cx <- gsub("[.]", "\\\\cdot", cx)
            cx <- matrix(paste("$", cx, "$", sep = ""), nrow = nr)
            cx[is.na(x)] <- ""
        }
        sep <- "c"
    }
    if (is.null(n.rgroup) && !missing(rgroup)) 
        n.rgroup <- rep(nr/length(rgroup), length(rgroup))
    if (!is.null(n.rgroup) && sum(n.rgroup) != nr) 
        stop("sum of n.rgroup must equal number of rows in x")
    if (!missing(rgroup) && !is.null(n.rgroup) && (length(rgroup) != 
        length(n.rgroup))) 
        stop("lengths of rgroup and n.rgroup must match")
    fi <- paste(file, ".tex", sep = "")
    rowname <- dimnames(x)[[1]]
    if (length(rowname) == 0) {
        rowname <- NULL
        rowlabel <- NULL
        if (!missing(rgroup)) 
            stop("you must have row dimnames to use rgroup")
    }
    #start new file
    if (!append) 
        cat("", file = fi)
    cat("%", deparse(match.call()), "\n%\n", file = fi, append = TRUE)
    if (dcolumn) 
        cat(sl, "newcolumn{.}{D{.}{", sl, "cdot}{-1}}\n", file = fi, 
            append = TRUE)
    if (!is.null(rowlabel)) 
        form <- paste("|", rowlabel.just, "|", sep = "")
    else form <- ""
    f <- paste("|", sep, sep = "", collapse = "")
    if (missing(cgroup)) 
        ff <- c(rep(f, nc), "|")
    else {
        k <- length(cgroup)
        if (missing(n.cgroup)) 
            n.cgroup <- rep(nc/k, k)
        if (sum(n.cgroup) != nc) 
            stop("sum of n.cgroup must equal number of columns")
        if (length(n.cgroup) != length(cgroup)) 
            stop("cgroup and n.cgroup must have same lengths")
        ff <- NULL
        for (i in 1:k) ff <- c(ff, rep(f, n.cgroup[i]), "|")
    }
    form <- paste(form, paste(ff, collapse = ""), sep = "")
    #if(missing(cgroup)) hline <- "" else hline <- paste(sl,"hline",sep="")
    hline <- ""
    if (!missing(caption)) 
        caption <- paste(sl, "caption", if (missing(caption.lot)) 
            NULL
        else paste("[", caption.lot, "]", sep = ""), "{", caption, 
            if (longtable) 
                NULL
            else paste(sl, "label{", label, "}", sep = ""), "}", 
            sep = "")
    if (!longtable) {
        if (table.env) 
            cat(sl, "begin{table}[hptb]\n", sep = "", file = fi, 
                append = TRUE)
        cat(sl, "begin{center}\n", file = fi, sep = "", append = TRUE)
        cat(sl, "begin{tabular}{", form, "} ", sl, "hline", hline, 
            "\n", sep = "", file = fi, append = TRUE)
    }
    else {
        cat(paste(sl, "setlongtables", sep = ""), paste(sl, "begin{longtable}{", 
            form, "}", sep = ""), sep = "\n", file = fi, append = TRUE)
        if (!missing(caption)) 
            cat(caption, sl, sl, "\n", sep = "", file = fi, append = TRUE)
        cat(sl, "hline", hline, "\n", sep = "", file = fi, append = TRUE)
    }
    if (!missing(cgroup)) {
        cgroup <- paste(sl, "bf ", cgroup, sep = "")
        if (is.null(rowlabel)) {
            labs <- c(paste(sl, "multicolumn{", n.cgroup[1], 
                "}{|c||}{", cgroup[1], "}", sep = "", collapse = ""), 
                if (k > 2) paste(sl, "multicolumn{", n.cgroup[c(-1, 
                  -k)], "}{c||}{", cgroup[c(-1, -k)], "}", sep = "") else NULL, 
                paste(sl, "multicolumn{", n.cgroup[k], "}{c|}{", 
                  cgroup[k], "}", sep = ""))
            g <- paste(sl, "hline", sep = "")
        }
        else {
            rowlabel <- paste(sl, "bf ", rowlabel, sep = "")
            labs <- c(paste(sl, "multicolumn{1}{|", rlj, "||}{", 
                rowlabel, "}", sep = ""), paste(sl, "multicolumn{", 
                n.cgroup[-k], "}{c||}{", cgroup[-k], "}", sep = ""), 
                paste(sl, "multicolumn{", n.cgroup[k], "}{c|}{", 
                  cgroup[k], "}", sep = ""))
            g <- paste(sl, "cline{2-", nc + 1, "}", sep = "")
        }
        cat(labs, file = fi, sep = "&", append = TRUE)
        cat(sl, sl, " ", g, "\n", sep = "", file = fi, append = TRUE)
        if (!is.null(rowlabel)) 
            rowlabel <- ""
    }
    collabel <- dimnames(x)[[2]]
    if (is.null(collabel)) 
        collabel <- as.character(1:nc)
    labs <- c(rowlabel, collabel)
    if (missing(cgroup)) {
        if (is.null(rowlabel)) 
            pre <- c(paste(sl, "multicolumn{1}{|c|}{", sep = ""), 
                rep(paste(sl, "multicolumn{1}{c|}{", sep = ""), 
                  nc - 1))
        else pre <- c(paste(sl, "multicolumn{1}{|", rlj, "||}{", 
            sep = ""), rep(paste(sl, "multicolumn{1}{c|}{", sep = ""), 
            nc))
    }
    else {
        if (is.null(rowlabel)) {
            pre <- NULL
            j <- 0
            for (i in 1:k) {
                if (n.cgroup[i] > 1) {
                  g <- rep(paste(sl, "multicolumn{1}{c|}{", sep = ""), 
                    n.cgroup[i] - 1)
                  if (j == 0) 
                    g[1] <- paste(sl, "multicolumn{1}{|c|}{", 
                      sep = "")
                  pre <- c(pre, g)
                }
                j <- j + n.cgroup[i]
                if (j == 1) 
                  g <- paste(sl, "multicolumn{1}{|c||}{", sep = "")
                else if (j < nc) 
                  g <- paste(sl, "multicolumn{1}{c||}{", sep = "")
                else g <- paste(sl, "multicolumn{1}{c|}{", sep = "")
                pre <- c(pre, g)
            }
        }
        else {
            pre <- paste(sl, "multicolumn{1}{|", rlj, "||}{", 
                sep = "")
            j <- 0
            for (i in 1:k) {
                pre <- c(pre, rep(paste(sl, "multicolumn{1}{c|}{", 
                  sep = ""), n.cgroup[i] - 1))
                j <- j + n.cgroup[i]
                if (j < nc) 
                  g <- paste(sl, "multicolumn{1}{c||}{", sep = "")
                else g <- paste(sl, "multicolumn{1}{c|}{", sep = "")
                pre <- c(pre, g)
            }
        }
    }
    labs <- paste(pre, labs, "}", sep = "")
    cat(labs, file = fi, sep = "&", append = TRUE)
    cat(sl, sl, " ", sl, "hline", hline, "\n", sep = "", file = fi, 
        append = TRUE)
    if (longtable) {
        if (missing(caption)) 
            cat(sl, "endhead\n", sl, "hline", sl, "endfoot\n", 
                sep = "", file = fi, append = TRUE)
        else {
            cat(sl, "endfirsthead\n", sep = "", file = fi, append = TRUE)
            if (!missing(caption)) 
                cat(sl, "caption[]{\\em (continued)} ", sl, sl, 
                  "\n", sep = "", file = fi, append = TRUE)
            cat(sl, "hline", hline, "\n", sep = "", file = fi, 
                append = TRUE)
            cat(labs, file = fi, sep = "&", append = TRUE)
            cat(sl, sl, " ", sl, "hline", hline, "\n", sl, "endhead", 
                sl, "hline", sl, "endfoot\n", sep = "", file = fi, 
                append = TRUE)
            cat(sl, "label{", label, "}\n", sep = "", file = fi, 
                append = TRUE)
        }
    }
    if (is.null(n.rgroup)) 
        rg.end <- 0
    else {
        rg.end <- cumsum(n.rgroup)
        rg.start <- rg.end - n.rgroup + 1
        if (missing(rgroup)) 
            rgroup <- rep("", length(n.rgroup))
        else rgroup <- paste("{", sl, "bf ", rgroup, "}", sep = "")
    }
    linecnt <- 0
    for (i in 1:nr) {
        if (!missing(rgroup)) {
            k <- rg.start == i
            if (any(k)) {
                j <- (1:length(n.rgroup))[k]
                if (longtable && linecnt > 0 && (linecnt + n.rgroup[j] + 
                  (n.rgroup[j] > 1)) > lines.page) {
                  cat(sl, "newpage\n", sep = "", file = fi, append = TRUE)
                  linecnt <- 0
                }
                if (n.rgroup[j] > 1) {
                  cat(rgroup[j], rep("", nc), file = fi, sep = "&", 
                    append = TRUE)
                  linecnt <- linecnt + 1
                  cat(sl, sl, "\n", sep = "", file = fi, append = TRUE)
                }
                l <- rg.start[j]:rg.end[j]
                if (length(l) > 1) 
                  rowname[l] <- paste("~~", rowname[l], sep = "")
                else rowname[l] <- paste("{", sl, "bf ", rowname[l], 
                  "}", sep = "")
            }
        }
        else if (longtable && linecnt > 0 && (linecnt + 1 > lines.page)) {
            cat(sl, "newpage\n", sep = "", file = fi, append = TRUE)
            linecnt <- 0
        }
        cat(c(rowname[i], cx[i, ]), file = fi, sep = "&", append = TRUE)
        linecnt <- linecnt + 1
        if (i < nr && any(rg.end == i)) 
            g <- paste(sl, "hline", sep = "")
        else g <- ""
        cat(sl, sl, " ", g, "\n", sep = "", file = fi, append = TRUE)
    }
    cat(sl, "hline", hline, "\n", sep = "", file = fi, append = TRUE)
    if (longtable) 
        cat(sl, "end{longtable}\n", sep = "", file = fi, append = TRUE)
    else {
        cat(sl, "end{tabular}\n", sep = "", file = fi, append = TRUE)
        if (!missing(caption)) 
            cat(sl, "vspace{3mm}\n", sep = "", file = fi, append = TRUE)
        cat(caption, "\n", file = fi, append = TRUE)
        cat(sl, "end{center}\n", sep = "", file = fi, append = TRUE)
        if (table.env) 
            cat(sl, "end{table}\n", sep = "", file = fi, append = TRUE)
    }
    invisible()
}
"table.rq" <-
function (formula, taus = c(0.25, 0.5, 0.75), method = "br", ...) 
{
    m <- length(taus)
    tab <- NULL
    for (i in 1:m) {
        fit <- summary(rq(formula, taus[i], method = method), ...)
        tab <- rbind(tab, coefficients(fit))
    }
    p <- nrow(tab)/m
    colsfit <-  3
    ctypes <- c("coefs", "lower ci limit", "upper ci limit")
    if(method == "fn") {
	colsfit <- 4
    	ctypes <- c("coefs", "se", "t-stat","P-value")
	}
    a <- array(tab, dim = c(p, m, colsfit))
    vnames <- dimnames(coefficients(fit))[[1]]
    dimnames(a) <- list(vnames, paste("tau=", taus), ctypes)
    a <- aperm(a,c(1,3,2))
    tab <- list(a = a, taus = taus, method = method)
    class(tab) <- "table.rq"
    invisible(tab)
}
