## file modreg/R/ksmooth.R
## copyright (C) 1998 B. D. Ripley
##
ksmooth <-
  function(x, y, kernel=c("box", "normal"), bandwidth=0.5, range.x=range(x),
	   n.points=max(100, length(x)), x.points)
{
    ## box is [-0.5, 0.5]. normal is sd = 1.4826/4
    if(missing(y))
	stop("y must be supplied.\nFor density estimation use density()")
    kernel <- match.arg(kernel)
    krn <- switch(kernel, "box" = 1, "normal" = 2)
    x.points <-
	if(missing(x.points))
	    seq(range.x[1], range.x[2], len=n.points)
	else {
	    n.points <- length(x.points)
	    sort(x.points)
	}
    ord <- order(x)
    z <- .C("BDRksmooth",
	    as.double(x[ord]),
	    as.double(y[ord]),
	    as.integer(length(x)),
	    xp=as.double(x.points),
	    yp=double(n.points),
	    as.integer(n.points),
	    as.integer(krn),
	    as.double(bandwidth),
	    PACKAGE="modreg"
	    )
    list(x=z$xp, y=z$yp)
}

# file modreg/R/loess.R
# copyright (C) 1998 B. D. Ripley
# Copyright (C) 2000 The R Development Core Team
#
loess <-
function(formula, data=NULL, weights, subset, na.action, model = FALSE,
	 span = 0.75, enp.target, degree = 2, parametric = FALSE,
	 drop.square = FALSE, normalize = TRUE,
	 family = c("gaussian", "symmetric"),
	 method = c("loess", "model.frame"),
	 control = loess.control(...), ...)
{
    mt <- terms(formula, data = data)
    mf <- match.call(expand.dots=FALSE)
    mf$model <- mf$span <- mf$enp.target <- mf$degree <-
	mf$parametric <- mf$drop.square <- mf$normalize <- mf$family <-
	    mf$control <- mf$... <- NULL
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, parent.frame())
    if (match.arg(method) == "model.frame") return(mf)
    na.act <- attr(mf, "na.action")
    y <- model.response(mf, "numeric")
    w <- model.weights(mf)
    if(is.null(w)) w <- rep(1, length(y))
    nmx <- as.character(attr(mt, "variables"))[-(1:2)]
    x <- mf[, nmx, drop=FALSE]
    if(any(sapply(x, is.factor))) stop("predictors must all be numeric")
    x <- as.matrix(x)
    D <- ncol(x)
    nmx <- colnames(x)
    names(nmx) <- nmx
    drop.square <- match(nmx, nmx[drop.square], 0) > 0
    parametric <- match(nmx, nmx[parametric], 0) > 0
    if(!match(degree, 0:2, 0)) stop("degree must be 0, 1 or 2")
    iterations <- if(family=="gaussian") 1 else control$iterations
    if(!missing(enp.target))
	if(!missing(span))
	    warning("both span and enp.target specified: span will be used")
	else {				# White book p.321
	    tau <- switch(degree+1, 1, D+1, (D+1)*(D+2)/2) - sum(drop.square)
	    span <- 1.2 * tau/enp.target
	}
    fit <- simpleLoess(y, x, w, span, degree, parametric, drop.square,
		       normalize, control$statistics, control$surface,
		       control$cell, iterations, control$trace.hat)
    fit$call <- match.call()
    fit$terms <- mt
    fit$xnames <- nmx
    fit$x <- x
    fit$y <- y
    fit$weights <- w
    if(model) fit$model <- mf
    if(!is.null(na.act)) fit$na.action <- na.act
    fit
}

loess.control <-
  function(surface = c("interpolate", "direct"),
	   statistics = c("approximate", "exact"),
	   trace.hat = c("exact", "approximate"),
	   cell = 0.2, iterations = 4, ...)
{
    list(surface=match.arg(surface),
	 statistics=match.arg(statistics),
	 trace.hat=match.arg(trace.hat),
	 cell=cell, iterations=iterations)
}


