.packageName <- "aws"
############################################################################
#
# univariate Adaptive Weights Smoothing
#
# Copyright Weierstrass Instiute for Applied Analysis and Stochastics 
#           J. Polzehl 2000
############################################################################

awsuni <- function(y, lambda=3, gamma=1.3, eta =4, s2hat = NULL, kstar =
length(radii),radii = c(1:8,(5:12)*2,(7:12)*4,(7:12)*8,(7:10)*16,(6:8)*32,
         (5:8)*64,(5:8)*128,(5:8)*256),rmax=max(radii),
         graph = FALSE,z0 = NULL, eps = 1e-08, control="dyadic",demomode=FALSE)
{
# requires  dyn.load("aws.so") 
#
#   y - observed values (ordered by value of independent variable)
#   lambda - main smoothing parameter (should be approximately 3)
#   gamma  - allow for increase of variances (over minsk) by factor gamma
#   eta   - main control parameter (should be approximately 4)   
#   s2hat - initial variance estimate (if available,
#           can be either a number (homogeneous case), a vector of same length 
#           as y (inhomogeneous variance) or NULL (a homogeneous variance estimate
#           will be generated in this case)
#   kstar - number of iterations to perform (set to min(kstar, length(radii)))
#   radii - radii of neighbourhoods used
#   graph - logical, if TRUE progress (for each iteration) is illustrated grahically,
#           if FALSE the program runs until the final estimate is obtained 
#           (much faster !!!)
#   z0    - allows for submission of "true" values for illustration puposes only
#           if graph=TRUE  MSE and MAE are reported for each iteration step
#   eps - stop iteration if ||(yhatnew - yhat)||^2 < eps * sum(s2hat)
#   control - the control step is performed in either a dyadic sceme
#           ("dyadic") or using all previous estimates (otherwise)
#   demomode - only active if graph=TRUE, causes the program to wait after displaying the 
#           results of an iteration step
#
        radii <- radii[radii<=rmax]
        kstar <- min(kstar,length(radii))
        args <- list(lambda=lambda,gamma=gamma,eta=eta,s2hat = s2hat, 
                     kstar = kstar, radii=radii, rmax=rmax)
        if(graph) oldpar <- par(mfrow=c(1,3))
        ind <- trunc(radii)
        ind <- ind[ind>0]
        if(is.null(ind)) ind <- 1:kstar
        kstar <- min(kstar, length(ind))
        newcontr <- numeric(kstar)
        if(control=="dyadic") newcontr[2^(0:(log(kstar)/log(2)))] <- 1
        else newcontr[1:kstar] <- 1
        cat("Control sceme: ",newcontr,"\n")
        n <- length(y)
        x <- 1:n
        lam0 <- lambda
        lambda <- lambda^2
        gamma <- gamma^2
# generate a variance estimate if needed
        if(is.null(s2hat))
                s2hat <- (IQR(diff(y))/1.908)^2
# expand variance estimate in case of homogeneous variance
        if(length(s2hat) == 1)
                s2hat <- rep(s2hat, n)
# now initialize 
        yhat <- y
        sk <- skmin <- s2hat
        kern <- exp( - seq(0, 6, 0.3))
        lambda.3 <- lambda * 0.3
        controls <- numeric(2*n)
        dim(controls) <- c(2,n)
        controls[1,] <- y-eta*sqrt(s2hat)
        controls[2,] <- y+eta*sqrt(s2hat)
        if(ind[1] > 1) {
# nontrivial first neighbourhood (should only be used for small signal/noise)
                z <- .Fortran("locuini2",
                        as.integer(n),
                        as.single(y),
                        yhat = as.single(y),
                        sk = as.single(sk),
                        as.integer(ind[1] - 1),
                        as.single(numeric(2 * ind[1] - 1)),
                        as.single(numeric(2 * ind[1] - 1)),
                        as.single(s2hat),PACKAGE="aws")
                yhat <- z$yhat
                sk <- skmin <- z$sk
                if(graph) {
                        plot(x, y)
                        if(!is.null(z0)) lines(x, z0, col = 3)
                        lines(x, yhat, col = 2)
                        lines(x, yhat-sqrt(lambda*sk),col=4,lty=2)
                        lines(x, yhat+sqrt(lambda*sk),col=4,lty=2)
                        if(!is.null(z0)) lines(x, yhat, col = 2)
                        title(paste("Estimate  Iteration ", 0,
                        "  N(U) = ", 2 * ind[1] - 1))
                        ylim <- range(y - yhat)
                        if(!is.null(z0)) ylim <- range(ylim, z0 - yhat)
                        plot(x, y - yhat, ylim = ylim)
                        if(!is.null(z0)) lines(x, z0 - yhat, col = 3)
                        lines(x, yhat - yhat, col = 2)
                        title("Residuals")
                        plot(x, sqrt(sk))
                        title(paste("sigmahat\n l=", sqrt(lambda), "g=", sqrt(
                                gamma), "shat=", signif(sqrt(mean(s2hat)), 3)))
            if(demomode) {
            cat("press ENTER to continue")
            readline()
            }
                }
        }
        if(graph) {
           if(!is.null(z0))
                cat("Iteration ", 0, "MSE:", mean((yhat - z0)^2), "MAE:", 
                        mean(abs(yhat - z0)), "\n")
           for(k in 2:kstar) {
                yhatold <- yhat
                z <- .Fortran("locuniw",
                        as.integer(n),
                        as.single(y),
                        as.single(yhat),
                        yhat = as.single(yhat),
                        as.single(sk),
                        as.single(s2hat),
                        sk = as.single(sk),
                        controls=as.single(controls),
                        as.integer(newcontr[k]),
                        as.single(skmin),
                        as.integer(ind[k] - 1),
                        as.single(lambda.3),
                        as.single(eta),
                        as.single(gamma),
                        as.single(kern),PACKAGE="aws")[c("yhat","sk","controls")]
                yhat <- z$yhat
                sk <- z$sk
                controls <- z$controls
                skmin <- pmin(skmin, sk)
                if(!is.null(z0))
                cat("Iteration ", k-1, "MSE:", mean((yhat - z0)^2), "MAE:",
                        mean(abs(yhat - z0)), "\n")
                plot(x, y)
                if(!is.null(z0)) lines(x, z0, col = 3)
                lines(x, yhat, col = 2)
                lines(x, yhat-sqrt(lambda*sk),col=4,lty=2)
                lines(x, yhat+sqrt(lambda*sk),col=4,lty=2)
                if(!is.null(z0)) lines(x, yhat, col = 2)
                title(paste("Estimate  Iteration ", k-1, "  N(U) = ", 2 * ind[k] - 1))
                ylim <- range(y - yhat)
                if(!is.null(z0)) ylim <- range(ylim, z0 - yhat)
                plot(x, y - yhat, ylim = ylim)
                if(!is.null(z0)) lines(x, z0 - yhat, col = 3)
                lines(x, yhat - yhat, col = 2)
                title("Residuals")
                plot(x, sqrt(sk))
                title(paste("sigmahat    mean(shat)=", 
                      signif(sqrt(mean(sk)), 3)))
                if(sum((yhatold - yhat)^2) <= sum(eps * s2hat)) break
            if(demomode) {
            cat("press ENTER to continue")
            readline()
            }
                }
             par(oldpar)
        }
        else {
                z <- .Fortran("locunial",
                        as.integer(kstar),
                        as.integer(n),
                        as.single(y),
                        as.single(yhat),
                        yhat = as.single(yhat),
                        as.single(sk),
                        as.single(s2hat),
                        sk = as.single(sk),
                        controls=as.single(controls),
                        as.integer(newcontr),
                        as.single(skmin),
                        as.integer(ind),
                        as.single(lambda.3),
                        as.single(eta),
                        as.single(gamma),
                        as.single(kern),
                        as.single(sum(eps * s2hat)),PACKAGE="aws")[c("yhat","sk")]
                yhat <- z$yhat
                sk <- z$sk
        }
        if(!is.null(z0))
                cat("kstar=", kstar, "MSE:", mean((yhat - z0)^2), "MAE:",
                        mean(abs(yhat - z0)), "\n")
        list(yhat = yhat, shat = sqrt(sk),args=args)
}

############################################################################
#
# bivariate local constant smoothing
#
# Copyright Weierstrass Instiute for Applied Analysis and Stochastics
#           J. Polzehl 2000
############################################################################

awsbi <- function(y, lambda=3, gamma=1.3, eta = 4, 
     s2hat = NULL, kstar = length(radii), rmax=max(radii),
     radii=c((1:8)/2,4.4,5.,(6:10),(6:10)*2), graph = FALSE, 
     u0 = NULL,control="dyadic",demomode=FALSE, colors=gray((0:255)/255))
{
# requires  dyn.load("aws.so") 
#
#   y - observed values 
#   lambda - main smoothing parameter (should be approximately 3)
#   gamma  - allow for increase of variances (over minsk) by factor gamma
#   eta   - main control parameter (should be approximately 4)   
#   s2hat - initial variance estimate (if available,
#           can be either a number (homogeneous case), a matrix of same dimension  
#           as y (inhomogeneous variance) or NULL (a homogeneous variance estimate
#           will be generated in this case)
#   kstar - number of iterations to perform (set to min(kstar, length(radii)))
#   radii - radii of neighbourhoods used
#   graph - logical, if TRUE progress (for each iteration) is illustrated grahically,
#           if FALSE the program runs until the final estimate is obtained 
#           (much faster !!!)
#   colors - color sceme to be used for images
#   u0    - allows for submission of "true" values for illustration puposes only
#           if graph=TRUE  MSE and MAE are reported for each iteration step
#   control - the control step is performed in either a dyadic sceme
#           ("dyadic") or using all previous estimates (otherwise)
#   demomode - only active if graph=TRUE, causes the program to wait after displaying the 
#           results of an iteration step
#
        storage.mode(y) <- "single"
        storage.mode(s2hat) <- "single"
        radii <- radii[radii<=rmax]
        kstar <- min(kstar,length(radii))
        args <- list(lambda=lambda,gamma=gamma,eta=eta,s2hat = s2hat, 
                     kstar = kstar, radii=radii)
        l2 <- r2 <- single(kstar)
        newcontr <- numeric(kstar)
        if(control=="dyadic") newcontr[2^(0:(log(kstar)/log(2)))] <- 1
        else newcontr[1:kstar] <- 1
        cat("Control sceme: ",newcontr,"\n")
        dy <- dim(y)
        if(is.null(dy)||length(dy)>2) stop("y should have dimension 2")
        nx <- dy[1]
        ny <- dy[2]
        n <- nx * ny
        if(graph) oldpar <- par(mfrow = c(1, 3))
        kiii <- radii^2
# get number of points in neighbourhoods
        iii <- getnubi(radii^2, c(1, 1))
        lambda <- lambda^2
        gamma <- gamma^2
        kern <- exp( - seq(0, 6, 0.3))
        lambda <- lambda * 0.3
# generate a variance estimate if needed
        if(length(s2hat) == 0) {
           s2hat <- (IQR(diff(y))/1.908)^2
           cat("Estimated variance:",s2hat,"\n")
           }
# expand s2hat in case of homogeneous variance
        if(length(as.vector(s2hat)) == 1) s2hat <- matrix(as.single(rep(s2hat, 
                        n)), ncol = ny) 
        storage.mode(s2hat) <- "single"
        controls <- numeric(2*n)
        dim(controls) <- c(2,nx,ny)
        controls[1,,] <- y-eta*sqrt(s2hat)
        controls[2,,] <- y+eta*sqrt(s2hat)
        storage.mode(controls) <- "single"
        yhat <- y
        minsk <- sk <- s2hat
        if(!is.null(u0)) {
                l2[1] <- mean((yhat - u0)^2)
                r2[1] <- mean(abs(yhat - u0))
                cat("Iteration", 0, "nu=", iii[1], "MSE", l2[1], 
                                "MAE", r2[1], "\n")
        }
        kiiinit <- kiii[1]
        if(kiiinit > 5) kiiinit <- 5
# nontrivial first neighbourhood (should only be used for small signal/noise)
        z <- .Fortran("locbinis",
                as.integer(nx),
                as.integer(ny),
                as.single(y),
                yhat = as.single(yhat),
                as.single(s2hat),
                sk = as.single(sk),
                as.single(kiiinit + 0.001),PACKAGE="aws")
        yhat <- as.single(z$yhat)
        sk <- as.single(z$sk)
        if(graph) {
        for(k in 2:kstar) {
                z <- .Fortran("locbiw",
                        as.integer(nx),
                        as.integer(ny),
                        as.single(y),
                        as.single(yhat),
                        yhat = as.single(yhat),
                        as.single(sk),
                        sk = as.single(sk),
                        controls=as.single(controls),
                        as.integer(newcontr[k]),
                        as.single(minsk),
                        as.single(kiii[k] + 0.0001),
                        as.single(s2hat),
                        as.single(lambda),
                        as.single(eta),
                        as.single(gamma),
                        as.single(kern),PACKAGE="aws")[c("yhat","sk","controls")]
                yhat <- as.single(z$yhat)
                sk <- as.single(z$sk)
                controls <- as.single(z$controls)
                minsk <- pmin(sk, minsk)
                if(!is.null(u0)) {
                        l2[k] <- mean((yhat - u0)^2)
                        r2[k] <- mean(abs(yhat - u0))
                }
                        image(matrix(y, ncol = ny),col=colors)
                        title("original image")
                        image(matrix(yhat, ncol = ny),zlim=range(y),col=colors)
                        title(paste("Estimate  Iteration ", k-1, "  N(U) = ", iii[k]))
                        image(matrix(log(sk), ncol = ny),col=colors)
                        title(paste("log(var(yhat))"," Mean Var:",signif(mean(sk),3)))
                if(!is.null(u0))
                        cat("Iteration", k-1, "nu=", iii[k], "MSE", l2[k],
                                "MAE", r2[k], "\n")
            if(demomode) {
            cat("press ENTER to continue")
            readline()
            }
                gc()
                }
                par(oldpar)
        list(yhat = matrix(yhat, ncol = ny), shat = matrix(sk, ncol = ny), 
             nu = iii, l2 = l2, r2 = r2, args=args)
        }
        else {
           z <- .Fortran("locbiall",
                        as.integer(kstar),
                        as.integer(nx),
                        as.integer(ny),
                        as.single(y),
                        as.single(yhat),
                        yhat = as.single(yhat),
                        as.single(sk),
                        sk = as.single(sk),
                        as.single(controls),
                        as.integer(newcontr),
                        as.single(minsk),
                        as.single(kiii),
                        as.single(s2hat),
                        as.single(lambda),
                        as.single(eta),
                        as.single(gamma),
                        as.single(kern),PACKAGE="aws")[c("yhat","sk")]
                if(!is.null(u0)){
                        l2[kstar] <- mean((z$yhat - u0)^2)
                        r2[kstar] <- mean(abs(z$yhat - u0))
                        cat("Iteration ", kstar-1, "nu=", iii[kstar], "MSE", l2[kstar],
                                "MAE", r2[kstar], "\n")
                        }
        list(yhat = matrix(as.single(z$yhat), ncol = ny),
             shat = matrix(as.single(z$sk), ncol = ny),
             nu = iii,  args=args)
        }
}

