# 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)
  if(missing(x.points))
    x.points <- seq(range.x[1], range.x[2], len=n.points)
  else {
    n.points <- length(x.points)
    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
#
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, sys.frame(sys.parent()))
  if (match.arg(method) == "model.frame") return(mf)
  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=F]
  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
  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);
  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")

  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
      z <- .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 - z$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 <- .Alias(object$x)
  else {
    vars <- as.character(attr(delete.response(terms(object)), "variables"))[-1]
    if(length(vars) > 1 || NCOL(newdata) > 1) {
      if(any(!match(vars, colnames(newdata), F)))
        stop("newdata does not contain the variables needed")
      newx <- as.matrix(newdata[, vars, drop=F])
    } else newx <- 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=F)
{
## 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),
              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),
                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(F, 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 - (1 - coverage)/2, results$df) * results$se.fit
  list(fit = fit, lower = fit - lim, upper = fit + lim)
}

print.loess <- function(x, digits=max(3, .Options$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")
}

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

print.summary.loess <- function(x, digits=max(3, .Options$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, "\n") else cat("\n")
  cat("  surface  : ", x$pars$surface)
  if(x$pars$surface == "interpolate")
    cat("     cell =", format(x$pars$cell), "\n") else cat("\n")
}

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=F, "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 <-
#   function(x, y, span = 2/3, degree = 1, family = c("symmetric", "gaussian"),
#         zero.line = F, 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
#
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 = F)
  m$contrasts <- m$... <- NULL
  m[[1]] <- as.name("model.frame")
  m <- eval(m, sys.parent())
  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, ...)
  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:p, 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, ml=max.terms, 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$call$nterms; ml <- x$ml
  cat("\nGoodness of fit:\n")
  gof <- x$gofn; names(gof) <- paste(1:ml, "terms")
  print(format(gof[mu:ml], ...), quote=F)
  invisible(x)
}

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

print.summary.ppr <- function(x, ...)
{
  print.ppr(x, ...)
  mu <- x$call$nterms
  cat("\nProjection direction vectors:\n")
  print(format(x$alpha, ...), quote=F)
  cat("\nCoefficients of ridge terms:\n")
  print(format(x$beta, ...), quote=F)
  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(fit, 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(fit)
  if(!missing(ask)) {
    oldpar <- par()
    on.exit(par(oldpar))
    par(ask = ask)
  }
  for(i in 1:fit$call$nterms) {
    ord <- order(obj$x[ ,i])
    plot(obj$x[ord, i], obj$y[ord, i], type = type,
	 xlab = paste("term", i), ylab = "", ...)
  }
}

predict.ppr <- function(obj, newdata, ...)
{
  if(missing(newdata)) return(obj$fitted)
  if(!is.null(obj$terms))
    x <- model.matrix(delete.response(obj$terms), newdata)
  else x <- as.matrix(newdata)
  if(ncol(x) != obj$p) stop("wrong number of columns in x")
  drop(matrix(.Fortran("bdrpred",
		       as.integer(nrow(x)),
		       as.double(x),
		       as.double(obj$smod),
		       y = double(nrow(x)*obj$q),
		       double(2*obj$smod[4]),
                       PACKAGE="modreg"
		       )$y,
	      ncol=obj$q,
	      dimnames=list(dimnames(x)[[1]], obj$ynames)
	      ))
}
#### copyright (C) 1998 B. D. Ripley

smooth.spline <-
  function(x, y = NULL, w = NULL, df = 5, spar = 0, cv = FALSE,
	   all.knots = FALSE, df.offset = 0, penalty = 1)
{
    sknotl <- function(x)
    {
	## 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))
    }

    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")
	    (w * sum(w > 0))/sum(w)
	}
    ispar <- if(missing(spar)) 0 else if(spar < 1.01e-15) 0 else  1
    icrit <- if(cv) 2 else  1
    dfinfo <- df.offset
    if(!missing(df)) {
	if(df > 1 & df < n) {
	    icrit <- 3
	    dfinfo <- df
	} else warning("you must supply 1 < df < n")
    }
    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(mean(y[i]), sum(w[i])),
				y = y, w = w)),
		  ncol = 2, byrow=TRUE)
    ybar <- tmp[, 1]
    wbar <- tmp[, 2]
    nx <- length(ux)
    r.ux <- ux[nx] - ux[1]
    xbar <- (ux - ux[1])/r.ux
    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
    }
    low.parm <- 0
    high.parm <- 1.5
    fit <- .Fortran("qsbart",
		    as.double(penalty),
		    as.double(dfinfo),
		    x = as.double(xbar),
		    y = as.double(ybar),
		    w = as.double(wbar),
		    as.integer(nx),
		    as.double(knot),
		    as.integer(nk),
		    coef = double(nk),
		    ty = double(nx),
		    lev = double(nx),
		    crit = double(1),
		    iparms =as.integer(c(icrit, ispar)),
		    spar = as.double(spar),
		    parms= as.double(c(0, 1.5, 0.001)),
		    isetup= as.integer(0),
		    scrtch= double((17 + nk) * nk),
		    ld4= as.integer(4),
		    ldnk= as.integer(1),
		    ier = as.integer(1),
                    DUP = FALSE, PACKAGE="modreg"
                    )[c("coef","ty","lev","spar","ier")]
    if(fit$ier > 0) {
	warning("smoothing parameter value too small or too large")
	fit$ty <- rep(mean(y), nx)
    }
    lev <- fit$lev
    df <- sum(lev)
    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)/sum(wbar))^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"
    object <- list(x = ux, y = fit$ty, w = wbar, yin = ybar,
		   lev = lev, cv.crit = cv.crit, pen.crit = pen.crit, df = df,
		   spar = fit$spar, fit = fit.object, call = match.call())
    class(object) <- "smooth.spline"
    object
}

print.smooth.spline <- function(x, ...)
{
    if(!is.null(cl <- x$call)) {
	cat("Call:\n")
	dput(cl)
    }
    if(is.null(cv <- cl$cv)) cv <- FALSE
    cat("\nSmoothing Parameter (Spar):", format(x$spar), "\n")
    cat("Equivalent Degrees of Freedom (Df):", format(x$df), "\n")
    cat("Penalized Criterion:", format(x$pen.crit), "\n")
    crss <- if(cv) "PRESS:" else "GCV:"
    cat(crss, format(x$cv.crit), "\n")
    invisible(x)
}

predict.smooth.spline <- function(object, x, deriv = 0, ...)
{
    if(missing(x)) 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, length(y)), span = "cv", periodic = FALSE, bass = 0)
{
    if(span == "cv") span <- 0
    n <- length(y)
    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")
    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)