simpleLoess <-
  function(y, x, weights, span = 0.75, degree = 2, parametric = FALSE,
	   drop.square = FALSE, normalize = TRUE,
	   statistics = "approximate", surface = "interpolate",
	   cell = 0.2, iterations = 1, trace.hat = "exact")
{
    ## loess_ translated to R.

    D <- NCOL(x)
    N <- NROW(x)
    if(!N || !D)	stop("invalid `x'")
    if(!length(y))	stop("invalid `y'")
    x <- as.matrix(x)
    max.kd <-  max(N, 200)
    robust <- rep(1, N)
    divisor<- rep(1, D)
    if(normalize && D > 1) {
	trim <- ceiling(0.1 * N)
	divisor <-
	    sqrt(apply(apply(x, 2, sort)[seq(trim+1, N-trim), , drop = FALSE],
		       2, var))
	x <- x/rep(divisor, rep(N, D))
    }
    sum.drop.sqr <- sum(drop.square)
    sum.parametric <- sum(parametric)
    nonparametric <- sum(!parametric)
    order.parametric <- order(parametric)
    x <- x[, order.parametric]
    order.drop.sqr <- (2 - drop.square)[order.parametric]
    if(degree==1 && sum.drop.sqr)
	stop("Specified the square of a factor predictor to be dropped when degree = 1")
    if(D == 1 && sum.drop.sqr)
	stop("Specified the square of a predictor to be dropped with only one numeric predictor")
    if(sum.parametric == D) stop("Specified parametric for all predictors")

    if(iterations)
    for(j in 1:iterations) {
	robust <- weights * robust
	if(j > 1) statistics <- "none"
	if(surface == "interpolate" && statistics == "approximate")
	    statistics <- if(trace.hat == "approximate") "2.approx"
	    else if(trace.hat == "exact") "1.approx"
	surf.stat <- paste(surface, statistics, sep="/")
	z <- .C("loess_raw",
		as.double(y),
		as.double(x),
		as.double(weights),
		as.double(robust),
		as.integer(D),
		as.integer(N),
		as.double(span),
		as.integer(degree),
		as.integer(nonparametric),
		as.integer(order.drop.sqr),
		as.integer(sum.drop.sqr),
		as.double(span*cell),
		as.character(surf.stat),
		fitted.values = double(N),
		parameter = integer(7),
		a = integer(max.kd),
		xi = double(max.kd),
		vert = double(2*D),
		vval = double((D+1)*max.kd),
		diagonal = double(N),
		trL = double(1),
		delta1 = double(1),
		delta2 = double(1),
		as.integer(surf.stat == "interpolate/exact"),
		PACKAGE="modreg")
	if(j==1) {
	    trace.hat.out <- z$trL
	    one.delta <- z$delta1
	    two.delta <- z$delta2
	}
	fitted.residuals <- y - z$fitted.values
	if(j < iterations)
	    robust <- .Fortran("lowesw",
			       as.double(fitted.residuals),
			       as.integer(N),
			       robust = double(N),
			       double(N),
			       PACKAGE="modreg")$robust
    }
    if(surface == "interpolate")
    {
	pars <- z$parameter
	names(pars) <- c("d", "n", "vc", "nc", "nv", "liv", "lv")
	enough <- (D + 1) * pars["nv"]
	fit.kd <- list(parameter=pars, a=z$a[1:pars[4]], xi=z$xi[1:pars[4]],
		       vert=z$vert, vval=z$vval[1:enough])
    }
    if(iterations > 1) {
	pseudovalues <- .Fortran("lowesp",
				 as.integer(N),
				 as.double(y),
				 as.double(z$fitted.values),
				 as.double(weights),
				 as.double(robust),
				 double(N),
				 pseudovalues = double(N),
				 PACKAGE="modreg")$pseudovalues
	zz <- .C("loess_raw",
		as.double(pseudovalues),
		as.double(x),
		as.double(weights),
		as.double(weights),
		as.integer(D),
		as.integer(N),
		as.double(span),
		as.integer(degree),
		as.integer(nonparametric),
		as.integer(order.drop.sqr),
		as.integer(sum.drop.sqr),
		as.integer(span*cell),
		as.character(surf.stat),
		temp = double(N),
		parameter = integer(7),
		a = integer(max.kd),
		xi = double(max.kd),
		vert = double(2*D),
		vval = double((D+1)*max.kd),
		diagonal = double(N),
		trL = double(1),
		delta1 = double(1),
		delta2 = double(1),
		as.integer(0),
		PACKAGE="modreg")
	pseudo.resid <- pseudovalues - zz$temp
    }
    sum.squares <- if(iterations <= 1) sum(weights * fitted.residuals^2)
    else sum(weights * pseudo.resid^2)
    enp <- one.delta + 2*trace.hat.out - N
    s <- sqrt(sum.squares/one.delta)
    pars <- list(robust=robust, span=span, degree=degree, normalize=normalize,
		 parametric=parametric, drop.square=drop.square,
		 surface=surface, cell=cell, family=
		 if(iterations <= 1) "gaussian" else "symmetric",
		 iterations=iterations)
    fit <- list(n=N, fitted=z$fitted.values, residuals=fitted.residuals,
		enp=enp, s=s, one.delta=one.delta, two.delta=two.delta,
		trace.hat=trace.hat.out, divisor=divisor)
    fit$pars <- pars
    if(surface == "interpolate") fit$kd <- fit.kd
    class(fit) <- "loess"
    fit
}

predict.loess <- function(object, newdata = NULL, se = FALSE, ...)
{
    if(!inherits(object, "loess"))
	stop("First argument must be a loess object")
    if(is.null(newdata) & (se == FALSE)) return(fitted(object))

    if(is.null(newdata)) newx <- object$x
    else {
	vars <- as.character(attr(delete.response(terms(object)),
				  "variables"))[-1]
	newx <- if(length(vars) > 1 || NCOL(newdata) > 1) {
	    if(any(!match(vars, colnames(newdata), FALSE)))
		stop("newdata does not contain the variables needed")
	    as.matrix(newdata[, vars, drop=FALSE])
	} else as.matrix(newdata)
    }
    res <- predLoess(object$y, object$x, newx, object$s, object$weights,
		     object$pars$robust, object$pars$span, object$pars$degree,
		     object$pars$normalize, object$pars$parametric,
		     object$pars$drop.square, object$pars$surface,
		     object$pars$cell, object$pars$family,
		     object$kd, object$divisor, se=se)
    if(se)
	res$df <- object$one.delta^2/object$two.delta
    res
}