############################################################################
#
# trivariate local constant smoothing
#
# Copyright Weierstrass Instiute for Applied Analysis and Stochastics
#           J. Polzehl 2000
############################################################################


awstri <- function(y, lambda = 3, gamma = 1.3 , eta = 4, s2hat = NULL, 
    kstar = length(radii), rmax=max(radii), weight = c(1,1,1), 
    radii = c((1:4)/2,2.3,(5:12)/2,7:9,10.5,12,13.5),control="dyadic")
{
# requires  dyn.load("aws.so") 
#
#   y - observed values (ordered by value of independent variable)
#   lambda - main smoothing parameter (should be approximately 3)
#   gamma  - allow for increase of variances (over minsk) by factor gamma
#   eta   - main control parameter (should be approximately 4)   
#   s2hat - initial variance estimate (if available,
#           can be either a number (homogeneous case), a vector of same length 
#           as y (inhomogeneous variance) or NULL (a homogeneous variance estimate
#           will be generated in this case)
#   kstar - number of iterations to perform (set to min(kstar, length(radii)))
#   weight - excentricities of ellipsoids used as neighbourhoods 
#            used to weight distances in coordinate directions
#   radii - radii of neighbourhoods used
#   control - the control step is performed in either a dyadic sceme
#           ("dyadic") or using all previous estimates (otherwise)
#
# Speicherschonende Variante
# mit Fortran requires  dyn.load.shared("./image3.so")
        storage.mode(y) <- "single"
        storage.mode(s2hat) <- "single"
        radii <- radii[radii<=rmax]
        kstar <- min(kstar,length(radii))
        args <- list(lambda=lambda,gamma=gamma,eta=eta,s2hat = s2hat, 
                     kstar = kstar, radii=radii)
        dy <- dim(y)
        if(length(dy) != 3) stop("y is not a 3-dimensional array")
        if(is.null(weight)) weight <- rep(1, 3)
        if(is.null(radii)) stop("No neigborhood defined")
        radii2 <- radii^2
        nx <- dy[1]
        ny <- dy[2]
        nz <- dy[3]
        newcontr <- numeric(kstar)
        if(control=="dyadic") newcontr[2^(0:(log(kstar)/log(2)))] <- 1
        else newcontr[1:kstar] <- 1
    cat("Control sceme: ", newcontr,"\n")
        lambda <- lambda^2
        gamma <- gamma^2
#         kern <- exp( - seq(0, 6, 0.3)/1.44)
        kern <- exp( - seq(0, 6, 0.3))
        lambda <- lambda*.3
        n <- nx * ny * nz
        if(length(s2hat) == 0) s2hat <- (IQR(diff(y))/1.908)^2
        if(length(as.vector(s2hat)) == 1) homogeneous <- TRUE
        #now precompute neighbourhoods
        yhat <- as.single(y)
        if(homogeneous) minsk <- sk <- array(s2hat,dim(y))
    else minsk <- sk <- s2hat
        controls <- numeric(2*n)
        dim(controls) <- c(2,nx,ny,nz)
        controls[1,,,] <- y-eta*sqrt(s2hat)
        controls[2,,,] <- y+eta*sqrt(s2hat)
        storage.mode(controls) <- "single"
        if(homogeneous){
        z <- .Fortran("loctria0",
                as.integer(kstar),
                as.integer(nx),
                as.integer(ny),
                as.integer(nz),
                as.single(y),
                as.single(yhat),
                yhat = as.single(yhat),
                as.single(sk),
                sk = as.single(sk),
                as.single(controls),
                as.integer(newcontr),
                as.single(radii2),
                as.single(s2hat),
                as.single(lambda),
                as.single(eta),
                as.single(weight),
                as.single(kern),PACKAGE="aws")[c("yhat","sk")]
                }
        else{
        z <- .Fortran("loctrial",
                      as.integer(kstar),
                      as.integer(nx),
                      as.integer(ny),
                      as.integer(nz),
                      as.single(y),
                      as.single(yhat),
                      yhat = as.single(yhat),
                      as.single(sk),
                      sk = as.single(sk),
                      as.single(controls),
                      as.integer(newcontr),
                      as.single(minsk),
                      as.single(radii2),
                      as.single(s2hat),
                      as.single(lambda),
                      as.single(eta),
                      as.single(gamma),
                      as.single(weight),
                      as.single(kern),PACKAGE="aws")[c("yhat","sk")]
                      }
    list(yhat = array(as.single(z$yhat), dim = dy), shat = array(as.single(z$sk),
         dim = dy), args = args)
}


############################################################################
#
# get number of pixels in bivariate neighbourhoods
#
############################################################################

getnubi <- function(radiusq, weights)
{
        nu <- numeric(length(radiusq))
        nu <- .Fortran("getnubi",
                as.single(radiusq),
                as.single(weights),
                nu = as.integer(nu),
                as.integer(length(radiusq)),PACKAGE="aws")$nu
        nu
}

############################################################################
#
# get number of pixels in trivariate neighbourhoods
#
############################################################################

getnutri <- function(radiusq, weights)
{
        nu <- nu3 <- numeric(length(radiusq))
        nu3 <- .Fortran("getnubi",
                as.single(radiusq),
                as.single(weights[1:2]),
                nu = as.integer(nu3),
                as.integer(length(radiusq)),PACKAGE="aws")$nu
        for( i in 1:trunc(max(sqrt(radiusq))/weights[3])) {
           radius2 <- radiusq-i^2*weights[3]
           ind <- (1:length(radiusq))[radius2>=0]
           if(length(ind)<1) break
           nu3[ind] <- nu3[ind] + 2*.Fortran("getnubi",
                         as.single(radius2[ind]),
                         as.single(weights[1:2]),
                         nu = as.integer(nu[ind]),
                         as.integer(length(ind)),PACKAGE="aws")$nu
        }
        nu3
}