predLoess <-
  function(y, x, newx, s, weights, robust, span, degree,
	   normalize, parametric, drop.square, surface, cell, family,
	   kd, divisor, se=FALSE)
{
    ## translation of pred_
    D <- NCOL(x); N <- NROW(x); M <- NROW(newx)
    x <- as.matrix(x); newx <- as.matrix(newx)
    newx <- newx/rep(divisor, rep(M, D))
    x <- x/rep(divisor, rep(N, D))
    sum.drop.sqr <- sum(drop.square)
    sum.parametric <- sum(parametric)
    nonparametric <- sum(!parametric)
    order.parametric <- order(parametric)
    x <- x[, order.parametric, drop=FALSE]
    x.evaluate <- newx[, order.parametric, drop=FALSE]
    order.drop.sqr <- (2 - drop.square)[order.parametric]
    if(surface == "direct") {
	if(se) {
	    z <- .C("loess_dfitse",
		    as.double(y),
		    as.double(x),
		    as.double(x.evaluate),
		    as.double(weights*robust),
		    as.double(robust),
		    as.integer(family =="gaussian"),
		    as.double(span),
		    as.integer(degree),
		    as.integer(nonparametric),
		    as.integer(order.drop.sqr),
		    as.integer(sum.drop.sqr),
		    as.integer(D),
		    as.integer(N),
		    as.integer(M),
		    fit = double(M),
		    L = double(N*M),
		    PACKAGE="modreg")[c("fit", "L")]
	    fit <- z$fit
	    se.fit <- (matrix(z$L^2, M, N)/rep(weights, rep(M,N))) %*% rep(1,N)
	    se.fit <- drop(s * sqrt(se.fit))
	} else {
	    fit <- .C("loess_dfit",
		      as.double(y),
		      as.double(x),
		      as.double(x.evaluate),
		      as.double(weights*robust),
		      as.double(span),
		      as.integer(degree),
		      as.integer(nonparametric),
		      as.integer(order.drop.sqr),
		      as.integer(sum.drop.sqr),
		      as.integer(D),
		      as.integer(N),
		      as.integer(M),
		      fit = double(M),
		      PACKAGE="modreg")$fit
	}
    }
    else { ## interpolate
	## need to eliminate points outside original range - not in pred_
	inside <- matrix(FALSE, M, ncol = D)
	ranges <- apply(x, 2, range)
	inside <- (x.evaluate <= rep(ranges[2,], rep(M, D))) &
	(x.evaluate >= rep(ranges[1,], rep(M, D)))
	inside <- inside %*% rep(1, D) == D
	M1 <- sum(inside)
	fit <- rep(NA, M)
	if(any(inside))
	    fit[inside] <- .C("loess_ifit",
			      as.integer(kd$parameter),
			      as.integer(kd$a), as.double(kd$xi),
			      as.double(kd$vert), as.double(kd$vval),
			      as.integer(M1),
			      as.double(x.evaluate[inside, ]),
			      fit = double(M1),
			      PACKAGE="modreg")$fit
	if(se) {
	    se.fit <- rep(NA, M)
	    if(any(inside)) {
		L <- .C("loess_ise",
			as.double(y),
			as.double(x),
			as.double(x.evaluate[inside, ]),
			as.double(weights),
			as.double(span),
			as.integer(degree),
			as.integer(nonparametric),
			as.integer(order.drop.sqr),
			as.integer(sum.drop.sqr),
			as.double(span*cell),
			as.integer(D),
			as.integer(N),
			as.integer(M1),
			double(M1),
			L = double(N*M1),
			PACKAGE="modreg"
			)$L
		tmp <- (matrix(L^2, M1, N)/rep(weights, rep(M1,N))) %*% rep(1,N)
		se.fit[inside] <- drop(s * sqrt(tmp))
	    }
	}
    }
    if(se) list(fit = fit, se.fit = drop(se.fit), residual.scale = s) else fit
}

pointwise <- function(results, coverage)
{
    fit <- results$fit
    lim <- qt((1 - coverage)/2, results$df, lower = FALSE) * results$se.fit
    list(fit = fit, lower = fit - lim, upper = fit + lim)
}

print.loess <- function(x, digits=max(3, getOption("digits")-3), ...)
{
    if(!is.null(cl <- x$call)) {
	cat("Call:\n")
	dput(cl)
    }
    cat("\nNumber of Observations:", x$n, "\n")
    cat("Equivalent Number of Parameters:", format(round(x$enp, 2)), "\n")
    cat("Residual",
	if(x$pars$family == "gaussian")"Standard Error:" else "Scale Estimate:",
	format(signif(x$s, digits)), "\n")
    invisible(x)
}

summary.loess <- function(object, ...)
{
    class(object) <- "summary.loess"
    object
}

print.summary.loess <- function(x, digits=max(3, getOption("digits")-3), ...)
{
    if(!is.null(cl <- x$call)) {
	cat("Call:\n")
	dput(cl)
    }
    cat("\nNumber of Observations:", x$n, "\n")
    cat("Equivalent Number of Parameters:", format(round(x$enp, 2)), "\n")
    if(x$pars$family == "gaussian")
	cat("Residual Standard Error:", format(signif(x$s, digits)), "\n")
    else cat("Residual Scale Estimate:", format(signif(x$s, digits)), "\n")
    cat("Trace of smoother matrix:", format(round(x$trace.hat, 2)), "\n")
    cat("\nControl settings:\n")
    cat("  normalize: ", x$pars$normalize, "\n")
    cat("  span	    : ", format(x$pars$span), "\n")
    cat("  degree   : ", x$pars$degree, "\n")
    cat("  family   : ", x$pars$family)
    if(x$pars$family != "gaussian")
	cat("	    iterations =", x$pars$iterations)
    cat("\n  surface  : ", x$pars$surface)
    if(x$pars$surface == "interpolate")
	cat("	  cell =", format(x$pars$cell))
    cat("\n")
    invisible(x)
}

scatter.smooth <-
    function(x, y, span = 2/3, degree = 1,
	     family = c("symmetric", "gaussian"),
	     xlab = deparse(substitute(x)), ylab = deparse(substitute(y)),
	     ylim = range(y, prediction$y), evaluation = 50, ...)
{
    if(inherits(x, "formula")) {
	if(length(x) < 3) stop("need response in formula")
	thiscall <- match.call()
	thiscall$x <- x[[3]]
	thiscall$y <- x[[2]]
	return(invisible(eval(thiscall, sys.parent())))
    }
    prediction <- loess.smooth(x, y, span, degree, family, evaluation)
    plot(x, y, ylim = ylim, xlab = xlab, ylab = ylab, ...)
    lines(prediction)
    invisible()
}

loess.smooth <-
  function(x, y, span = 2/3, degree = 1, family = c("symmetric", "gaussian"),
	   evaluation = 50, ...)
{
    notna <- x[!(is.na(x) | is.na(y))]
    new.x <- seq(min(notna), max(notna), length = evaluation)

    control <- loess.control(...)
    ##	x <- matrix(x, ncol = 1)
    ##	n <- length(y)
    robust <- w <- rep(1, length(y))
    family <- match.arg(family)
    iterations <- if(family == "gaussian") 1 else control$iterations
    fit <- simpleLoess(y, x, w, span, degree, FALSE, FALSE,
		       normalize=FALSE, "none", "interpolate",
		       control$cell, iterations, control$trace.hat)
    kd <- fit$kd
    z <- .C("loess_ifit",
	    as.integer(kd$parameter),
	    as.integer(kd$a), as.double(kd$xi),
	    as.double(kd$vert), as.double(kd$vval),
	    as.integer(evaluation),
	    as.double(new.x),
	    fit = double(evaluation),
	    PACKAGE="modreg")$fit
    list(x = new.x, y = z)
}

## panel.smooth is currently defined in ../../base/R/coplot.R :
## panel.smooth <-
##   function(x, y, span = 2/3, degree = 1, family = c("symmetric", "gaussian"),
##	   zero.line = FALSE, evaluation = 50, ...)
## {
##   points(x, y, ...)
##   lines(loess.smooth(x, y, span, degree, family, evaluation), ...)
##   if(zero.line) abline(h = 0, ...)
## }

anova.loess <- function(object, ...)
{
    objects <- list(object, ...)
    responses <- as.character(lapply(objects,
				     function(x) as.character(x$terms[[2]])))
    sameresp <- responses == responses[1]
    ## calculate the number of models
    if (!all(sameresp)) {
	objects <- objects[sameresp]
	warning(paste("Models with response", deparse(responses[!sameresp]),
		      "removed because response differs from", "model 1"))
    }
    nmodels <- length(objects)
    if(nmodels <= 1) stop("no models to compare")
    models <- as.character(lapply(objects, function(x) x$call))
    descr <- paste("Model ", format(1:nmodels), ": ", models,
		   sep = "", collapse = "\n")
    ## extract statistics
    delta1 <- sapply(objects, function(x) x$one.delta)
    delta2 <- sapply(objects, function(x) x$two.delta)
    s <- sapply(objects, function(x) x$s)
    enp <- sapply(objects, function(x) x$enp)
    rss <- s^2*delta1
    max.enp <- order(enp)[nmodels]
    d1diff <- abs(diff(delta1))
    dfnum <- c(d1diff^2/abs(diff(delta2)))
    dfden <- (delta1^2/delta2)[max.enp]
    Fvalue <- c(NA, (abs(diff(rss))/d1diff)/s[max.enp]^2)
    pr <- 1 - pf(Fvalue, dfnum, dfden)
    ans <- data.frame(ENP = round(enp,2), RSS = rss, "F-value" = Fvalue,
		      "Pr(>F)" = pr, check.names = FALSE)
    attr(ans, "heading") <-
	paste(descr, "\n\n", "Analysis of Variance:   denominator df ",
	      format(round(dfden,2)), "\n", sep = "")
    class(ans) <- c("anova", "data.frame")
    ans
}
# file modreg/R/ppr.R
# copyright (C) 1998 B. D. Ripley
# Copyright (C) 2000 The R Development Core Team
#
ppr <- function(x, ...) UseMethod("ppr")