.First.lib <- function(lib, pkg) {
  if(version$major==0)
    stop("This version for R 1.00 or later")
  library.dynam("aws", pkg, lib)
}
#
#    R - function  awstindex  for tail-index estimation                                                          
#
#    Copyright (C) 2002 Weierstrass-Institut fr                                
#                       Angewandte Analysis und Stochastik (WIAS)               
#
#    Author:  Jrg Polzehl                                                      
#
#  This program is free software; you can redistribute it and/or modify         
#  it under the terms of the GNU General Public License as published by         
#  the Free Software Foundation; either version 2 of the License, or            
#  (at your option) any later version.                                          
#
#  This program is distributed in the hope that it will be useful,              
#  but WITHOUT ANY WARRANTY; without even the implied warranty of               
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the                
#  GNU General Public License for more details.                                 
#
#  You should have received a copy of the GNU General Public License            
#  along with this program; if not, write to the Free Software                  
#  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,        
#  USA.                                                                         
#
awstindex <- function(y,qlambda=NULL,eta=0.5,lkern="Triangle",hinit=1,hincr=1.25,hmax=1000,
                 graph=FALSE,symmetric=FALSE){
args <- match.call()
if(!is.null(dim(y))) 
   return("only univariate tail index estimation is implemented")
n <- length(y)
y <- sort(y)[n:1]
x <- (1:(n-1))*log(y[-n]/y[-1])
theta <- laws(x,qlambda=qlambda,model="Exponential",hinit=hinit,hincr=hincr,
     hmax=hmax,graph=graph,symmetric=symmetric)$theta
z<-list(tindex=theta[1],intensity=theta,y=y,call=args)
class(z)<-"laws.tindex"
z
}
#
#    R - function  awsdens  for local constant density estimation  in 1D, 2D and 3D                                                        
#
#    Copyright (C) 2002 Weierstrass-Institut fr                                
#                       Angewandte Analysis und Stochastik (WIAS)               
#
#    Author:  Jrg Polzehl                                                      
#
#  This program is free software; you can redistribute it and/or modify         
#  it under the terms of the GNU General Public License as published by         
#  the Free Software Foundation; either version 2 of the License, or            
#  (at your option) any later version.                                          
#
#  This program is distributed in the hope that it will be useful,              
#  but WITHOUT ANY WARRANTY; without even the implied warranty of               
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the                
#  GNU General Public License for more details.                                 
#
#  You should have received a copy of the GNU General Public License            
#  along with this program; if not, write to the Free Software                  
#  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,        
#  USA.                                                                         
#
awsdens <- function(y,ngrid=NULL,nempty=NULL,qlambda=NULL,eta=0.5,lkern="Triangle",fu=NULL,
                    hinit=1,hincr=1.2,hmax=NULL,graph=FALSE,demo=FALSE,symmetric=TRUE){
# first generate the grid of bin's
args <- match.call()
dy <- dim(y)
u <- NULL
if(is.null(dy)){
   n <- length(y)
   if(is.null(ngrid)) ngrid <- as.integer(2*n)
   if(is.null(nempty)) nempty <- trunc(.1*ngrid)
   dd <- 1
   ry <- range(y)
   dry <- diff(ry)
   ry[1] <- ry[1]-dry/ngrid*nempty
   ry[2] <- ry[2]+dry/ngrid*nempty
   dry <- dry*(1+2/ngrid*nempty)
   bin <- numeric(ngrid)
   ind <- trunc((y-ry[1])/dry*ngrid)+1
   bin[as.integer(levels(factor(ind)))] <- table(ind)
   xgrid <- list(seq(ry[1]+dry/2/ngrid,ry[2]+dry/2/ngrid,length=ngrid))
   if(!is.null(fu)) u <- fu(xgrid)
   } else {
# assume the rows to contain components
   dd <- dy[1] 
   n <- dy[2]
   if(is.null(ngrid)) ngrid <- as.integer(2*n^(1/dd))
   if(is.null(nempty)) nempty <- trunc(.1*ngrid)
   ry <- apply(y,1,range)
   dry <- ry[2,]-ry[1,]
   ry[1,] <- ry[1,]-dry/ngrid*nempty
   ry[2,] <- ry[2,]+dry/ngrid*nempty
   dry <- dry*(1+2/ngrid*nempty)
   if(length(ngrid)==1) ngrid <- rep(ngrid,dd)
   if(length(ngrid)!=dd) return("incompatible length of ngrid")
   if(dd>3) return("not implemented for more than three dimensions")
   if(dd==2) bin <- matrix(0,ngrid[1],ngrid[2])
   if(dd>2) bin <- array(0,ngrid)
   ind <- matrix(0,n,dd)
   for(i in 1:dd) 
       ind[,i] <- trunc((y[i,]-ry[1,i])/dry[i]*ngrid[i])+1
   if(dd==2) {
       bin[as.integer(levels(factor(ind[,1]))),
       as.integer(levels(factor(ind[,2])))] <- table(ind[,1],ind[,2]) 
       xgrid <- list(seq(ry[1,1]+dry[1]/2/ngrid[1],ry[2,1]+dry[1]/2/ngrid[1],length=ngrid[1]),
                      seq(ry[1,2]+dry[2]/2/ngrid[2],ry[2,2]+dry[2]/2/ngrid[2],length=ngrid[2]))
       if(!is.null(fu)) u <- fu(xgrid[[1]],xgrid[[2]])
       } else {
       bin[as.integer(levels(factor(ind[,1]))),as.integer(levels(factor(ind[,2]))),
       as.integer(levels(factor(ind[,3])))] <- table(ind[,1],ind[,2],ind[,3])
       xgrid <- list(seq(ry[1,1]+dry[1]/2/ngrid[1],ry[2,1]+dry[1]/2/ngrid[1],length=ngrid[1]),
                      seq(ry[1,2]+dry[2]/2/ngrid[2],ry[2,2]+dry[2]/2/ngrid[2],length=ngrid[2]),
                      seq(ry[1,3]+dry[3]/2/ngrid[3],ry[2,3]+dry[3]/2/ngrid[3],length=ngrid[3]))
       if(!is.null(fu)) u <- fu(xgrid[[1]],xgrid[[2]],xgrid[[3]])
       }
   }
   if(!is.null(fu)) u <- u*n*prod(dry/ngrid)
   dens <- laws(bin,qlambda=qlambda,model="Poisson",eta=eta,lkern=lkern,
                hinit=hinit,hincr=hincr,hmax=hmax,graph=graph,demo=demo,
                u=u,symmetric=symmetric)$theta
   dens <- dens/sum(dens)/prod(dry/ngrid)
z<-list(bin=bin,dens=dens,xgrid=xgrid,call=args)
class(z)<-"laws.density"
z
}
#
#    R - function  laws  for likelihood  based  Adaptive Weights Smoothing (AWS)
#    for local constant Gaussian, Bernoulli, Exponential, Poisson, Weibull and  
#    Volatility models                                                          
#
#    Copyright (C) 2002 Weierstrass-Institut fr
#                       Angewandte Analysis und Stochastik (WIAS)
#
#    Author:  Jrg Polzehl
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
#  USA.
#
laws <- function(y,x=NULL,qlambda=NULL,eta=0.5,lkern="Triangle",model="Poisson",
                 shape=NULL,hinit=NULL,hincr=NULL,hmax=10,NN=FALSE,u=NULL,
                 graph=FALSE,demo=FALSE,symmetric=FALSE,wghts=NULL)
{
#
#    first check arguments and initialize
#
args <- match.call()
eps <- 1.e-10
if(is.null(qlambda)) if(symmetric) qlambda <- switch(model,
                                                     Gaussian=.985,
                                                     Bernoulli=.985,
                                                     Exponential=.985,
                                                     Poisson=.985,
                                                     Weibull=.985,
                                                     Volatility=.995)
                     else qlambda <- switch(model,   Gaussian=.966,
                                                     Bernoulli=.966,
                                                     Exponential=.966,
                                                     Poisson=.966,
                                                     Weibull=.966,
                                                     Volatility=.98)
if(qlambda>=1 || qlambda<.6) return("Inappropriate value of qlambda")
if(eta<eps || eta>=1) return("Inappropriate value of eta")
if(model!="Gaussian"&&model!="Bernoulli"&&model!="Exponential"&&
   model!="Poisson"&&model!="Weibull"&&model!="Volatility")
   return(paste("specified model ",model," not yet implemented"))
#
#    generate kernel on a grid  and set lambda
#
getkern <- function(x,kern)
switch(kern,Triangle=pmax(0,(1-x)),
            Quadratic=pmax(0,(1-x))^2,
            Cubic=pmax(0,(1-x))^3,
            Uniform=as.numeric(abs(x)<=1),
            Exponential=exp(-5*x),
            {
            cat("Triangle kernel is used as default\n");
            pmax(0,(1-x))
            })
# this gives a discretized kern on [0,1.01] for use of (xij^2) as argument
#  length 102  (last element to avoid numerical problems if x(j)==xi+-h)
kernl <- getkern(seq(0,1.01,.01),lkern)
kerns <- getkern(seq(0,1.01,.01),"Exponential")
#
#      get lambda as quantile of appropriate chisq,
#                rescale to be consistent with the paper in  lamakt
#
lamakt <- 5*qchisq(qlambda,1)
if(model=="Gaussian") lamakt <- lamakt*shape*2
#
#   specify which statistics are needed and transform data if necessary
#
logtheta <- switch(model,Gaussian=FALSE,Bernoulli=TRUE,Exponential=TRUE,
                   Poisson=TRUE,Weibull=TRUE,Volatility=TRUE)
logctheta <- switch(model,Gaussian=FALSE,Bernoulli=TRUE,Exponential=FALSE,
                    Poisson=FALSE,Weibull=FALSE,Volatility=FALSE)
if(model=="Weibull" && (is.null(shape) || shape<=0))
   return("Shape parameter for Weibull has to be positive")
if(model=="Gaussian" && (is.null(shape) || shape<=0)) 
   return("Variance (shape) for Gaussian errors has to be positive")
weibull <- FALSE
if(model=="Weibull") {
model <- "Exponential"
y <- y^shape
weibull <- TRUE
}
shape <- 1
if(model=="Volatility"){
model <- "Exponential"
y <- y^2
lamakt <- 2*lamakt 
# this accounts for the additional 1/2 in Q(\hat{theta},theta)
weibull <- TRUE
shape <- 2
}
if(demo&& !graph) graph <- TRUE
# now check which procedure is appropriate
gridded <- is.null(x)
if(gridded){
##  this is the version on a grid
if(is.null(hinit)||hinit<1) hinit <- 1
dy <- dim(y)
if(is.null(dy)) {
   form <- "uni"
   ddim  <- 1
   n <- length(y)
}
if(length(dy)==2){
   form <- "bi"
   ddim  <- 2
n1 <- dy[1]
n2 <- dy[2]
n <- n1*n2
if(is.null(wghts)) wghts<-c(1,1)
hinit<-hinit/wghts[1]
hmax<-hmax/wghts[1]
wghts<-(wghts[2]/wghts[1])^2
}
if(length(dy)==3){
   form <- "tri"
   ddim  <- 3
n1 <- dy[1]
n2 <- dy[2]
n3 <- dy[3]
n <- n1*n2*n3
if(is.null(wghts)) wghts<-c(1,1,1)
hinit<-hinit/wghts[1]
hmax<-hmax/wghts[1]
wghts<-(wghts[2:3]/wghts[1])^2
}
if(length(dy)>3)
   return("AWS for more than 3 dimensional grids is not implemented")
} else {
# not gridded
dx <- dim(x)
ddim <- 1
if(is.null(dx)&&NN) {
#
#    order data by order of x
#
    form <- "uni"
    n <- length(x)
    if(n!=length(y)) return("incompatible lengths of x and y")
    ox <- order(x)
    x <- x[ox]
    y <- y[ox]
}else {
   if(is.null(dx)){
      px <- 1
      n <- length(x)
   }else{
   px <- dx[1]
   n <- dx[2]
   }
   form <- "multi"
   if(n!=length(y)) return("incompatible dimensions of x and y")
   weights <- rep(1,px)
#
#  now generate matrix of nearest neighbors
#  hmax is interpreted as maximal number of neighbors
#
   if(NN){
   ihmax <- trunc(hmax)
   if(ihmax>n) ihmax <- n
   neighbors <- matrix(0,ihmax,n)
   for (i in 1:n) {
      adist <- weights%*%((x-x[,i])^2)
      neighbors[,i] <- order(adist)[1:ihmax]
      }
   } else {
   ihmax <- n
   ddim <- px
   neighbors <- distmat <- matrix(0,n,n)
   for (i in 1:n) {
      adist <- weights%*%((x-x[,i])^2)
      od <- order(adist)
      distmat[,i] <- adist[od]
      neighbors[,i] <- od
      }
#  now reduce memory used to whats needed
   gc()
   distmat <- sqrt(distmat)
   maxdist <- apply(distmat,1,max)
   meandist <- apply(distmat,1,mean)
   mindist <- apply(distmat,1,min)
   ihmax <- sum(mindist<=hmax)
   distmat <- distmat[1:ihmax,]
   neighbors <- neighbors[1:ihmax,]
   maxdist <- maxdist[1:ihmax]
   gc()
   }
   }

   if(length(y)!=n) return("incompatible dimensions of x and y")
   #
   #
   if(NN){
      if(is.null(hinit)||hinit<1) hinit <- 1
   } else {
      if(is.null(hinit)||hinit<=0) hinit <- mindist
   }
   }
#
#     now set hincr if not provided
#
if(is.null(hincr)) hincr <- 1.25^(1/ddim)
#
#    get a global estimate if they are needed for regularization
#
if(logtheta) gtheta <- mean(y)
#
#    now select the correct aws-procedure
#
#   cases:    gridded      uni
#             gridded      bi
#             gridded      tri
#             !gridded     multi
#             !gridded     multi, Nearest Neighbor
#
if(gridded &&  form=="uni" ){
###
###              gridded     uni
###
###     this should run a little faster than the nongridded version
###
bi <- ai <- theta <- numeric(n)
if(is.null(hinit)||hinit<1) hinit <- 1
#  first initialize
z <- .Fortran("iawsuni",
              as.double(y),
              as.integer(n),
              as.double(hinit),
              bi=as.double(bi),
              ai=as.double(ai),
              as.double(kernl),PACKAGE="aws")[c("bi","ai")]
bi <- z$bi
ai <- z$ai
if(logtheta) {
bi <- (1-eta)*bi+eta
ai <- (1-eta)*ai+eta*gtheta
}
theta <- ai/bi
if(logtheta) ltheta <- log(theta+eps*max(theta))
if(logctheta) lctheta <- log(1.e0-theta+eps*max(1.e0-theta))
if(weibull) theta <- theta^(1/shape)
if(graph){
par(mfrow=c(1,2),mar=c(3,3,2.5,.5),mgp=c(2,1,0))
plot(y^(1/shape),ylim=range(y^(1/shape),theta),col=3)
if(!is.null(u)) lines(u,col=2)
lines(theta,lwd=2)
title(paste("Reconstruction  h=",signif(hinit,3)))
plot(bi,type="l")
title("Sum of weights")
}
if(!is.null(u)) cat("bandwidth: ",signif(hinit,3),"   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
if(weibull) theta <- theta^(shape)
# now run aws-cycle
hakt <- hinit*hincr
if(graph){
#
#   run single steps to display intermediate results
#
while(hakt<=hmax){
z <- switch(model,
            Gaussian=.Fortran("lawsuni",
                              as.double(y),
                              as.integer(n),
                              as.double(hakt),
                              as.double(lamakt),
                              as.double(theta),
                              bi=as.double(bi),
                              ai=as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.logical(symmetric),PACKAGE="aws")[c("bi","ai")],
            Bernoulli=.Fortran("lberuni",
                               as.double(y),
                               as.integer(n),
                               as.double(hakt),
                               as.double(lamakt),
                               as.double(theta),
                               as.double(ltheta),
                               as.double(lctheta),
                               bi=as.double(bi),
                               ai=as.double(ai),
                               as.double(kernl),
                               as.double(kerns),
                              as.logical(symmetric),PACKAGE="aws")[c("bi","ai")],
            Poisson=.Fortran("lpoiuni",
                             as.double(y),
                             as.integer(n),
                             as.double(hakt),
                             as.double(lamakt),
                             as.double(theta),
                             as.double(ltheta),
                             bi=as.double(bi),
                             ai=as.double(ai),
                             as.double(kernl),
                             as.double(kerns),
                              as.logical(symmetric),PACKAGE="aws")[c("bi","ai")],
            Exponential=.Fortran("lexpuni",
                             as.double(y),
                             as.integer(n),
                             as.double(hakt),
                             as.double(lamakt),
                             as.double(theta),
                             as.double(ltheta),
                             bi=as.double(bi),
                             ai=as.double(ai),
                             as.double(kernl),
                             as.double(kerns),
                              as.logical(symmetric),PACKAGE="aws")[c("bi","ai")])
ai <- (1-eta)*z$ai + eta * ai
bi <- (1-eta)*z$bi + eta * bi
theta  <- ai / bi
if(logtheta) ltheta <- log(theta+eps*max(theta))
if(logctheta) lctheta <- log(1.e0-theta+eps*max(1.e0-theta))
if(weibull) theta <- theta^(1/shape)
plot(y^(1/shape),ylim=range(y^(1/shape),theta),col=3)
if(!is.null(u)) lines(u,col=2)
lines(theta,lwd=2)
title(paste("Reconstruction  h=",signif(hakt,3)))
plot(bi,type="l")
title("Sum of weights")
if(!is.null(u)) cat("bandwidth: ",signif(hakt,3),"   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
if(weibull) theta <- theta^(shape)
hakt <- hakt*hincr
gc()
}
if(weibull) theta <- theta^(1/shape)
} else
{
#   run all iterations in one call
theta <- switch(model,
            Gaussian=.Fortran("gawsuni",
                              as.double(y),
                              as.integer(n),
                              as.double(hinit),
                              as.double(hincr),
                              as.double(hmax),
                              as.double(lamakt),
                              as.double(eta),
                              theta=as.double(theta),
                              as.double(bi),
                              as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.double(bi),
                              as.logical(symmetric),PACKAGE="aws")$theta,
            Bernoulli=.Fortran("gberuni",
                              as.double(y),
                              as.integer(n),
                              as.double(hinit),
                              as.double(hincr),
                              as.double(hmax),
                              as.double(lamakt),
                              as.double(eta),
                              theta=as.double(theta),
                              as.double(ltheta),
                              as.double(lctheta),
                              as.double(bi),
                              as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.double(bi),
                              as.double(ai),
                              as.logical(symmetric),PACKAGE="aws")$theta,
            Poisson= .Fortran("gpoiuni",
                              as.double(y),
                              as.integer(n),
                              as.double(hinit),
                              as.double(hincr),
                              as.double(hmax),
                              as.double(lamakt),
                              as.double(eta),
                              theta=as.double(theta),
                              as.double(ltheta),
                              as.double(bi),
                              as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.double(bi),
                              as.double(ai),
                              as.logical(symmetric),PACKAGE="aws")$theta,
            Exponential=.Fortran("gexpuni",
                              as.double(y),
                              as.integer(n),
                              as.double(hinit),
                              as.double(hincr),
                              as.double(hmax),
                              as.double(lamakt),
                              as.double(eta),
                              theta=as.double(theta),
                              as.double(ltheta),
                              as.double(bi),
                              as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.double(bi),
                              as.double(ai),
                              as.logical(symmetric),PACKAGE="aws")$theta)
if(weibull) theta <- theta^(1/shape)
}
}
      if(gridded &&  form=="bi" ){
###
###             gridded      bi
###
bi <- ai <- theta <- matrix(0,n1,n2)
if(is.null(hinit)||hinit<1) hinit <- 1
#  first initialize
z <- .Fortran("iawsbi",
              as.double(y),
              as.integer(n1),
              as.integer(n2),
              as.double(hinit),
              bi=as.double(bi),
              ai=as.double(ai),
              as.double(kernl),
              as.double(wghts),PACKAGE="aws")[c("bi","ai")]
bi <- z$bi
ai <- z$ai
if(logtheta) {
bi <- (1-eta)*bi+eta
ai <- (1-eta)*ai+eta*gtheta
}
theta <- matrix(ai/bi,n1,n2)
if(logtheta) ltheta <- log(theta+eps*max(theta))
if(logctheta) lctheta <- log(1.e0-theta+eps*max(1.e0-theta))
bi <- matrix(bi,n1,n2)
if(weibull) theta <- theta^(1/shape)
if(graph){
par(mfrow=c(1,3),mar=c(1,1,3,.25),mgp=c(2,1,0))
image(y,col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Observed Image")
image(theta,col=gray((0:255)/255),xaxt="n",yaxt="n")
title(paste("Reconstruction  h=",signif(hinit,3)))
image(bi,col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Sum of weights")
}
if(!is.null(u)) cat("bandwidth: ",signif(hinit,3),"   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
if(weibull) theta <- theta^(shape)
# now run aws-cycle
hakt <- hinit*hincr
if(graph){
#
#   run single steps to display intermediate results
#
while(hakt<=hmax){
z <- switch(model,
            Gaussian=.Fortran("lawsbi",
                              as.double(y),
                              as.integer(n1),
                              as.integer(n2),
                              as.double(hakt),
                              as.double(lamakt),
                              as.double(theta),
                              bi=as.double(bi),
                              ai=as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.logical(symmetric),
                              as.double(wghts),PACKAGE="aws")[c("bi","ai")],
            Bernoulli=.Fortran("lberbi",
                              as.double(y),
                              as.integer(n1),
                              as.integer(n2),
                              as.double(hakt),
                              as.double(lamakt),
                              as.double(theta),
                              as.double(ltheta),
                              as.double(lctheta),
                              bi=as.double(bi),
                              ai=as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.logical(symmetric),
                              as.double(wghts),PACKAGE="aws")[c("bi","ai")],
            Poisson=.Fortran("lpoibi",
                              as.double(y),
                              as.integer(n1),
                              as.integer(n2),
                              as.double(hakt),
                              as.double(lamakt),
                              as.double(theta),
                              as.double(ltheta),
                              bi=as.double(bi),
                              ai=as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.logical(symmetric),
                              as.double(wghts),PACKAGE="aws")[c("bi","ai")],
            Exponential=.Fortran("lexpbi",
                              as.double(y),
                              as.integer(n1),
                              as.integer(n2),
                              as.double(hakt),
                              as.double(lamakt),
                              as.double(theta),
                              as.double(ltheta),
                              bi=as.double(bi),
                              ai=as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.logical(symmetric),
                              as.double(wghts),PACKAGE="aws")[c("bi","ai")])
ai <- (1-eta)*z$ai + eta * ai
bi <- matrix((1-eta)*z$bi + eta * bi,n1,n2)
theta  <- matrix(ai / bi, n1, n2)
if(logtheta) ltheta <- log(theta+eps*max(theta))
if(logctheta) lctheta <- log(1.e0-theta+eps*max(1.e0-theta))
if(weibull) theta <- theta^(1/shape)
image(y,col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Observed Image")
image(theta,col=gray((0:255)/255),xaxt="n",yaxt="n")
title(paste("Reconstruction  h=",signif(hakt,3)))
image(bi,col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Sum of weights")
if(!is.null(u)) cat("bandwidth: ",signif(hakt,3),"   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
hakt <- hakt*hincr
if(weibull) theta <- theta^(shape)
gc()
}
if(weibull) theta <- theta^(1/shape)
} else
{
#   run all iterations in one call
theta <- switch(model,
            Gaussian=.Fortran("gawsbi",
                              as.double(y),
                              as.integer(n1),
                              as.integer(n2),
                              as.double(hinit),
                              as.double(hincr),
                              as.double(hmax),
                              as.double(lamakt),
                              as.double(eta),
                              theta=as.double(theta),
                              as.double(bi),
                              as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.double(bi),
                              as.logical(symmetric),
                              as.double(wghts),PACKAGE="aws")$theta,
            Bernoulli=.Fortran("gberbi",
                              as.double(y),
                              as.integer(n1),
                              as.integer(n2),
                              as.double(hinit),
                              as.double(hincr),
                              as.double(hmax),
                              as.double(lamakt),
                              as.double(eta),
                              theta=as.double(theta),
                              as.double(ltheta),
                              as.double(lctheta),
                              as.double(bi),
                              as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.double(bi),
                              as.double(ai),
                              as.logical(symmetric),
                              as.double(wghts),PACKAGE="aws")$theta,
            Poisson=.Fortran("gpoibi",
                              as.double(y),
                              as.integer(n1),
                              as.integer(n2),
                              as.double(hinit),
                              as.double(hincr),
                              as.double(hmax),
                              as.double(lamakt),
                              as.double(eta),
                              theta=as.double(theta),
                              as.double(ltheta),
                              as.double(bi),
                              as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.double(bi),
                              as.double(ai),
                              as.logical(symmetric),
                              as.double(wghts),PACKAGE="aws")$theta,
            Exponential=.Fortran("gexpbi",
                              as.double(y),
                              as.integer(n1),
                              as.integer(n2),
                              as.double(hinit),
                              as.double(hincr),
                              as.double(hmax),
                              as.double(lamakt),
                              as.double(eta),
                              theta=as.double(theta),
                              as.double(ltheta),
                              as.double(bi),
                              as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.double(bi),
                              as.double(ai),
                              as.logical(symmetric),
                              as.double(wghts),PACKAGE="aws")$theta)
theta <- matrix(theta,n1,n2)
if(weibull) theta <- theta^(1/shape)
}
}
      if(gridded &&  form=="tri" ){
###
###             gridded      tri
###
bi <- ai <- theta <- array(0,c(n1,n2,n3))
if(is.null(hinit)||hinit<1) hinit <- 1
#  first initialize
z <- .Fortran("iawstri",
              as.double(y),
              as.integer(n1),
              as.integer(n2),
              as.integer(n3),
              as.double(hinit),
              bi=as.double(bi),
              ai=as.double(ai),
              as.double(kernl),
              as.double(wghts),PACKAGE="aws")[c("bi","ai")]
bi <- z$bi
ai <- z$ai
if(logtheta) {
bi <- (1-eta)*bi+eta
ai <- (1-eta)*ai+eta*gtheta
}
theta <- array(ai/bi,c(n1,n2,n3))
if(logtheta) ltheta <- log(theta+eps*max(theta))
if(logctheta) lctheta <- log(1.e0-theta+eps*max(1.e0-theta))
bi <- array(z$bi,c(n1,n2,n3))
if(weibull) theta <- theta^(1/shape)
if(graph){
par(mfrow=c(1,3),mar=c(1,1,3,.25),mgp=c(2,1,0))
image(y[,,1],col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Observed Image")
image(theta[,,1],col=gray((0:255)/255),zlim=range(y),xaxt="n",yaxt="n")
title(paste("Reconstruction  h=",signif(hinit,3)))
image(bi[,,1],col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Sum of weights")
}
if(!is.null(u)) cat("bandwidth: ",signif(hinit,3),"   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
if(weibull) theta <- theta^(shape)
# now run aws-cycle
hakt <- hinit*hincr
if(graph){
#
#   run single steps to display intermediate results
#
while(hakt<=hmax){
z <- switch(model,
            Gaussian=.Fortran("lawstri",
                               as.double(y),
                               as.integer(n1),
                               as.integer(n2),
                               as.integer(n3),
                               as.double(hakt),
                               as.double(lamakt),
                               as.double(theta),
                               bi=as.double(bi),
                               ai=as.double(ai),
                               as.double(kernl),
                               as.double(kerns),
                               as.logical(symmetric),
                               as.double(wghts),PACKAGE="aws")[c("bi","ai")],
            Bernoulli=.Fortran("lbertri",
                               as.double(y),
                               as.integer(n1),
                               as.integer(n2),
                               as.integer(n3),
                               as.double(hakt),
                               as.double(lamakt),
                               as.double(theta),
                               as.double(ltheta),
                               as.double(lctheta),
                               bi=as.double(bi),
                               ai=as.double(ai),
                               as.double(kernl),
                               as.double(kerns),
                               as.logical(symmetric),
                               as.double(wghts),PACKAGE="aws")[c("bi","ai")],
            Poisson=.Fortran("lpoitri",
                              as.double(y),
                              as.integer(n1),
                              as.integer(n2),
                              as.integer(n3),
                              as.double(hakt),
                              as.double(lamakt),
                              as.double(theta),
                              as.double(ltheta),
                              bi=as.double(bi),
                              ai=as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.logical(symmetric),
                              as.double(wghts),PACKAGE="aws")[c("bi","ai")],
            Exponential=.Fortran("lexptri",
                              as.double(y),
                              as.integer(n1),
                              as.integer(n2),
                              as.integer(n3),
                              as.double(hakt),
                              as.double(lamakt),
                              as.double(theta),
                              as.double(ltheta),
                              bi=as.double(bi),
                              ai=as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.logical(symmetric),
                              as.double(wghts),PACKAGE="aws")[c("bi","ai")])
ai <- (1-eta)*z$ai + eta * bi * theta
bi <- array((1-eta)*z$bi + eta * bi,c(n1,n2,n3))
theta  <- array(ai / bi, c(n1,n2,n3))
if(logtheta) ltheta <- log(theta+eps*max(theta))
if(logctheta) lctheta <- log(1.e0-theta+eps*max(1.e0-theta))
if(weibull) theta <- theta^(1/shape)
image(y[,,1],col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Observed Image")
image(theta[,,1],col=gray((0:255)/255),zlim=range(y),xaxt="n",yaxt="n")
title(paste("Reconstruction  h=",signif(hakt,3)))
image(bi[,,1],col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Sum of weights")
if(!is.null(u)) cat("bandwidth: ",signif(hakt,3),"   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
if(weibull) theta <- theta^(shape)
hakt <- hakt*hincr
gc()
}
if(weibull) theta <- theta^(1/shape)
} else
{
#   run all iterations in one call
theta <- switch(model,
            Gaussian=.Fortran("gawstri",
                               as.double(y),
                               as.integer(n1),
                               as.integer(n2),
                               as.integer(n3),
                               as.double(hinit),
                               as.double(hincr),
                               as.double(hmax),
                               as.double(lamakt),
                               as.double(eta),
                               theta=as.double(theta),
                               as.double(bi),
                               as.double(ai),
                               as.double(kernl),
                               as.double(kerns),
                               as.double(bi),
                               as.logical(symmetric),
                               as.double(wghts),PACKAGE="aws")$theta,
            Bernoulli=.Fortran("gbertri",
                               as.double(y),
                               as.integer(n1),
                               as.integer(n2),
                               as.integer(n3),
                               as.double(hinit),
                               as.double(hincr),
                               as.double(hmax),
                               as.double(lamakt),
                               as.double(eta),
                               theta=as.double(theta),
                               as.double(ltheta),
                               as.double(lctheta),
                               as.double(bi),
                               as.double(ai),
                               as.double(kernl),
                               as.double(kerns),
                               as.double(bi),
                               as.double(ai),
                               as.logical(symmetric),
                               as.double(wghts),PACKAGE="aws")$theta,
            Poisson=.Fortran("gpoitri",
                              as.double(y),
                              as.integer(n1),
                              as.integer(n2),
                              as.integer(n3),
                              as.double(hinit),
                              as.double(hincr),
                              as.double(hmax),
                              as.double(lamakt),
                              as.double(eta),
                              theta=as.double(theta),
                              as.double(ltheta),
                              as.double(bi),
                              as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.double(bi),
                              as.double(ai),
                              as.logical(symmetric),
                              as.double(wghts),PACKAGE="aws")$theta,
            Exponential=.Fortran("gexptri",
                              as.double(y),
                              as.integer(n1),
                              as.integer(n2),
                              as.integer(n3),
                              as.double(hinit),
                              as.double(hincr),
                              as.double(hmax),
                              as.double(lamakt),
                              as.double(eta),
                              theta=as.double(theta),
                              as.double(ltheta),
                              as.double(bi),
                              as.double(ai),
                              as.double(kernl),
                              as.double(kerns),
                              as.double(bi),
                              as.double(ai),
                              as.logical(symmetric),
                              as.double(wghts),PACKAGE="aws")$theta)
theta <- array(theta, c(n1,n2,n3))
if(weibull) theta <- theta^(1/shape)
}
}
      if( form=="multi" ){
###
###                        multi (nongridded)    p==0 or p==1
###
bi <- numeric(n)
theta <- ai <- numeric(n)
if(NN){
ihinit <- trunc(hinit)
z <- .Fortran("iawsmnn",
              as.integer(n),
              as.double(y),
              as.integer(neighbors[1:ihinit,]),
              as.integer(ihinit),
              as.double(hinit),
              bi=as.double(bi),
              ai=as.double(ai),
              as.double(kernl),PACKAGE="aws")[c("bi","ai")]
bi <- z$bi
ai <- z$ai
if(logtheta) {
bi <- (1-eta)*bi+eta
ai <- (1-eta)*ai+eta*gtheta
}
theta <- ai/bi
if(logtheta) ltheta <- log(theta+eps*max(theta))
if(logctheta) lctheta <- log(1.e0-theta+eps*max(1.e0-theta))
if(!is.null(u)){
if(weibull) theta <- theta^(1/shape)
cat("bandwidth: ",signif(hinit,3),"   MSE: ",
    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(weibull) theta <- theta^(shape)
}
# now run aws-cycle
hakt <- hinit*hincr
while(hakt<=hmax){
ihakt <- min(ihmax,trunc(hakt))
z <- switch(model,
            Gaussian=.Fortran("lawsmnn",
                               as.integer(n),
                               as.double(y),
                               as.integer(neighbors[1:ihakt,]),
                               as.integer(ihakt),
                               as.double(theta),
                               as.double(bi),
                               bi=as.double(bi),
                               as.double(ai),
                               ai=as.double(ai),
                               as.double(lamakt),
                               as.double(hakt),
                               as.double(kernl),
                               as.double(kerns),
                               as.logical(symmetric),PACKAGE="aws")[c("bi","ai")],
              Bernoulli=.Fortran("lbermnn",
                               as.integer(n),
                               as.double(y),
                               as.integer(neighbors[1:ihakt,]),
                               as.integer(ihakt),
                               as.double(theta),
                               as.double(ltheta),
                               as.double(lctheta),
                               as.double(bi),
                               bi=as.double(bi),
                               as.double(ai),
                               ai=as.double(ai),
                               as.double(lamakt),
                               as.double(hakt),
                               as.double(kernl),
                               as.double(kerns),
                               as.logical(symmetric),PACKAGE="aws")[c("bi","ai")],
              Poisson=.Fortran("lpoimnn",
                               as.integer(n),
                               as.double(y),
                               as.integer(neighbors[1:ihakt,]),
                               as.integer(ihakt),
                               as.double(theta),
                               as.double(ltheta),
                               as.double(bi),
                               bi=as.double(bi),
                               as.double(ai),
                               ai=as.double(ai),
                               as.double(lamakt),
                               as.double(hakt),
                               as.double(kernl),
                               as.double(kerns),
                               as.logical(symmetric),PACKAGE="aws")[c("bi","ai")],
              Exponential=.Fortran("lexpmnn",
                               as.integer(n),
                               as.double(y),
                               as.integer(neighbors[1:ihakt,]),
                               as.integer(ihakt),
                               as.double(theta),
                               as.double(ltheta),
                               as.double(bi),
                               bi=as.double(bi),
                               as.double(ai),
                               ai=as.double(ai),
                               as.double(lamakt),
                               as.double(hakt),
                               as.double(kernl),
                               as.double(kerns),
                               as.logical(symmetric),PACKAGE="aws")[c("bi","ai")])
    ai <- (1-eta)*z$ai + eta * ai
    bi <- (1-eta)*z$bi + eta * bi
    theta <- ai/bi
if(logtheta) ltheta <- log(theta+eps*max(theta))
if(logctheta) lctheta <- log(1.e0-theta+eps*max(1.e0-theta))
if(!is.null(u)) {
if(weibull) theta <- theta^(1/shape)
cat("bandwidth: ",signif(hakt,3),"   MSE: ",
    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(weibull) theta <- theta^(shape)
}
hakt <- hakt*hincr
gc()
}
if(weibull) theta <- theta^(1/shape)
} else {
dpd <- 2
if(is.null(hinit)) hinit <- maxdist[dpd]
if(hinit<=meandist[dpd]) hinit <- meandist[dpd]
ihinit <- sum(mindist<=hinit)
z <- .Fortran("iawsmul",
              as.integer(n),
              as.double(y),
              as.integer(neighbors[1:ihinit,]),
              as.double(distmat[1:ihinit,]),
              as.integer(ihinit),
              as.double(hinit),
              bi=as.double(bi),
              ai=as.double(ai),
              as.double(kernl),PACKAGE="aws")[c("bi","ai")]
bi <- z$bi
ai <- z$ai
if(logtheta) {
bi <- (1-eta)*bi+eta
ai <- (1-eta)*ai+eta*gtheta
}
theta <- ai/bi
if(logtheta) ltheta <- log(theta+eps*max(theta))
if(logctheta) lctheta <- log(1.e0-theta+eps*max(1.e0-theta))
if(!is.null(u)) {
if(weibull) theta <- theta^(1/shape)
cat("bandwidth: ",signif(hinit,3),"   MSE: ",mean((theta-u)^2),
    "   MAE: ",mean(abs(theta-u)),"\n")
if(weibull) theta <- theta^(shape)
}
# now run aws-cycle
hakt <- hinit*hincr
while(hakt<=hmax){
ihakt <- sum(maxdist<=hakt)
z <- switch(model,
            Gaussian=.Fortran("lawsmul",
                               as.integer(n),
                               as.double(y),
                               as.integer(neighbors[1:ihakt,]),
                               as.double(distmat[1:ihakt,]),
                               as.integer(ihakt),
                               as.double(theta),
                               as.double(bi),
                               bi=as.double(bi),
                               as.double(ai),
                               ai=as.double(ai),
                               as.double(lamakt),
                               as.double(hakt),
                               as.double(kernl),
                               as.double(kerns),
                               as.logical(symmetric),PACKAGE="aws")[c("bi","ai")],
              Bernoulli=.Fortran("lbermul",
                               as.integer(n),
                               as.double(y),
                               as.integer(neighbors[1:ihakt,]),
                               as.double(distmat[1:ihakt,]),
                               as.integer(ihakt),
                               as.double(theta),
                               as.double(ltheta),
                               as.double(lctheta),
                               as.double(bi),
                               bi=as.double(bi),
                               as.double(ai),
                               ai=as.double(ai),
                               as.double(lamakt),
                               as.double(hakt),
                               as.double(kernl),
                               as.double(kerns),
                               as.logical(symmetric),PACKAGE="aws")[c("bi","ai")],
              Poisson=.Fortran("lpoimul",
                               as.integer(n),
                               as.double(y),
                               as.integer(neighbors[1:ihakt,]),
                               as.double(distmat[1:ihakt,]),
                               as.integer(ihakt),
                               as.double(theta),
                               as.double(ltheta),
                               as.double(bi),
                               bi=as.double(bi),
                               as.double(ai),
                               ai=as.double(ai),
                               as.double(lamakt),
                               as.double(hakt),
                               as.double(kernl),
                               as.double(kerns),
                               as.logical(symmetric),PACKAGE="aws")[c("bi","ai")],
              Exponential=.Fortran("lexpmul",
                               as.integer(n),
                               as.double(y),
                               as.integer(neighbors[1:ihakt,]),
                               as.double(distmat[1:ihakt,]),
                               as.integer(ihakt),
                               as.double(theta),
                               as.double(ltheta),
                               as.double(bi),
                               bi=as.double(bi),
                               as.double(ai),
                               ai=as.double(ai),
                               as.double(lamakt),
                               as.double(hakt),
                               as.double(kernl),
                               as.double(kerns),
                               as.logical(symmetric),PACKAGE="aws")[c("bi","ai")])
    ai <- (1-eta)*z$ai + eta * ai
    bi <- (1-eta)*z$bi + eta * bi
    theta <- ai/bi
if(logtheta) ltheta <- log(theta+eps*max(theta))
if(logctheta) lctheta <- log(1.e0-theta+eps*max(1.e0-theta))
if(!is.null(u)) {
if(weibull) theta <- theta^(1/shape)
cat("bandwidth: ",signif(hakt,3),"   MSE: ",
    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(weibull) theta <- theta^(shape)
}
hakt <- hakt*hincr
gc()
}
if(weibull) theta <- theta^(1/shape)
}
}
###                                                                       
###            end cases                                                  
###                                                                       
z<-list(theta=theta,y=y,x=x,call=args)
class(z)<-switch(model,Gaussian="laws.gaussian",Bernoulli="laws.bernoulli",Exponential="laws.exponential",
                 Poisson="laws.poisson",Weibull="laws.weibull",Volatility="laws.vola")
z
}
#
#    R - function  aws  for  Adaptive Weights Smoothing (AWS)
#    in regression models with additive sub-Gaussian errors
#    local constant and local polynomial approach
#
#    Copyright (C) 2002 Weierstrass-Institut f?r
#                       Angewandte Analysis und Stochastik (WIAS)
#
#    Author:  J?rg Polzehl
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
#  USA.
#
awsh <- function(y,x=NULL,p=0,sigma2=NULL,qlambda=NULL,eta=0.5,tau=NULL,
                lkern="Triangle",hinit=NULL,hincr=NULL,hmax=100,hmaxs=2*hmax,
                u=NULL,graph=FALSE,demo=FALSE,symmetric=NULL,conf=FALSE,
                qconf=.95,alpha=2)
{
#
#    first check arguments and initialize
#
args <- match.call()
if(p>0) symmetric <- FALSE
if(is.null(symmetric)) symmetric <- FALSE
if(is.null(qlambda)) {
if(p>5) return("no default for qlambda for p>5")
qlambda <- switch(p+1,.966,.92,.92,.92,.92,.92)
if(symmetric==TRUE) qlambda <- .985
}
if(conf) qconf<-qnorm(1-(1-qconf)/2)
if(qlambda>=1 || qlambda<.6) return("Inappropriate value of qlambda")
if(eta<0 || eta>=1) return("Inappropriate value of eta")
if(demo&& !graph) graph <- TRUE
taudefault <- NULL
# now check which procedure is appropriate
gridded <- is.null(x)
if(gridded){
#  this is the version on a grid
dy <- dim(y)
if(is.null(dy)) {
   form <- "uni"
   ddim  <- 1
   n <- length(y)
   dp1 <- p+1
}
if(length(dy)>1){
return("this is heteroscedastics univariate regression only")
}
} else {
# not gridded
return("currently this is heteroscedastics univariate regression on a grid only")
ddim <- 1
if(is.null(dx)) {
#
#    order data by order of x
#
    form <- "uni"
    n <- length(x)
    if(n!=length(y)) return("incompatible lengths of x and y")
    ox <- order(x)
    x <- x[ox]
    y <- y[ox]
    dp1 <- p+1
}
if(length(y)!=n) return("incompatible dimensions of x and y")
   #
   #
   }
#
#     now set hincr, sigma2 if not provided
#
if(is.null(hincr)) hincr <- 1.25^(1/ddim)
if(is.null(sigma2)){
#
#    heteroscedastic regression estimation of sigma2
#
z<-diff(y)/sqrt(2)
sigma2<-laws(z,hmax=hmaxs,model="Volatility")$theta^2
sigma2<-(sigma2[c(1,1:(n-1))]+sigma2[c(1:(n-1),n-1)])/2
}
if(length(sigma2)==1) sigma2<-rep(sigma2,n)
#
#    now generate kernel on a grid
#
getkern <- function(x,kern)
switch(kern,Triangle=pmax(0,(1-x)),
            Quadratic=pmax(0,(1-x))^2,
            Cubic=pmax(0,(1-x))^3,
            Uniform=as.numeric(abs(x)<=1),
            Exponential=exp(-5*x),
            {
            cat("Triangle kernel is used as default\n");
            pmax(0,(1-x))
            })
# this gives a discretized kern on [0,1.01] for use of (xij^2) as argument
#  length 102  (last element to avoid numerical problems if x(j)==xi+-h)
kernl <- getkern(seq(0,1.01,.01),lkern)
kerns <- getkern(seq(0,1.01,.01),"Exponential")
#
#   get lambda as quantile of appropriate chisq, rescale to be consistent
# with the paper and multiply by 2*sigma2 to get 2*sigma2*lambda in lamakt
#
lamakt <- 10*qchisq(qlambda,dp1)
#
#  set tau in case it may be necessary
#
if(form=="uni") taudefault <- 1.5*3^p else if(is.null(taudefault))
                                          taudefault <- switch(p+1,1,13.5,150)
if(is.null(tau)) tau <- taudefault
#  rescale tau for use in scaled kernel to be consistent with the paper
tau <- 6*tau
#
#    now select the correct aws-procedure
#
#   cases:    gridded      uni   p=0
#             !gridded     uni   p>=0
#             gridded      bi    p=0
#             gridded      bi    p=1,2
#             gridded      tri   p=0
#             !gridded     multi p=0,1
#             !gridded     multi p=0,1  Nearest-Neighbor
#
if(gridded &&  form=="uni" && p==0){
###
###              gridded     uni    p=0
###
###           this should run a little faster than the nongridded version
###
bi <- bi2 <- ai <- theta <- numeric(n)
if(is.null(hinit)||hinit<1) hinit <- 1
#  first initialize
z <- .Fortran("ihawsuni",
              as.double(y),
              as.integer(n),
              as.double(hinit),
              bi=as.double(bi),
              bi2=as.double(bi2),
              ai=as.double(ai),
              as.double(kernl),
              as.double(sigma2),PACKAGE="aws")[c("ai","bi","bi2")]
bi <- z$bi
bi2 <- z$bi2
ai <- z$ai
theta <- ai/bi
if(graph){
par(mfrow=c(1,1),mar=c(3,3,2.5,.5),mgp=c(2,1,0))
plot(y,ylim=range(y,theta),col=3)
if(!is.null(u)) lines(u,col=2)
lines(theta,lwd=2)
if(conf){
lines(theta+qconf/sqrt(bi),col=4)
lines(theta-qconf/sqrt(bi),col=4)
}
title(paste("Reconstruction  h=",signif(hinit,3)))
if(!is.null(u)) cat("bandwidth: ",signif(hinit,3),"   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
}
# now run aws-cycle
hakt <- hinit*hincr
if(graph){
#
#   run single steps to display intermediate results
#
while(hakt<=hmax){
z <- .Fortran("lhawsuni",
              as.double(y),
              as.integer(n),
              as.double(hakt),
              as.double(lamakt),
              as.double(theta),
              bi=as.double(bi),
              bi2=as.double(bi),
              ai=as.double(ai),
              as.double(kernl),
              as.double(kerns),
              as.logical(symmetric),
              as.double(sigma2),PACKAGE="aws")[c("ai","bi","bi2")]
ai <- (1-eta)*z$ai + eta * ai
bi <- (1-eta)*z$bi + eta * bi
bi2 <- (1-eta)*z$bi2 + eta * bi2
#  this is correct only if wij = 0 or 1,  or if eta = 0, or if the weights have stabilized
#  but should deliver a reasonable approximation at the end of the iteration process
theta  <- ai / bi
sdtheta<-sqrt(bi2)/bi
plot(y,ylim=range(y,theta),col=3)
if(!is.null(u)) lines(u,col=2)
lines(theta,lwd=2)
if(conf){
lines(theta+qconf*sdtheta,col=4)
lines(theta-qconf*sdtheta,col=4)
}
title(paste("Reconstruction  h=",signif(hakt,3)))
cat("bandwidth: ",signif(hakt,3),
                    "PMSE",mean((theta-y)^2+alpha*bi2/(bi-1/sigma2)^2),mean((theta-y)^2+alpha/(bi-1/sigma2)))
if(!is.null(u)) cat("   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)))
cat("\n")
if(demo) readline("Press return")
hakt <- hakt*hincr
gc()
}
} else
{
#   run all iterations in one call
z <- .Fortran("ghawsuni",
              as.double(y),
              as.integer(n),
              as.double(hinit),
              as.double(hincr),
              as.double(hmax),
              as.double(lamakt),
              as.double(eta),
              theta=as.double(theta),
              bi=as.double(bi),
              bi2=as.double(bi),
              as.double(ai),
              as.double(kernl),
              as.double(kerns),
              as.double(bi),
              as.logical(symmetric),
              as.double(sigma2),PACKAGE="aws")[c("theta","bi","bi2")]
theta<-z$theta
sdtheta<-sqrt(z$bi2)/z$bi
}
}
      if( form=="uni" && (p>0 || (!gridded && p==0)) ){
###
###                        uni     p>=0
###
if(gridded) x <- 1:length(y)
dp1 <- p+1
dp2 <- p+dp1
bi <- matrix(0,dp2,n)
theta <- ai <- matrix(0,dp1,n)
dxp <- max(diff(x,p+1))*(1+1.e-8)
if(is.null(hinit)||hinit<dxp) hinit <- dxp
#   generate binomial coefficients
cb <- matrix(0,dp1,dp1)
for(i in (1:dp1)) cb[i:dp1,i] <- choose((i:dp1)-1,i-1)
#  first initialize
z <- .Fortran("iphawsun",
              as.integer(n),
              as.integer(dp1),
              as.integer(dp2),
              as.double(x),
              as.double(y),
              as.double(hinit),
              bi=as.double(bi),
              ai=as.double(ai),
              theta=as.double(theta),
              as.double(kernl),
              double(dp1*dp1),
              as.double(sigma2),PACKAGE="aws")[c("ai","bi","theta")]
theta <- matrix(z$theta,dp1,n)
bi <- bi0 <- matrix(z$bi,dp2,n)
ai <- z$ai
if(graph){
par(mfrow=c(1,2),mar=c(3,3,2.5,.5),mgp=c(2,1,0))
plot(x,y,ylim=range(y,theta[1,]),col=3)
if(!is.null(u)) lines(x,u,col=2)
lines(x,theta[1,],lwd=2)
title(paste("Estimated function  h=",signif(hinit,3)))
plot(x,theta[2,],type="l")
title("Estimated first derivative")
}
if(!is.null(u))
cat("bandwidth: ",signif(hinit,3),"   MSE: ",mean((theta[1,]-u)^2),
      "   MAE: ",mean(abs(theta[1,]-u)),"\n")
if(demo) readline("Press return")
# now run aws-cycle
hakt <- hinit*hincr
while(hakt<=hmax){
z <- .Fortran("lphawsun",
              as.integer(n),
              as.integer(dp1),
              as.integer(dp2),
              as.double(x),
              as.double(y),
              as.double(theta),
              as.double(bi),
              bi=as.double(bi),
              as.double(bi0[1,]),
              bi0=as.double(bi0),
              ai=as.double(ai),
              as.double(lamakt),
              as.double(tau),
              as.double(hakt),
              as.double(kernl),
              as.double(kerns),
              as.double(cb),
              double(dp1*dp1),
              double(dp1*dp1),
              double(dp1*dp1),
              double(dp1),
              double(dp1),
              double(dp2),
              double(dp1),
              as.logical(symmetric),
              as.double(sigma2),PACKAGE="aws")[c("ai","bi","bi0")]
    ai <- (1-eta)*z$ai + eta * ai
    bi <- matrix((1-eta)*z$bi + eta * bi,dp2,n)
    bi0 <- (1-eta)*z$bi0 + eta * bi0
    z <- .Fortran("mphawsun",
                  as.integer(n),
                  as.integer(dp1),
                  as.integer(dp2),
                  as.double(ai),
                  as.double(bi),
                  theta=as.double(theta),
                  double(dp1*dp1),
                  sdtheta=double(dp1*n),PACKAGE="aws")[c("theta","sdtheta")]
theta<-matrix(z$theta,dp1,n)
sdtheta<-sqrt(matrix(z$sdtheta,dp1,n))
#  sdtheta contains diaganol elements of the inverse of bi
#  this is correct if weights are 0 or 1, i.e. at the end of the iteration process
if(graph){
plot(x,y,ylim=range(y,theta[1,]),col=3)
if(!is.null(u)) lines(x,u,col=2)
lines(x,theta[1,],lwd=2)
if(conf){
lines(theta[1,]+qconf*sdtheta[1,],col=4)
lines(theta[1,]-qconf*sdtheta[1,],col=4)
}
title(paste("Reconstruction  h=",signif(hakt,3)))
if(conf) ylim<-range(theta[2,]+qconf*sqrt(sdtheta[2,]),theta[2,]-qconf*sqrt(sdtheta[2,])) else ylim<-range(theta[2,])
plot(x,theta[2,],type="l",ylim=ylim)
if(conf){
lines(theta[2,]+qconf*sdtheta[2,],col=4)
lines(theta[2,]-qconf*sdtheta[2,],col=4)
}
title("Estimated first derivative")
}
if(!is.null(u))
cat("bandwidth: ",signif(hakt,3),"   MSE: ",mean((theta[1,]-u)^2),
    "   MAE: ",mean(abs(theta[1,]-u)),"\n")
if(demo) readline("Press return")
hakt <- hakt*hincr
gc()
}
}
###
###            end cases
###
z<-list(theta=theta,sdtheta=sdtheta,y=y,x=x,call=args)
class(z)<-"aws"
z
}
#
#    R - function  aws  for  Adaptive Weights Smoothing (AWS)
#    in regression models with additive sub-Gaussian errors               
#    local constant and local polynomial approach                         
#
#    Copyright (C) 2002 Weierstrass-Institut fr                          
#                       Angewandte Analysis und Stochastik (WIAS)         
#
#    Author:  Jrg Polzehl                                                
#
#  This program is free software; you can redistribute it and/or modify   
#  it under the terms of the GNU General Public License as published by   
#  the Free Software Foundation; either version 2 of the License, or      
#  (at your option) any later version.                                    
#
#  This program is distributed in the hope that it will be useful,        
#  but WITHOUT ANY WARRANTY; without even the implied warranty of         
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the          
#  GNU General Public License for more details.                           
#
#  You should have received a copy of the GNU General Public License      
#  along with this program; if not, write to the Free Software            
#  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,  
#  USA.
#
aws <- function(y,x=NULL,p=0,sigma2=NULL,qlambda=NULL,eta=0.5,tau=NULL,
                lkern="Triangle",hinit=NULL,hincr=NULL,hmax=10,NN=FALSE,
                u=NULL,graph=FALSE,demo=FALSE,symmetric=NULL,wghts=NULL)
{ 
#
#    first check arguments and initialize                                 
#
args <- match.call()
if(p>0) symmetric <- FALSE
if(is.null(symmetric)) symmetric <- FALSE 
if(is.null(qlambda)) {
if(p>5) return("no default for qlambda for p>5")
qlambda <- switch(p+1,.966,.92,.92,.92,.92,.92)
if(symmetric==TRUE) qlambda <- .985
}
if(qlambda>=1 || qlambda<.6) return("Inappropriate value of qlambda")
if(eta<0 || eta>=1) return("Inappropriate value of eta")
if(demo&& !graph) graph <- TRUE
taudefault <- NULL
# now check which procedure is appropriate
gridded <- is.null(x)
if(gridded){
#  this is the version on a grid
if(is.null(hinit)||hinit<=0) hinit <- 1
dy <- dim(y)
if(is.null(dy)) {
   form <- "uni"
   ddim  <- 1
   n <- length(y)
   dp1 <- p+1
}
if(length(dy)==2){
   form <- "bi"
   ddim  <- 2
if(is.null(wghts)) wghts<-c(1,1)
hinit<-hinit/wghts[1]
hmax<-hmax/wghts[1]
wghts<-(wghts[2]/wghts[1])^2
#  only use a wght for the second component
n1 <- dy[1]
n2 <- dy[2]
n <- n1*n2
if(p>2) return("bivariate aws on a grid is not implemented for p>2")
dp1 <- switch(p+1,1,3,6)
}
if(length(dy)==3){
   form <- "tri"
   ddim  <- 3
if(is.null(wghts)) wghts<-c(1,1,1)
hinit<-hinit/wghts[1]
hmax<-hmax/wghts[1]
wghts<-(wghts[2:3]/wghts[1])^2
#  only use a wght for the second and third component
n1 <- dy[1]
n2 <- dy[2]
n3 <- dy[3]
n <- n1*n2*n3
dp1 <- 3*p+1
}
if(length(dy)>3)
   return("AWS for more than 3 dimensional grids is not implemented")
} else {
# not gridded
dx <- dim(x)
ddim <- 1
if(is.null(dx)) {
#
#    order data by order of x
#
    form <- "uni"
    n <- length(x)
    if(n!=length(y)) return("incompatible lengths of x and y")
    ox <- order(x)
    x <- x[ox]
    y <- y[ox]
    dp1 <- p+1
}else {
   px <- dx[1]
   n <- dx[2]
   if(p>1) {
      p <- 1
      cat("p is set to 1, the maximal polynomial degree implemented")
      }
   form <- "multi"
   if(n!=length(y)) return("incompatible dimensions of x and y")
   if(is.null(wghts)||length(wghts)!=px) wghts <- rep(1,px)
   dp1 <- 1+p*px
   taudefault <- 1.5*3^px
#
#  now generate matrix of nearest neighbors
#  hmax is interpreted as maximal number of neighbors
#
   if(NN){
   ihmax <- trunc(hmax)
   if(ihmax>n) ihmax <- n
   neighbors <- matrix(0,ihmax,n)
   for (i in 1:n) {
      if(px==1) adist <- (x-x[i])^2 else adist <- wghts%*%((x-x[,i])^2)
      neighbors[,i] <- order(adist)[1:ihmax]
      }
   } else {
   ihmax <- n
   ddim <- px
   neighbors <- distmat <- matrix(0,n,n)
   for (i in 1:n) {
      if(px==1) adist <- (x-x[i])^2 else adist <- wghts%*%((x-x[,i])^2)
      od <- order(adist)
      distmat[,i] <- adist[od]
      neighbors[,i] <- od
      }
#  now reduce memory used to whats needed                                 
   gc()
   distmat <- sqrt(distmat)
   maxdist <- apply(distmat,1,max)
   ihmax <- sum(maxdist<=hmax)
   distmat <- distmat[1:ihmax,]
   neighbors <- neighbors[1:ihmax,]
   maxdist <- maxdist[1:ihmax]
   gc()
   }
   }
   if(length(y)!=n) return("incompatible dimensions of x and y")
   #
   #
   }
#
#     now set hincr, sigma2 if not provided                               
#
if(is.null(hincr)) hincr <- 1.25^(1/ddim)  
if(is.null(sigma2)){
IQRdiff <- function(y) IQR(diff(y))/1.908
sigma2 <- IQRdiff(y)^2
}
#
#    now generate kernel on a grid                                        
#
getkern <- function(x,kern)
switch(kern,Triangle=pmax(0,(1-x)),
            Quadratic=pmax(0,(1-x))^2,
            Cubic=pmax(0,(1-x))^3,
            Uniform=as.numeric(abs(x)<=1),
            Exponential=exp(-5*x),
            {
            cat("Triangle kernel is used as default\n");
            pmax(0,(1-x))
            })
# this gives a discretized kern on [0,1.01] for use of (xij^2) as argument
#  length 102  (last element to avoid numerical problems if x(j)==xi+-h)  
kernl <- getkern(seq(0,1.01,.01),lkern)
kerns <- getkern(seq(0,1.01,.01),"Exponential")
#
#   get lambda as quantile of appropriate chisq, rescale to be consistent 
# with the paper and multiply by 2*sigma2 to get 2*sigma2*lambda in lamakt
#
lamakt <- 10*qchisq(qlambda,dp1)*sigma2
#
#  set tau in case it may be necessary                                    
#
if(form=="uni") taudefault <- 1.5*3^p else if(is.null(taudefault)) 
                                          taudefault <- switch(p+1,1,13.5,150)
if(is.null(tau)) tau <- taudefault
#  rescale tau for use in scaled kernel to be consistent with the paper   
tau <- 6*tau
#
#    now select the correct aws-procedure                                 
#
#   cases:    gridded      uni   p=0                                      
#             !gridded     uni   p>=0                                     
#             gridded      bi    p=0                                      
#             gridded      bi    p=1,2                                    
#             gridded      tri   p=0                                      
#             !gridded     multi p=0,1                                    
#             !gridded     multi p=0,1  Nearest-Neighbor                  
#
if(gridded &&  form=="uni" && p==0){
###                                                                       
###              gridded     uni    p=0                                   
###                                                                       
###           this should run a little faster than the nongridded version
###                                                                       
bi <- ai <- theta <- numeric(n)
#  first initialize
z <- .Fortran("iawsuni",
              as.double(y),
              as.integer(n),
              as.double(hinit),
              bi=as.double(bi),
              ai=as.double(ai),
              as.double(kernl),PACKAGE="aws")[c("ai","bi")]
bi <- z$bi
ai <- z$ai
theta <- ai/bi
if(graph){
par(mfrow=c(1,2),mar=c(3,3,2.5,.5),mgp=c(2,1,0))
plot(y,ylim=range(y,theta),col=3)
if(!is.null(u)) lines(u,col=2)
lines(theta,lwd=2)
title(paste("Reconstruction  h=",signif(hinit,3)))
plot(bi,type="l")
title("Sum of weights")
if(!is.null(u)) cat("bandwidth: ",signif(hinit,3),"   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
}
# now run aws-cycle
hakt <- hinit*hincr
if(graph){
#
#   run single steps to display intermediate results
#
while(hakt<=hmax){
z <- .Fortran("lawsuni",
              as.double(y),
              as.integer(n),
              as.double(hakt),
              as.double(lamakt),
              as.double(theta),
              bi=as.double(bi),
              ai=as.double(ai),
              as.double(kernl),
              as.double(kerns),
              as.logical(symmetric),PACKAGE="aws")[c("ai","bi")]
ai <- (1-eta)*z$ai + eta * ai
bi <- (1-eta)*z$bi + eta * bi
theta  <- ai / bi
plot(y,ylim=range(y,theta),col=3)
if(!is.null(u)) lines(u,col=2)
lines(theta,lwd=2)
title(paste("Reconstruction  h=",signif(hakt,3)))
plot(bi,type="l")
title("Sum of weights")
if(!is.null(u)) cat("bandwidth: ",signif(hakt,3),"   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
hakt <- hakt*hincr
gc()
}
} else
{
#   run all iterations in one call
theta <- .Fortran("gawsuni",
              as.double(y),
              as.integer(n),
              as.double(hinit),
              as.double(hincr),
              as.double(hmax),
              as.double(lamakt),
              as.double(eta),
              theta=as.double(theta),
              as.double(bi),
              as.double(ai),
              as.double(kernl),
              as.double(kerns),
              as.double(bi),
              as.logical(symmetric),PACKAGE="aws")$theta
}
}
      if( form=="uni" && (p>0 || (!gridded && p==0)) ){
###
###                        uni     p>=0
###
if(gridded) x <- 1:length(y)
dp1 <- p+1
dp2 <- p+dp1
bi <- matrix(0,dp2,n)
theta <- ai <- matrix(0,dp1,n)
dxp <- max(diff(x,p+1))*(1+1.e-8)
if(is.null(hinit)||hinit<dxp) hinit <- dxp
#   generate binomial coefficients
cb <- matrix(0,dp1,dp1)
for(i in (1:dp1)) cb[i:dp1,i] <- choose((i:dp1)-1,i-1)
#  first initialize
z <- .Fortran("ipawsuni",
              as.integer(n),
              as.integer(dp1),
              as.integer(dp2),
              as.double(x),
              as.double(y),
              as.double(hinit),
              bi=as.double(bi),
              ai=as.double(ai),
              theta=as.double(theta),
              as.double(kernl),
              double(dp1*dp1),PACKAGE="aws")[c("ai","bi","theta")]
theta <- matrix(z$theta,dp1,n)
bi <- bi0 <- matrix(z$bi,dp2,n)
ai <- z$ai
if(graph){
par(mfrow=c(1,2),mar=c(3,3,2.5,.5),mgp=c(2,1,0))
plot(x,y,ylim=range(y,theta[1,]),col=3)
if(!is.null(u)) lines(x,u,col=2)
lines(x,theta[1,],lwd=2)
title(paste("Reconstruction  h=",signif(hinit,3)))
plot(x,bi[1,],type="l")
title("Sum of weights")
}
if(!is.null(u))
cat("bandwidth: ",signif(hinit,3),"   MSE: ",mean((theta[1,]-u)^2),
      "   MAE: ",mean(abs(theta[1,]-u)),"\n")
if(demo) readline("Press return")
# now run aws-cycle
hakt <- hinit*hincr
while(hakt<=hmax){
z <- .Fortran("lpawsuni",
              as.integer(n),
              as.integer(dp1),
              as.integer(dp2),
              as.double(x),
              as.double(y),
              as.double(theta),
              as.double(bi),
              bi=as.double(bi),
              as.double(bi0[1,]),
              bi0=as.double(bi0),
              ai=as.double(ai),
              as.double(lamakt),
              as.double(tau),
              as.double(hakt),
              as.double(kernl),
              as.double(kerns),
              as.double(cb),
              double(dp1*dp1),
              double(dp1*dp1),
              double(dp1*dp1),
              double(dp1),
              double(dp1),
              double(dp2),
              double(dp1),
              as.logical(symmetric),PACKAGE="aws")[c("ai","bi","bi0")]
    ai <- (1-eta)*z$ai + eta * ai
    bi <- matrix((1-eta)*z$bi + eta * bi,dp2,n)
    bi0 <- (1-eta)*z$bi0 + eta * bi0
    theta <- matrix(.Fortran("mpawsuni",
                  as.integer(n),
                  as.integer(dp1),
                  as.integer(dp2),
                  as.double(ai),
                  as.double(bi),
                  theta=as.double(theta),
                  double(dp1*dp1),PACKAGE="aws")$theta,dp1,n)
if(graph){
plot(x,y,ylim=range(y,theta[1,]),col=3)
if(!is.null(u)) lines(x,u,col=2)
lines(x,theta[1,],lwd=2)
title(paste("Reconstruction  h=",signif(hakt,3)))
plot(x,bi[1,],type="l")
title("Sum of weights")
}
if(!is.null(u)) 
cat("bandwidth: ",signif(hakt,3),"   MSE: ",mean((theta[1,]-u)^2),
    "   MAE: ",mean(abs(theta[1,]-u)),"\n")
if(demo) readline("Press return")
hakt <- hakt*hincr
gc()
}
}
      if(gridded &&  form=="bi" && p==0){
###                                                                       
###             gridded      bi   p=0                                     
###                                                                       
bi <- ai <- theta <- matrix(0,n1,n2)
if(is.null(hinit)||hinit<1) hinit <- 1
#  first initialize                                                       
z <- .Fortran("iawsbi",
              as.double(y),
              as.integer(n1),
              as.integer(n2),
              as.double(hinit),
              bi=as.double(bi),
              ai=as.double(ai),
              as.double(kernl),
              as.double(wghts),PACKAGE="aws")[c("ai","bi")]
bi <- matrix(z$bi,n1,n2)
ai <- matrix(z$ai,n1,n2)
theta <- ai/bi
if(graph){
par(mfrow=c(1,3),mar=c(1,1,3,.25),mgp=c(2,1,0))
image(y,col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Observed Image")
image(theta,col=gray((0:255)/255),zlim=range(y),xaxt="n",yaxt="n")
title(paste("Reconstruction  h=",signif(hinit,3)))
image(bi,col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Sum of weights")
if(!is.null(u)) cat("bandwidth: ",signif(hinit,3),"   MSE: ",
      mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
}
# now run aws-cycle
hakt <- hinit*hincr
if(graph){
#
#   run single steps to display intermediate results
#
while(hakt<=hmax){
z <- .Fortran("lawsbi",
              as.double(y),
              as.integer(n1),
              as.integer(n2),
              as.double(hakt),
              as.double(lamakt),
              as.double(theta),
              bi=as.double(bi),
              ai=as.double(ai),
              as.double(kernl),
              as.double(kerns),
              as.logical(symmetric),
              as.double(wghts),PACKAGE="aws")[c("ai","bi")]
ai <- (1-eta)*z$ai + eta * ai
bi <- matrix((1-eta)*z$bi + eta * bi,n1,n2)
theta  <- matrix(ai / bi, n1, n2)
image(y,col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Observed Image")
image(theta,col=gray((0:255)/255),zlim=range(y),xaxt="n",yaxt="n")
title(paste("Reconstruction  h=",signif(hakt,3)))
image(bi,col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Sum of weights")
if(!is.null(u)) cat("bandwidth: ",signif(hakt,3),"   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
hakt <- hakt*hincr
gc()
}
} else
{
#   run all iterations in one call
theta <- .Fortran("gawsbi",
              as.double(y),
              as.integer(n1),
              as.integer(n2),
              as.double(hinit),
              as.double(hincr),
              as.double(hmax),
              as.double(lamakt),
              as.double(eta),
              theta=as.double(theta),
              as.double(bi),
              as.double(ai),
              as.double(kernl),
              as.double(kerns),
              as.double(bi),
              as.logical(symmetric),
              as.double(wghts),PACKAGE="aws")$theta
theta <- matrix(theta,n1,n2)
}
}
      if(gridded &&  form=="bi" && p>0){
###
###             gridded      bi    p=1,2
###
dp1 <- switch(p+1,1,3,6)
dp2 <- switch(p+1,1,6,15)
if(symmetric) dpm <- dp1*(dp1+1)/2 else dpm <- 1
bi <- matrix(0,dp2,n)
theta <- ai <- matrix(0,dp1,n)
ind <- matrix(c(1, 2, 3, 4, 5, 6,
                2, 4, 5, 7, 8, 9,
                3, 5, 6, 8, 9,10,
                4, 7, 8,11,12,13,
                5, 8, 9,12,13,14,
                6, 9,10,13,14,15),6,6)[1:dp1,1:dp1]
if(is.null(hinit)||hinit<p+1.25) hinit <- p+1.25
#  first initialize
z <- .Fortran("ipawsbi",
              as.integer(n1),
              as.integer(n2),
              as.integer(dp1),
              as.integer(dp2),
              as.double(y),
              as.double(hinit),
              bi=as.double(bi),
              ai=as.double(ai),
              theta=as.double(theta),
              as.double(kernl),
              double(dp1*dp1),
              double(dp2),
              double(dp1),
              as.integer(ind),
              as.double(wghts),PACKAGE="aws")[c("ai","bi","theta")]
theta <- array(z$theta,c(dp1,n1,n2))
bi <- bi0 <- array(z$bi,c(dp2,n1,n2))
ai <- z$ai
if(graph){
par(mfrow=c(1,3),mar=c(1,1,3,.25),mgp=c(2,1,0))
image(y,col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Observed Image")
image(theta[1,,],col=gray((0:255)/255),zlim=range(y),xaxt="n",yaxt="n")
title(paste("Reconstruction  h=",signif(hinit,3)))
image(bi[1,,],col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Sum of weights")
}
if(!is.null(u))
cat("bandwidth: ",signif(hinit,3),"   MSE: ",mean((theta[1,,]-u)^2),
    "   MAE: ",mean(abs(theta[1,,]-u)),"\n")
if(demo) readline("Press return")
# now run aws-cycle                                                         
hakt <- hinit*hincr
while(hakt<=hmax){
z <- .Fortran("lpawsbi",
              as.integer(n1),
              as.integer(n2),
              as.integer(dp1),
              as.integer(dp2),
              as.double(y),
              as.double(theta),
              as.double(bi),
              bi=as.double(bi),
              bi0=as.double(bi0),
              ai=as.double(ai),
              as.double(lamakt),
              as.double(tau),
              as.double(hakt),
              as.double(kernl),
              as.double(kerns),
              double(dp1*dp1),
              double(dp1*dp1),
              double(dp1*dp1),
              double(dp1),
              double(dp1),
              double(dp2),
              double(dp2),
              double(dp2),
              double(dp1),
              as.logical(symmetric),
              as.integer(ind),
              as.double(wghts),PACKAGE="aws")[c("ai","bi","bi0")]
    ai <- (1-eta)*z$ai + eta * ai
    bi <- array((1-eta)*z$bi + eta * bi,c(dp2,n1,n2))
    bi0 <- (1-eta)*z$bi0 + eta * bi0
    theta <- array(.Fortran("mpawsbi",
                  as.integer(n),
                  as.integer(dp1),
                  as.integer(dp2),
                  as.double(ai),
                  as.double(bi),
                  theta=as.double(theta),
                  double(dp1*dp1),
                  as.integer(ind),PACKAGE="aws")$theta,c(dp1,n1,n2))
if(graph){
par(mfrow=c(1,3),mar=c(1,1,3,.25),mgp=c(2,1,0))
image(y,col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Observed Image")
image(theta[1,,],col=gray((0:255)/255),zlim=range(y),xaxt="n",yaxt="n")
title(paste("Reconstruction  h=",signif(hakt,3)))
image(bi[1,,],col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Sum of weights")
}
if(!is.null(u)) 
   cat("bandwidth: ",signif(hakt,3),"   MSE: ",mean((theta[1,,]-u)^2),
       "   MAE: ",mean(abs(theta[1,,]-u)),"\n")
hakt <- hakt*hincr
gc()
}
}
      if(gridded &&  form=="tri" && p==0){
###                                                                       
###             gridded      tri   p=0                                    
###                                                                       
if(is.null(hinit)||hinit<1) hinit <- 1
#  first initialize
z <- .Fortran("iawstri",
              as.double(y),
              as.integer(n1),
              as.integer(n2),
              as.integer(n3),
              as.double(hinit),
              bi=double(n),
              ai=double(n),
              as.double(kernl),
              as.double(wghts),PACKAGE="aws")[c("ai","bi")]
bi <- array(z$bi,c(n1,n2,n3))
theta <- array(z$ai/bi,c(n1,n2,n3))
if(graph){
par(mfrow=c(1,3),mar=c(1,1,3,.25),mgp=c(2,1,0))
image(y[,,1],col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Observed Image")
image(theta[,,1],col=gray((0:255)/255),zlim=range(y),xaxt="n",yaxt="n")
title(paste("Reconstruction  h=",signif(hinit,3)))
image(bi[,,1],col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Sum of weights")
if(!is.null(u)) cat("bandwidth: ",signif(hinit,3),"   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
}
# now run aws-cycle
hakt <- hinit*hincr
if(graph){
#
#   run single steps to display intermediate results
#
while(hakt<=hmax){
z <- .Fortran("lawstri",
              as.double(y),
              as.integer(n1),
              as.integer(n2),
              as.integer(n3),
              as.double(hakt),
              as.double(lamakt),
              as.double(theta),
              bi=as.double(bi),
              ai=double(n),
              as.double(kernl),
              as.double(kerns),
              as.logical(symmetric),
              as.double(wghts),PACKAGE="aws")[c("ai","bi")]
ai <- (1-eta)*z$ai + eta * bi * theta
bi <- array((1-eta)*z$bi + eta * bi,c(n1,n2,n3))
theta  <- array(ai / bi, c(n1,n2,n3))
rm(ai)
gc()
image(y[,,1],col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Observed Image")
image(theta[,,1],col=gray((0:255)/255),zlim=range(y),xaxt="n",yaxt="n")
title(paste("Reconstruction  h=",signif(hakt,3)))
image(bi[,,1],col=gray((0:255)/255),xaxt="n",yaxt="n")
title("Sum of weights")
if(!is.null(u)) cat("bandwidth: ",signif(hakt,3),"   MSE: ",
                    mean((theta-u)^2),"   MAE: ",mean(abs(theta-u)),"\n")
if(demo) readline("Press return")
hakt <- hakt*hincr
gc()
}
} else
{
#   run all iterations in one call
theta <- array(.Fortran("gawstri",
              as.double(y),
              as.integer(n1),
              as.integer(n2),
              as.integer(n3),
              as.double(hinit),
              as.double(hincr),
              as.double(hmax),
              as.double(lamakt),
              as.double(eta),
              theta=as.double(theta),
              as.double(bi),
              double(n),
              as.double(kernl),
              as.double(kerns),
              as.double(bi),
              as.logical(symmetric),
              as.double(wghts),PACKAGE="aws")$theta, c(n1,n2,n3))
}
}
      if( form=="multi" ){
###
###                        multi (nongridded)    p==0 or p==1
###
dp1 <- 1+p*px
dp2 <- dp1*(dp1+1)/2
bi <- matrix(0,dp2,n)
theta <- ai <- matrix(0,dp1,n)
if(NN){
if(is.null(hinit)||hinit<(p+1)) hinit <- p+1
info <- 1
while(info>0){
ihinit <- trunc(hinit)
z <- .Fortran("ipawsmnn",
              as.integer(n),
              as.integer(px),
              as.integer(dp1),
              as.integer(dp2),
              as.double(x),
              as.double(y),
              as.integer(neighbors[1:ihinit,]),
              as.integer(ihinit),
              as.double(hinit),
              bi=as.double(bi),
              ai=as.double(ai),
              theta=as.double(theta),
              as.double(kernl),
              double(dp1*dp1),
              double(dp1),
              info=as.integer(info),PACKAGE="aws")[c("ai","bi","theta","info")]
info <- z$info
hinit <- hinit+1
}
theta <- matrix(z$theta,dp1,n)
bi <- bi0 <- matrix(z$bi,dp2,n)
ai <- z$ai
if(!is.null(u))
cat("bandwidth: ",signif(hinit,3),"   MSE: ",mean((theta[1,]-u)^2),
                "   MAE: ",mean(abs(theta[1,]-u)),"\n")
# now run aws-cycle
hakt <- hinit*hincr
while(hakt<=hmax){
ihakt <- min(ihmax,trunc(hakt))
z <- .Fortran("lpawsmnn",
              as.integer(n),
              as.integer(px),
              as.integer(dp1),
              as.integer(dp2),
              as.double(x),
              as.double(y),
              as.integer(neighbors[1:ihakt,]),
              as.integer(ihakt),
              as.double(theta),
              as.double(bi),
              bi=as.double(bi),
              bi0=as.double(bi0),
              as.double(ai),
              ai=as.double(ai),
              as.double(lamakt),
              as.double(tau),
              as.double(hakt),
              as.double(kernl),
              as.double(kerns),
              double(dp1*dp1),
              double(dp1*dp1),
              double(dp1*dp1),
              double(dp1),
              double(dp1),
              double(dp1),
              as.logical(symmetric),PACKAGE="aws")[c("ai","bi","bi0")]
    ai <- (1-eta)*z$ai + eta * ai
    bi <- matrix((1-eta)*z$bi + eta * bi,dp2,n)
    bi0 <- (1-eta)*z$bi0 + eta * bi0
    theta <- matrix(.Fortran("mpawsmul",
                             as.integer(n),
                             as.integer(dp1),
                             as.integer(dp2),
                             as.double(ai),
                             as.double(bi),
                             as.double(theta),
                             double(dp1*dp1),PACKAGE="aws")[[6]],dp1,n)
if(!is.null(u))
cat("bandwidth: ",signif(hakt,3),"   MSE: ",mean((theta[1,]-u)^2),
                 "   MAE: ",mean(abs(theta[1,]-u)),"\n")
hakt <- hakt*hincr
gc()
}
} else {
dpd <- dp1+1
if(is.null(hinit)) hinit <- maxdist[dpd]
info <- 1
while(info>0){
if(hinit<=maxdist[dpd]) hinit <- maxdist[dpd]
ihinit <- sum(maxdist<=hinit)
z <- .Fortran("ipawsmul",
              as.integer(n),
              as.integer(px),
              as.integer(dp1),
              as.integer(dp2),
              as.double(x),
              as.double(y),
              as.integer(neighbors[1:ihinit,]),
              as.double(distmat[1:ihinit,]),
              as.integer(ihinit),
              as.double(hinit),
              bi=as.double(bi),
              ai=as.double(ai),
              theta=as.double(theta),
              as.double(kernl),
              double(dp1*dp1),
              double(dp1),
              info=integer(1),PACKAGE="aws")[c("ai","bi","theta","info")]
info <- z$info
dpd <- dpd+1
}
theta <- matrix(z$theta,dp1,n)
bi <- bi0 <- matrix(z$bi,dp2,n)
ai <- z$ai
if(!is.null(u))
cat("bandwidth: ",signif(hinit,3),"   MSE: ",mean((theta[1,]-u)^2),
                "   MAE: ",mean(abs(theta[1,]-u)),"\n")
# now run aws-cycle
hakt <- hinit*hincr
while(hakt<=hmax){
ihakt <- sum(maxdist<=hakt)
z <- .Fortran("lpawsmul",
              as.integer(n),
              as.integer(px),
              as.integer(dp1),
              as.integer(dp2),
              as.double(x),
              as.double(y),
              as.integer(neighbors[1:ihakt,]),
              as.double(distmat[1:ihakt,]),
              as.integer(ihakt),
              as.double(theta),
              as.double(bi),
              bi=as.double(bi),
              bi0=as.double(bi0),
              as.double(ai),
              ai=as.double(ai),
              as.double(lamakt),
              as.double(tau),
              as.double(hakt),
              as.double(kernl),
              as.double(kerns),
              double(dp1*dp1),
              double(dp1*dp1),
              double(dp1*dp1),
              double(dp1),
              double(dp1),
              double(dp1),
              as.logical(symmetric),PACKAGE="aws")[c("ai","bi","bi0")]
    ai <- (1-eta)*z$ai + eta * ai
    bi <- matrix((1-eta)*z$bi + eta * bi,dp2,n)
    bi0 <- (1-eta)*z$bi0 + eta * bi0
    theta <- matrix(.Fortran("mpawsmul",
                             as.integer(n),
                             as.integer(dp1),
                             as.integer(dp2),
                             as.double(ai),
                             as.double(bi),
                             as.double(theta),
                             double(dp1*dp1),PACKAGE="aws")[[6]],dp1,n)
if(!is.null(u))
cat("bandwidth: ",signif(hakt,3),"   MSE: ",mean((theta[1,]-u)^2),
                  "   MAE: ",mean(abs(theta[1,]-u)),"\n")
hakt <- hakt*hincr
gc()
}
}
}
###
###            end cases
###
z<-list(theta=theta,y=y,x=x,call=args)
class(z)<-"aws"
z
}