ppr.formula <-
function(formula, data=sys.parent(), weights, subset,
	 na.action, contrasts=NULL, ...)
{
    call <- match.call()
    m <- match.call(expand = FALSE)
    m$contrasts <- m$... <- NULL
    m[[1]] <- as.name("model.frame")
    m <- eval(m, parent.frame())
    na.act <- attr(m, "na.action")
    Terms <- attr(m, "terms")
    attr(Terms, "intercept") <- 0
    X <- model.matrix(Terms, m, contrasts)
    Y <- model.extract(m, response)
    w <- model.extract(m, weights)
    if(length(w) == 0) w <- rep(1, nrow(X))
    fit <- ppr.default(X, Y, w, ...)
    if(!is.null(na.act)) fit$na.action <- na.act
    fit$terms <- Terms
    fit$call <- call
    structure(fit, class=c("ppr.form", "ppr"))
}

ppr.default <-
function(x, y, weights=rep(1,n), ww=rep(1,q), nterms, max.terms=nterms,
	 optlevel=2, sm.method=c("supsmu", "spline", "gcvspline"),
	 bass=0, span=0, df=5, gcvpen=1, ...)
{
    call <- match.call()
    sm.method <- match.arg(sm.method)
    ism <- switch(sm.method, supsmu=0, spline=1, gcvspline=2)
    if(missing(nterms)) stop("nterms is missing with no default")
    mu <- nterms; ml <- max.terms
    x <- as.matrix(x)
    y <- as.matrix(y)
    n <- nrow(x)
    if(nrow(y) != n) stop("mismatched x and y")
    p <- ncol(x)
    q <- ncol(y)
    if(!is.null(dimnames(x))) xnames <- dimnames(x)[[2]]
    else xnames <- paste("X", 1:p, sep="")
    if(!is.null(dimnames(y))) ynames <- dimnames(y)[[2]]
    else ynames <- paste("Y", 1:q, sep="")
    msmod <- ml*(p+q+2*n)+q+7+ml+1	# for asr
    nsp <- n*(q+15)+q+3*p
    ndp <- p*(p+1)/2+6*p
    .Fortran("bdrsetppr",
	     as.double(span), as.double(bass), as.integer(optlevel),
	     as.integer(ism), as.double(df), as.double(gcvpen),
	     PACKAGE="modreg"
	     )
    Z <- .Fortran("bdrsmart",
		  as.integer(ml), as.integer(mu),
		  as.integer(p), as.integer(q), as.integer(n),
		  as.double(weights),
		  as.double(t(x)),
		  as.double(t(y)),
		  as.double(ww),
		  smod=double(msmod), as.integer(msmod),
		  double(nsp), as.integer(nsp),
		  double(ndp), as.integer(ndp),
		  edf=double(ml),
		  PACKAGE="modreg"
		  )
    smod <- Z$smod
    ys <- smod[q+6]
    tnames <- paste("term", 1:mu)
    alpha <- matrix(smod[q+6 + 1:(p*mu)],p, mu,
		    dimnames=list(xnames, tnames))
    beta <- matrix(smod[q+6+p*ml + 1:(q*mu)], q, mu,
		   dimnames=list(ynames, tnames))
    fitted <- drop(matrix(.Fortran("bdrpred",
				   as.integer(nrow(x)),
				   as.double(x),
				   as.double(smod),
				   y = double(nrow(x)*q),
				   double(2*smod[4]),
				   PACKAGE="modreg")$y,
			  ncol=q, dimnames=dimnames(y)))
    jt <- q + 7 + ml*(p+q+2*n)
    gof <- smod[jt] * n * ys^2
    gofn <- smod[jt+1:ml] * n * ys^2
    ## retain only terms for the size of model finally fitted
    jf <- q+6+ml*(p+q)
    smod <- smod[c(1:(q+6+p*mu), q+6+p*ml + 1:(q*mu),
		   jf + 1:(mu*n), jf+ml*n + 1:(mu*n))]
    smod[1] <- mu
    structure(list(call=call, mu=mu, ml=ml, p=p, q=q,
		   gof=gof, gofn=gofn,
		   df=df, edf=Z$edf[1:mu],
		   xnames=xnames, ynames=ynames,
		   alpha=drop(alpha), beta=ys*drop(beta),
		   yb=smod[5+1:q], ys=ys,
		   fitted.values=fitted, residuals=drop(y-fitted),
		   smod=smod),
	      class="ppr")
}

print.ppr <- function(x, ...)
{
    if(!is.null(cl <- x$call)) {
	cat("Call:\n")
	dput(cl)
    }
    mu <- x$mu; ml <- x$ml
    cat("\nGoodness of fit:\n")
    gof <- x$gofn; names(gof) <- paste(1:ml, "terms")
    print(format(gof[mu:ml], ...), quote=FALSE)
    invisible(x)
}

summary.ppr <- function(object, ...)
{
    class(object) <- "summary.ppr"
    object
}

print.summary.ppr <- function(x, ...)
{
    print.ppr(x, ...)
    mu <- x$mu
    cat("\nProjection direction vectors:\n")
    print(format(x$alpha, ...), quote=FALSE)
    cat("\nCoefficients of ridge terms:\n")
    print(format(x$beta, ...), quote=FALSE)
    if(any(x$edf >0)) {
	cat("\nEquivalent df for ridge terms:\n")
	edf <- x$edf; names(edf) <- paste("term", 1:mu)
	print(round(edf,2), ...)
    }
    invisible(x)
}

plot.ppr <- function(x, ask, type="o", ...)
{
    ppr.funs <- function(obj)
    {
	## cols for each term
	p <- obj$p; q <- obj$q
	sm <- obj$smod
	n <- sm[4]; mu <- sm[5]; m <- sm[1]
	jf <- q+6+m*(p+q)
	jt <- jf+m*n
	f <- matrix(sm[jf+1:(mu*n)],n, mu)
	t <- matrix(sm[jt+1:(mu*n)],n, mu)
	list(x=t, y=f)
    }
    obj <- ppr.funs(x)
    if(!missing(ask)) {
	oldpar <- par()
	on.exit(par(oldpar))
	par(ask = ask)
    }
    for(i in 1:x$mu) {
	ord <- order(obj$x[ ,i])
	plot(obj$x[ord, i], obj$y[ord, i], type = type,
	     xlab = paste("term", i), ylab = "", ...)
    }
}

predict.ppr <- function(object, newdata, ...)
{
    if(missing(newdata)) return(fitted(object))
    if(!is.null(object$terms)) {
        newdata <- as.data.frame(newdata)
        rn <- row.names(newdata)
# work hard to predict NA for rows with missing data
        Terms <- delete.response(object$terms)
        m <- model.frame(Terms, newdata, na.action = na.omit)
        keep <- match(row.names(m), rn)
        x <- model.matrix(Terms, m, contrasts = object$contrasts)
    } else {
        x <- as.matrix(newdata)
        keep <- 1:nrow(x)
        rn <- dimnames(x)[[1]]
    }
    if(ncol(x) != object$p) stop("wrong number of columns in x")
    res <- matrix(NA, length(keep), object$q,
                  dimnames = list(rn, object$ynames))
    res[keep, ] <- matrix(.Fortran("bdrpred",
                                   as.integer(nrow(x)),
                                   as.double(x),
                                   as.double(object$smod),
                                   y = double(nrow(x)*object$q),
                                   double(2*object$smod[4]),
                                   PACKAGE="modreg"
                                   )$y, ncol=object$q)
    drop(res)
}
#### copyright (C) 1998 B. D. Ripley
#### Copyright (C) 2000-2001 The R Development Core Team

smooth.spline <-
  function(x, y = NULL, w = NULL, df = 5, spar = NULL, cv = FALSE,
	   all.knots = FALSE, df.offset = 0, penalty = 1, control.spar = list())
{
    sknotl <- function(x)
    {
        ## if (all.knots == FALSE)
	## return reasonable sized knot sequence for INcreasing x[]:
	n.kn <- function(n) {
	    ## Number of inner knots
	    if(n < 50) n
	    else trunc({
		a1 <- log( 50, 2)
		a2 <- log(100, 2)
		a3 <- log(140, 2)
		a4 <- log(200, 2)
		if	(n < 200) 2^(a1+(a2-a1)*(n-50)/150)
		else if (n < 800) 2^(a2+(a3-a2)*(n-200)/600)
		else if (n < 3200)2^(a3+(a4-a3)*(n-800)/2400)
		else  200 + (n-3200)^0.2
	    })
	}
	nk <- n.kn( n <- length(x) )
	c(rep(x[1], 3), x[seq(1,n, len= nk)], rep(x[n], 3))
    }
    contr.sp <- list(low = -1.5,## low = 0.      was default till R 1.3.x
                     high = 1.5,
                     tol = 1e-4,## tol = 0.001   was default till R 1.3.x
                     eps = 2e-8,## eps = 0.00244 was default till R 1.3.x
                     maxit = 500, trace = getOption("verbose"))
    contr.sp[(namc <- names(control.spar))] <- control.spar
    if(!all(sapply(contr.sp[1:4],is.double)) ||
       contr.sp$tol < 0 || contr.sp$eps <= 0 || contr.sp$maxit <= 0)
        stop("invalid `control.spar'")

    xy <- xy.coords(x, y)
    y <- xy$y
    x <- xy$x
    n <- length(x)
    w <-
	if(is.null(w)) rep(1, n)
	else {
	    if(n != length(w)) stop("lengths of x and w must match")
	    if(any(w < 0)) stop("all weights should be non-negative")
	    if(all(w == 0)) stop("some weights should be positive")
	    (w * sum(w > 0))/sum(w)
	}# now sum(w) == #{obs. with weight > 0} == sum(w > 0)

    ## Replace y[] for same x[] (to 6 digits precision) by their mean :
    x <- signif(x, 6)
    ux <- unique(sort(x))
    ox <- match(x, ux)
    tmp <- matrix(unlist(tapply(seq(along=y), ox,
				function(i,y,w)
				c(sum(w[i]), sum(w[i]*y[i]),sum(w[i]*y[i]^2)),
				y = y, w = w)),
		  ncol = 3, byrow=TRUE)
    wbar <- tmp[, 1]
    ybar <- tmp[, 2]/ifelse(wbar > 0, wbar, 1)
    yssw <- sum(tmp[, 3] - wbar*ybar^2)# will be added to RSS for GCV
    nx <- length(ux)
    if(nx <= 3) stop("need at least for unique `x' values")
    if(cv && nx < n)
        warning("crossvalidation with non-unique `x' seems doubtful")
    r.ux <- ux[nx] - ux[1]
    xbar <- (ux - ux[1])/r.ux # scaled to [0,1]
    if(all.knots) {
	knot <- c(rep(xbar[1], 3), xbar, rep(xbar[nx], 3))
	nk <- nx + 2
    } else {
	knot <- sknotl(xbar)
	nk <- length(knot) - 4
    }

    ## ispar != 1 : compute spar (later)
    ispar <-
        if(is.null(spar) || missing(spar)) { ## || spar == 0
            if(contr.sp$trace) -1 else 0
        } else 1
    spar <- if(ispar == 1) as.double(spar) else double(1)
    ## was <- if(missing(spar)) 0 else if(spar < 1.01e-15) 0 else  1
    ## icrit {../src/sslvrg.f}:
    ##		(0 = no crit,  1 = GCV ,  2 = ord.CV , 3 = df-matching)
    icrit <- if(cv) 2 else  1
    dofoff <- df.offset
    if(!missing(df)) {
	if(df > 1 && df <= nx) {
	    icrit <- 3
	    dofoff <- df
	} else warning(paste("you must supply 1 < df <= n,  n = #{unique x} =",
                             nx))
    }
    iparms <- as.integer(c(icrit,ispar, contr.sp$maxit))
    names(iparms) <- c("icrit", "ispar", "iter")

    fit <- .Fortran("qsbart",		# code in ../src/qsbart.f
		    as.double(penalty),
		    as.double(dofoff),
		    x = as.double(xbar),
		    y = as.double(ybar),
		    w = as.double(wbar),
		    ssw = as.double(yssw),
		    as.integer(nx),
		    as.double(knot),
		    as.integer(nk),
		    coef = double(nk),
		    ty = double(nx),
		    lev = double(nx),
		    crit = double(1),
		    iparms = iparms,
		    spar = spar,
		    parms = unlist(contr.sp[1:4]),
		    isetup = as.integer(0),
		    scrtch = double((17 + nk) * nk),
		    ld4  = as.integer(4),
		    ldnk = as.integer(1),
		    ier = integer(1),
		    DUP = FALSE, PACKAGE="modreg"
		    )[c("coef","ty","lev","spar","parms","crit","iparms","ier")]

    lev <- fit$lev
    df <- sum(lev)
    if(is.na(df))
	stop("NA lev[]; probably smoothing parameter `spar' way too large!")
    if(fit$ier > 0 ) {
        sml <- fit$spar < 0.5
	wtxt <- paste("smoothing parameter value too",
                      if(sml) "small" else "large")
        if(sml) {
            ## used to give warning too and mean() as below, but that's rubbish
            stop(wtxt)
        } else {
            fit$ty <- rep(mean(y), nx) ## would be df = 1
            df <- 1
            warning(paste(wtxt,"setting df = 1  __use with care!__", sep="\n"))
        }
    }
    cv.crit <-
	if(cv) {
	    ww <- wbar
	    ww[!(ww > 0)] <- 1
	    weighted.mean(((y - fit$ty[ox])/(1 - (lev[ox] * w)/ww[ox]))^2, w)
	} else weighted.mean((y - fit$ty[ox])^2, w)/
	    (1 - (df.offset + penalty * df)/n)^2
    pen.crit <- sum(wbar * (ybar - fit$ty) * ybar)
    fit.object <- list(knot = knot, nk = nk, min = ux[1], range = r.ux,
		       coef = fit$coef)
    class(fit.object) <- "smooth.spline.fit"
    ## parms :  c(low = , high = , tol = , eps = )
    object <- list(x = ux, y = fit$ty, w = wbar, yin = ybar,
		   lev = lev, cv.crit = cv.crit, pen.crit = pen.crit,
                   crit = fit$crit,
                   df = df, spar = fit$spar,
                   lambda = unname(fit$parms["low"]),
                   iparms = fit$iparms, # c(icrit= , ispar= , iter= )
                   fit = fit.object, call = match.call())
    class(object) <- "smooth.spline"
    object
}

print.smooth.spline <- function(x, digits = getOption("digits"), ...)
{
    if(!is.null(cl <- x$call)) {
	cat("Call:\n")
	dput(cl)
    }
    ip <- x$iparms
    cv <- cl$cv
    if(is.null(cv)) cv <- FALSE else if(is.name(cv)) cv <- eval(cv)
    cat("\nSmoothing Parameter  spar=", format(x$spar, digits=digits),
        " lambda=",format(x$lambda, digits=digits),
        if(ip["ispar"] != 1) paste("(",ip["iter"]," iterations)", sep=""),
        "\n")
    cat("Equivalent Degrees of Freedom (Df):", format(x$df,digits=digits),"\n")
    cat("Penalized Criterion:", format(x$pen.crit, digits=digits), "\n")
    cat(if(cv) "PRESS:" else "GCV:", format(x$cv.crit, digits=digits), "\n")
    invisible(x)
}

predict.smooth.spline <- function(object, x, deriv = 0, ...)
{
    if(missing(x) && deriv == 0)
	return(object[c("x", "y")])
    fit <- object$fit
    if(is.null(fit)) stop("not a valid smooth.spline object")
    else predict(fit, x, deriv, ...)
}

predict.smooth.spline.fit <- function(object, x, deriv = 0, ...)
{
    if(missing(x))
	x <- seq(from = object$min, to = object$min + object$range,
		 length = length(object$coef) - 4)
    xs <- (x - object$min)/object$range # x scaled to [0,1]
    extrap.left <- xs < 0
    extrap.right <- xs > 1
    interp <- !(extrap <- extrap.left | extrap.right)
    n <- sum(interp) # number of xs in [0,1]
    y <- xs
    if(any(interp))
	y[interp] <- .Fortran("bvalus",
			      n	  = as.integer(n),
			      knot= as.double(object$knot),
			      coef= as.double(object$coef),
			      nk  = as.integer(object$nk),
			      x	  = as.double(xs[interp]),
			      s	  = double(n),
			      order= as.integer(deriv),
			      DUP = FALSE, PACKAGE="modreg")$s
    if(any(extrap)) {
	xrange <- c(object$min, object$min + object$range)
	if(deriv == 0) {
	    end.object <- Recall(object, xrange)$y
	    end.slopes <- Recall(object, xrange, 1)$y * object$range
	    if(any(extrap.left))
		y[extrap.left] <- end.object[1] +
		    end.slopes[1] * (xs[extrap.left] - 0)
	    if(any(extrap.right))
		y[extrap.right] <- end.object[2] +
		    end.slopes[2] * (xs[extrap.right] - 1)
	} else if(deriv == 1) {
	    end.slopes <- Recall(object, xrange, 1)$y * object$range
	    y[extrap.left] <- end.slopes[1]
	    y[extrap.right] <- end.slopes[2]
	}
	else y[extrap] <- 0
    }
    if(deriv > 0)
	y <- y/(object$range^deriv)
    list(x = x, y = y)
}

supsmu <-
  function(x, y, wt = rep(1, n), span = "cv", periodic = FALSE, bass = 0)
{
    if(span == "cv") span <- 0
    n <- length(y)
    if(!n || !is.numeric(y)) stop("`y' must be numeric vector")
    if(length(x) != n) stop("number of observations in x and y must match.")
    if(length(wt) != n)
	stop("number of weights must match number of observations.")
    if(span < 0 || span > 1) stop("span must be between 0 and 1.")
    if(periodic) {
	iper <- 2
	xrange <- range(x)
	if(xrange[1] < 0 || xrange[2] > 1)
	    stop("x must be between 0 and 1 for periodic smooth")
    } else iper <- 1
    okay <- is.finite(x + y + wt)
    ord <- order(x[okay], y[okay])
    ord <- cumsum(!okay)[okay][ord] + ord
    xo <- x[ord]
    leno <- length(ord)
    if(diff <- n - leno)
	warning(paste(diff, "observation(s) with NAs, NaNs and/or Infs deleted"))
    .Fortran("bdrsetsmu", PACKAGE = "modreg")
    smo <- .Fortran("bdrsupsmu",
		    as.integer(leno),
		    as.double(xo),
		    as.double(y[ord]),
		    as.double(wt[ord]),
		    as.integer(iper),
		    as.double(span),
		    as.double(bass),
		    smo=double(leno),
		    double(n*7), double(1),
		    PACKAGE="modreg")$smo
    ## eliminate duplicate xsort values and corresponding smoothed values
    dupx <- duplicated(xo)
    list(x = xo[!dupx], y = smo[!dupx])
}
# file modreg/R/zzz.R
# copyright (C) 1998 B. D. Ripley
#
.First.lib <- function(lib, pkg) library.dynam("modreg", pkg, lib)
