.packageName <- "wle"
binary <- function(x, dim) {

   if (x==0) {
       pos <- 1
   } else {
       pos <- floor(log(x, 2))+1
   }

   if (!missing(dim)) {
       if (pos<=dim) {
           pos <- dim
       } else {
           warning("the value of `dim` is too small")
       }  
   }

   bin <- rep(0, pos)
   dicotomy <- rep(FALSE, pos)
   for (i in pos:1) {
        bin[i] <- floor(x/2^(i-1))
        dicotomy[i] <- bin[i]==1
        x <- x-((2^(i-1))*bin[i])
   }
   return(list(binary=bin, dicotomy=dicotomy))
}


#############################################################
#                                                           #
#	mle.aic function                                    #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

mle.aic <- function(formula, data=list(), model=TRUE, x=FALSE, y=FALSE, var.full=0, alpha=2, contrasts = NULL, verbose=FALSE) {

    ret.x <- x
    ret.y <- y
    result <- list()	
    mt <- terms(formula, data = data)
    mf <- cl <- match.call()
    mf$var.full <- mf$alpha <- mf$contrasts <- NULL
    mf$model <- mf$x <- mf$y <- NULL
    mf$verbose <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    xvars <- as.character(attr(mt, "variables"))[-1]
    inter <- attr(mt, "intercept")
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <-
	if(length(xvars) > 0) {
	    xlev <- lapply(mf[xvars], levels)
	    xlev[!sapply(xlev, is.null)]
	}
    ydata <- model.response(mf, "numeric")
    if (is.empty.model(mt)) 
	stop("The model is empty")
    else 
	xdata <- model.matrix(mt, mf, contrasts)

if (is.null(size <- nrow(xdata)) | is.null(nvar <- ncol(xdata))) stop("'x' must be a matrix")
if (length(ydata)!=size) stop("'y' and 'x' are not compatible")

nrep <- 2^nvar-1

if (size<nvar+1) {stop("Number of observation must be at least equal to the number of predictors (including intercept) + 1")}
if (var.full<0) {
    if (verbose) cat("mle.aic: the variance of the full model can not be negative, using default value \n")
    var.full <- 0
}

  z <- .Fortran("mleaic",
	as.double(ydata),
	as.matrix(xdata),
	as.integer(0), 
	as.integer(size),
	as.integer(nvar),
	as.integer(nrep),
	as.double(var.full),
	as.double(alpha),
	aic=mat.or.vec(nrep,nvar+1),
	param=mat.or.vec(nrep,nvar),
	var=double(nrep),
	resid=mat.or.vec(nrep,size),
	info=integer(1),
	PACKAGE="wle")
	
result$aic <- z$aic
result$coefficients <- z$param
result$scale <- sqrt(z$var)
result$residuals <- z$resid
result$call <- cl
result$info <- z$info
result$contrasts <- attr(xdata, "contrasts")
result$xlevels <- xlev
result$terms <- mt

if (model)
    result$model <- mf
if (ret.x)
    result$x <- xdata
if (ret.y)
    result$y <- ydata

dn <- colnames(xdata)
dimnames(result$coefficients) <- list(NULL,dn)
dimnames(result$aic) <- list(NULL,c(dn,"aic"))

class(result) <- "mle.aic"

return(result)
}

#############################################################
#                                                           #
#	summary.mle.aic function                            #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: December, 3, 2001                             #
#	Version: 0.4-1                                      #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

summary.mle.aic <- function (object, num.max=20, verbose=FALSE, ...) {

if (is.null(object$terms)) {
    stop("invalid \'mle.aic\' object")
}

if (num.max<1) {
    if (verbose) cat("summary.mle.aic: num.max can not less than 1, num.max=1 \n")
    num.max <- 1
}

ans <- list()
aic <- object$aic
if (is.null(nmodel <- nrow(aic))) nmodel <- 1
num.max <- min(nmodel,num.max)
if (nmodel!=1) { 
    nvar <- ncol(aic)-1
    aic <- aic[order(aic[,(nvar+1)]),]
    aic <- aic[1:num.max,]
}

ans$aic <- aic
ans$num.max <- num.max
ans$call <- object$call

class(ans) <- "summary.mle.aic"
return(ans)
}

#############################################################
#                                                           #
#	print.mle.aic function                                  #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: October, 27, 2003                                 #
#	Version: 0.4-1                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

print.mle.aic <- function (x, digits = max(3, getOption("digits") - 3), num.max=max(1, nrow(x$aic)), ...) {
   res <- summary.mle.aic(object=x, num.max=num.max, ...)
   print.summary.mle.aic(res, digits=digits, ...)
}

#############################################################
#                                                           #
#	print.summary.mle.aic function                      #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

print.summary.mle.aic <- function (x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep="\n", collapse = "\n"), "\n\n", sep="")

    cat("\nAkaike Information Criterion (AIC):\n")
    if(x$num.max>1) {
    nvar <- ncol(x$aic)-1
    x$aic[,(nvar+1)] <- signif(x$aic[,(nvar+1)],digits)
    } else {
    nvar <- length(x$aic)-1
    x$aic[(nvar+1)] <- signif(x$aic[(nvar+1)],digits)
    }
    print(x$aic)
    cat("\n")

    cat("Printed the first ",x$num.max," best models \n") 
    invisible(x)
}






#############################################################
#                                                           #
#	mle.cp function                                     #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

mle.cp <- function(formula, data=list(), model=TRUE, x=FALSE, y=FALSE, var.full=0, contrasts=NULL, verbose=FALSE) {

    ret.x <- x
    ret.y <- y
    result <- list()	
    mt <- terms(formula, data = data)
    mf <- cl <- match.call()
    mf$var.full <- mf$contrasts <- NULL
    mf$model <- mf$x <- mf$y <- NULL
    mf$verbose <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    xvars <- as.character(attr(mt, "variables"))[-1]
    inter <- attr(mt, "intercept")
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <-
	if(length(xvars) > 0) {
	    xlev <- lapply(mf[xvars], levels)
	    xlev[!sapply(xlev, is.null)]
	}
    ydata <- model.response(mf, "numeric")
    if (is.empty.model(mt)) 
	stop("The model is empty")
    else 
	xdata <- model.matrix(mt, mf, contrasts)

if (is.null(size <- nrow(xdata)) | is.null(nvar <- ncol(xdata))) stop("'x' must be a matrix")
if (length(ydata)!=size) stop("'y' and 'x' are not compatible")

nrep <- 2^nvar-1

if (size<nvar+1) {
stop("Number of observation must be at least equal to the number of predictors (including intercept) + 1")
}

if (var.full<0) {
    if (verbose) cat("mle.cp: the variance of the full model can not be negative, using default value \n")
    var.full <- 0
}

  z <- .Fortran("mlecp",
	as.double(ydata),
	as.matrix(xdata),
	as.integer(0), 
	as.integer(size),
	as.integer(nvar),
	as.integer(nrep),
	as.double(var.full),
	cp=mat.or.vec(nrep,nvar+1),
	param=mat.or.vec(nrep,nvar),
	var=double(nrep),
	resid=mat.or.vec(nrep,size),
	info=integer(1),
	PACKAGE="wle")


result$cp <- z$cp
result$coefficients <- z$param
result$scale <- sqrt(z$var)
result$residuals <- z$resid
result$call <- cl
result$info <- z$info
result$contrasts <- attr(xdata, "contrasts")
result$xlevels <- xlev
result$terms <- mt

if (model)
    result$model <- mf
if (ret.x)
    result$x <- xdata
if (ret.y)
    result$y <- ydata

dn <- colnames(xdata)
dimnames(result$coefficients) <- list(NULL,dn)
dimnames(result$cp) <- list(NULL,c(dn,"cp"))

class(result) <- "mle.cp" 

return(result)

}

#############################################################
#                                                           #
#	summary.mle.cp function                             #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: October, 28, 2003                             #
#	Version: 0.4-1                                      #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli              #
#                                                           #
#############################################################

summary.mle.cp <- function (object, num.max=20, verbose=FALSE, ...) {

if (is.null(object$terms)) {
    stop("invalid \'mle.cp\' object")
}

ans <- list()
cp <- object$cp

if (num.max<1) {
    if (verbose) cat("summary.mle.cp: num.max can not less than 1, num.max=1 \n")
    num.max <- 1
}

if(is.null(nmodel <- nrow(cp))) nmodel <- 1
num.max <- min(nmodel,num.max)
if (nmodel!=1) { 
    nvar <- ncol(cp)-1
    nparam <- apply(cp[,(1:nvar)],1,sum)
    cp <- cp[cp[,(nvar+1)]<=(nparam+0.00001),]
    if (!is.null(nrow(cp)) && nrow(cp)>1) {
	num.max <- min(nrow(cp),num.max)
    	cp <- cp[order(cp[,(nvar+1)]),]
    	cp <- cp[1:num.max,]
    } else num.max <- 1
}

ans$cp <- cp
ans$num.max <- num.max
ans$call <- object$call

class(ans) <- "summary.mle.cp"
return(ans)
}

#############################################################
#                                                           #
#	print.mle.cp function                                   #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: October, 27, 2003                                 #
#	Version: 0.4-1                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

print.mle.cp <- function (x, digits = max(3, getOption("digits") - 3),  num.max=max(1, nrow(x$cp)), ...) {
    res <- summary.mle.cp(object=x, num.max=num.max, ...)
    print.summary.mle.cp(res, digits=digits, ...)
}

#############################################################
#                                                           #
#	print.summary.mle.cp function                       #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

print.summary.mle.cp <- function (x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep="\n", collapse = "\n"), "\n\n", sep="")

    cat("\nMallows Cp:\n")
    if(x$num.max>1) {
    nvar <- ncol(x$cp)-1
    x$cp[,(nvar+1)] <- signif(x$cp[,(nvar+1)],digits)
    } else {
    nvar <- length(x$cp)-1
    x$cp[(nvar+1)] <- signif(x$cp[(nvar+1)],digits)
    }
    print(x$cp)
    cat("\n")

    cat("Printed the first ",x$num.max," best models \n") 
    invisible(x)
}


#############################################################
#                                                           #
#	mle.cv function                                         #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: April, 02, 2002                                   #
#	Version: 0.4                                            #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli                  #
#                                                           #
#############################################################

mle.cv <- function(formula, data=list(), model=TRUE, x=FALSE, y=FALSE, monte.carlo=500, split, contrasts=NULL, verbose=FALSE) {

if (missing(split)) {
    split <- 0
}

    ret.x <- x
    ret.y <- y
    result <- list()	
    mt <- terms(formula, data = data)
    mf <- cl <- match.call()
    mf$monte.carlo <- mf$split <- mf$contrasts <- NULL
    mf$model <- mf$x <- mf$y <- NULL
    mf$verbose <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    xvars <- as.character(attr(mt, "variables"))[-1]
    inter <- attr(mt, "intercept")
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <-
	if(length(xvars) > 0) {
	    xlev <- lapply(mf[xvars], levels)
	    xlev[!sapply(xlev, is.null)]
	}
    ydata <- model.response(mf, "numeric")
    if (is.empty.model(mt)) 
	stop("The model is empty")
    else 
	xdata <- model.matrix(mt, mf, contrasts)

if (is.null(size <- nrow(xdata)) | is.null(nvar <- ncol(xdata))) stop("'x' must be a matrix")
if (length(ydata)!=size) stop("'y' and 'x' are not compatible")

nrep <- 2^nvar-1

if (size<nvar+1) {stop("Number of observation must be at least equal to the number of predictors (including intercept) + 1")}

if (split<nvar+2 | split>(size-2)) {
    split <- max(round(size^(3/4)),nvar+2)
    if (verbose) cat("mle.cv: dimension of the split subsample set to default value = ",split,"\n")
}
maxcarlo <- sum(log(1:size))-(sum(log(1:split))+sum(log(1:(size-split))))
if (monte.carlo<1 | log(monte.carlo) > maxcarlo){
    stop("MonteCarlo replication not in the range")
}

  z <- .Fortran("mlecv",
	as.double(ydata),
	as.matrix(xdata),
	as.integer(0), 
	as.integer(size),
	as.integer(nvar),
	as.integer(nrep),
	as.integer(monte.carlo),
	as.integer(split),
	cv=mat.or.vec(nrep,nvar+1),
	info=integer(1),
	PACKAGE="wle")


result$cv <- z$cv
result$call <- cl
result$info <- z$info
result$contrasts <- attr(xdata, "contrasts")
result$xlevels <- xlev
result$terms <- mt

if (model)
    result$model <- mf
if (ret.x)
    result$x <- xdata
if (ret.y)
    result$y <- ydata

dn <- colnames(xdata)
dimnames(result$cv) <- list(NULL,c(dn,"cv"))

class(result) <- "mle.cv" 

return(result)
}

#############################################################
#                                                           #
#	summary.mle.cv function                             #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4-1                                      #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

summary.mle.cv <- function (object, num.max=20, verbose=FALSE, ...) {

    if (is.null(object$terms)) {
        stop("invalid \'mle.cv\' object")
    }

    if (num.max<1) {
        if (verbose) cat("summary.mle.cv: num.max can not less than 1, num.max=1 \n")
        num.max <- 1
    }

    ans <- list()
    cv <- object$cv
    if(is.null(nmodel <- nrow(cv))) nmodel <- 1
    num.max <- min(nmodel,num.max)
    if (nmodel!=1) { 
        nvar <- ncol(cv)-1
        cv <- cv[order(cv[,(nvar+1)]),]
        cv <- cv[1:num.max,]
    }

    ans$cv <- cv
    ans$num.max <- num.max
    ans$call <- object$call

    class(ans) <- "summary.mle.cv"
    return(ans)
}

#############################################################
#                                                           #
#	print.mle.cv function                                   #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: October, 27, 2003                                 #
#	Version: 0.4-1                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

print.mle.cv <- function (x, digits = max(3, getOption("digits") - 3), num.max=max(1, nrow(x$cv)), ...) {
    res <- summary.mle.cv(object=x, num.max=num.max, ...)
    print.summary.mle.cv(res, digits=digits, ...)
}

#############################################################
#                                                           #
#	print.summary.mle.cv function                       #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

print.summary.mle.cv <- function (x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep="\n", collapse = "\n"), "\n\n", sep="")

    cat("\nCross Validation selection criteria:\n")
    if(x$num.max>1) {
    nvar <- ncol(x$cv)-1
    x$cv[,(nvar+1)] <- signif(x$cv[,(nvar+1)],digits)
    } else {
    nvar <- length(x$cv)-1
    x$cv[(nvar+1)] <- signif(x$cv[(nvar+1)],digits)
    }
    print(x$cv)
    cat("\n")

    cat("Printed the first ",x$num.max," best models \n") 
    invisible(x)
}



#############################################################
#                                                           #
#	mle.stepwise function                               #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@stat.unipd.it                       #
#	Date: August,  2, 2001                              #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

mle.stepwise <- function(formula, data=list(), model=TRUE, x=FALSE, y=FALSE, type="Forward", f.in=4.0, f.out=4.0, contransts=NULL, verbose=FALSE)
{

ntype <- switch(type,
	Forward = 1,
	Backward = 2,
	Stepwise = 3,
	stop("The type must be Forward, Backward or Stepwise"))

    ret.x <- x
    ret.y <- y
    result <- list()	
    mt <- terms(formula, data = data)
    mf <- cl <- match.call()
    mf$type <- mf$f.in <- mf$f.out <- NULL
    mf$max.iter <- mf$contrasts <- NULL
    mf$model <- mf$x <- mf$y <- NULL
    mf$verbose <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    xvars <- as.character(attr(mt, "variables"))[-1]
    inter <- attr(mt, "intercept")
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <-
	if(length(xvars) > 0) {
	    xlev <- lapply(mf[xvars], levels)
	    xlev[!sapply(xlev, is.null)]
	}
    ydata <- model.response(mf, "numeric")
    if (is.empty.model(mt)) 
	stop("The model is empty")
    else 
	xdata <- model.matrix(mt, mf, contrasts)

if (is.null(size <- nrow(xdata)) | is.null(nvar <- ncol(xdata))) stop("'x' must be a matrix")
if (length(ydata)!=size) stop("'y' and 'x' are not compatible")

if (size<nvar+1) {
    stop("Number of observation must be at least equal to the number of predictors (including intercept) + 1")
}

if (f.in<0 | f.out<0) {
    stop("f.in and f.out can not be negative")
}

nrep <- 2^nvar-1

  z <- .Fortran("step",
	as.double(ydata),
	as.matrix(xdata),
	as.integer(0), 
	as.integer(size),
	as.integer(nvar),
	as.integer(nrep),
	as.integer(ntype),
	as.double(f.in),
	as.double(f.out),
	step=mat.or.vec(nrep,nvar+1),
	info=integer(1),
	imodel=integer(1),
	PACKAGE = "wle")

result$step <- z$step[1:z$imodel,]
result$info <- z$info
result$call <- match.call()
result$contrasts <- attr(xdata, "contrasts")
result$xlevels <- xlev
result$terms <- mt
result$type <- type
result$f.in <- f.in
result$f.out <- f.out

if (model)
    result$model <- mf
if (ret.x)
    result$x <- xdata
if (ret.y)
    result$y <- ydata

dn <- colnames(xdata)

if (z$imodel>0) {
if (z$imodel==1) {
names(result$step) <- c(dn," ")
} else {
dimnames(result$step) <- list(NULL,c(dn," "))
}
}

class(result) <- "mle.stepwise"

return(result)

}


summary.mle.stepwise <- function (object, num.max=20, verbose=FALSE, ...) {

if (is.null(object$terms)) {
    stop("invalid \'mle.stepwise\' object")
}

if (num.max<1) {
    if (verbose) cat("summary.mle.stepwise: num.max can not less than 1, num.max=1 \n")
    num.max <- 1
}

ans <- list()
step <- object$step
if(is.null(nmodel <- nrow(step))) nmodel <- 1
num.max <- min(nmodel,num.max)
if (nmodel!=1) { 
    step <- step[(nmodel-num.max+1):nmodel,]
}

ans$step <- step
ans$num.max <- num.max
ans$type <- object$type
ans$f.in <- object$f.in
ans$f.out <- object$f.out
ans$call <- object$call

class(ans) <- "summary.mle.stepwise"
return(ans)
}

print.mle.stepwise <- function (x, digits = max(3, getOption("digits") - 3), num.max=max(1,nrow(x$step)), ...) {
res <- summary.mle.stepwise(object=x, num.max=num.max, ...)
print.summary.mle.stepwise(res, digits=digits, ...)
}

print.summary.mle.stepwise <- function (x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep="\n", collapse = "\n"), "\n\n", sep="")

    cat("\n",x$type," selection procedure\n")
    if (x$type=="Forward" | x$type=="Stepwise") {
	cat("\nF.in: ",x$f.in)
    } 
    if (x$type=="Backward" | x$type=="Stepwise") {
	cat("\nF.out: ",x$f.out)
    }
    cat(" \n")
    cat("\nLast ",x$num.max," iterations:\n")

    if(x$num.max>1) {
    nvar <- ncol(x$step)-1
    x$step[,(nvar+1)] <- signif(x$step[,(nvar+1)],digits)
    } else {
    nvar <- length(x$step)-1
    x$step[(nvar+1)] <- signif(x$step[(nvar+1)],digits)
    }
    print(x$step)
    cat("\n")
    invisible(x)
}






#############################################################
#                                                           #
#	plot.mle.cp function                                    #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: October, 28, 2003                                 #
#	Version: 0.4-2                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

plot.mle.cp <- function(x, base.line=0, num.max=20, plot.it=TRUE, log.scale=FALSE, xlab="Number of Predictors", ylab=NULL, verbose=FALSE, ...) {

    if (is.null(x$terms)) {
        stop("invalid \'mle.cp\' object")
    }

    cp <- x$cp

    if (num.max<1) {
        if (verbose) cat("plot.mle.cp: num.max can not less than 1, num.max=1 \n")
        num.max <- 1
    }

    if (is.null(nrow(cp)) | nrow(cp)==1) {
        num.model <- 1
    } else {
        num.model <- nrow(cp) 
    }

    if (num.model<num.max) {
        if (verbose) cat("plot.mle.cp: The number of models is less than num.max \n")
        num.max <- num.model
    }

    if (is.null(ncol(cp))) {
        stop("No models to plot")
    } else {
        nvar <- ncol(cp)-1
    }

good.model <- (apply(cp[,1:nvar],1,sum)+base.line>=cp[,nvar+1])
cp.good <- matrix(cp[good.model,],ncol=nvar+1)
cp.bad <- matrix(cp[!good.model,],ncol=nvar+1)
ordine.good <- order(cp.good[,nvar+1])
ordine.bad <- order(cp.bad[,nvar+1])
cp.good <- matrix(cp.good[ordine.good,],ncol=(nvar+1))
num.good <- dim(cp.good)[1]
cp.bad <- matrix(cp.bad[ordine.bad,],ncol=(nvar+1))
num.bad <- dim(cp.bad)[1]

label.good <- character()
for(i in 1:nvar){
label.good <- paste(label.good,cp.good[,i],sep="")
}
label.bad <- character()
for(i in 1:nvar){
label.bad <- paste(label.bad,cp.bad[,i],sep="")
}


xcoord.good <- apply(matrix(cp.good[,1:nvar],ncol=nvar),1,sum)[1:min(num.max,num.good)]
ycoord.good <- cp.good[,nvar+1][1:min(num.max,num.good)]

label.good <- label.good[1:min(num.max,num.good)]

xcoord.best <- xcoord.good[1]
ycoord.best <- ycoord.good[1]

label.best <- label.good[1]

if (length(xcoord.good)==1) {
    xcoord.good <- xcoord.best <- 0
    ycoord.good <- ycoord.best <-  0
    plot.good <- FALSE
} else {
    xcoord.good <- xcoord.good[-1]
    ycoord.good <- ycoord.good[-1]
    label.good <- label.good[-1]
    plot.good <- TRUE
}

if (num.max>num.good) {
    xcoord.bad <- apply(matrix(cp.bad[,1:nvar],ncol=nvar),1,sum)[1:min(num.bad,num.max-num.good)]
    ycoord.bad <- cp.bad[,nvar+1][1:min(num.bad,num.max-num.good)]
    label.bad <- label.bad[1:min(num.bad,num.max-num.good)]
    plot.bad <- TRUE
} else {
    xcoord.bad <- 0
    ycoord.bad <- 0
    plot.bad <- FALSE
}

xlim.min <- min(xcoord.good, xcoord.bad, xcoord.best)
xlim.max <- max(xcoord.good, xcoord.bad, xcoord.best)

yetichetta <- "Cp"

if (log.scale) {
    ycoord.good <- log10(ycoord.good+min(ycoord.good,ycoord.bad,ycoord.best)+1)
    ycoord.bad <- log10(ycoord.bad+min(ycoord.good,ycoord.bad,ycoord.best)+1)
    ycoord.best <- log10(ycoord.best+min(ycoord.good,ycoord.bad,ycoord.best)+1)
    yetichetta <- "Cp log10 scale"
}

ylim.min <- min(ycoord.good, ycoord.bad, ycoord.best)
ylim.max <- max(ycoord.good, ycoord.bad, ycoord.best)

if (is.null(ylab)) {
ylab <- yetichetta
}

if(plot.it)
{
plot(xcoord.best,ycoord.best,xlim=c(xlim.min,xlim.max),ylim=c(ylim.min,ylim.max),xlab=xlab,ylab=ylab,type="n")
text(xcoord.best,ycoord.best,col=4,labels=label.best)

if(plot.good)
{
text(xcoord.good,ycoord.good,col=3,labels=label.good)
}

if(plot.bad)
{
text(xcoord.bad,ycoord.bad,col=2,labels=label.bad)
}


if(!log.scale)
{
abline(base.line,1,col=2)
abline(0,1)
}
else
{
vettx <- seq(xlim.min,xlim.max,0.5)
vetty <- log10(vettx+min(ycoord.good,ycoord.bad,ycoord.best)+1)
vetty.base.line <- log10(vettx+min(ycoord.good,ycoord.bad,ycoord.best)+1+base.line)
lines(vettx,vetty.base.line,col=2,type="l")
lines(vettx,vetty,type="l")
}

}

invisible(list(num.good=num.good,num.bad=num.bad,cp.good=cp.good, cp.bad=cp.bad))
}
#############################################################
#                                                           #
#	plot.wle.cp function                                    #
#	E-mail: claudio@unive.it                                #
#	Date: October, 27, 2003                                 #
#	Version: 0.4-2                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

plot.wle.cp <- function(x, base.line=0, num.max=20, plot.it=TRUE, log.scale=FALSE, xlab="Number of Predictors", ylab=NULL, verbose=FALSE, ...) {

    if (is.null(x$terms)) {
        stop("invalid \'wle.cp\' object")
    }

    wcp <- x$wcp

    if (num.max<1) {
        if (verbose) cat("plot.wle.cp: num.max can not less than 1, num.max=1 \n")
        num.max <- 1
    }

    if (is.null(nrow(wcp)) | nrow(wcp)==1) {
        num.model <- 1
    } else {
        num.model <- nrow(wcp) 
    }

    if (num.model<num.max) {
        if (verbose) cat("plot.wle.cp: The number of models is less than num.max \n")
        num.max <- num.model
    }

    if (is.null(ncol(wcp))) {
        stop("No models to plot")
    } else {
        nvar <- ncol(wcp)-1
    }

good.model <- (apply(wcp[,1:nvar],1,sum)+base.line>=wcp[,nvar+1])
wcp.good <- matrix(wcp[good.model,],ncol=nvar+1)
wcp.bad <- matrix(wcp[!good.model,],ncol=nvar+1)
ordine.good <- order(wcp.good[,nvar+1])
ordine.bad <- order(wcp.bad[,nvar+1])
wcp.good <- matrix(wcp.good[ordine.good,],ncol=(nvar+1))
num.good <- dim(wcp.good)[1]
wcp.bad <- matrix(wcp.bad[ordine.bad,],ncol=(nvar+1))
num.bad <- dim(wcp.bad)[1]

label.good <- character()
for(i in 1:nvar){
label.good <- paste(label.good,wcp.good[,i],sep="")
}
label.bad <- character()
for(i in 1:nvar){
label.bad <- paste(label.bad,wcp.bad[,i],sep="")
}


xcoord.good <- apply(matrix(wcp.good[,1:nvar],ncol=nvar),1,sum)[1:min(num.max,num.good)]
ycoord.good <- wcp.good[,nvar+1][1:min(num.max,num.good)]

label.good <- label.good[1:min(num.max,num.good)]

xcoord.best <- xcoord.good[1]
ycoord.best <- ycoord.good[1]

label.best <- label.good[1]

if (length(xcoord.good)==1) {
    xcoord.good <- xcoord.best <- 0
    ycoord.good <- ycoord.best <- 0
    plot.good <- FALSE
} else {
    xcoord.good <- xcoord.good[-1]
    ycoord.good <- ycoord.good[-1]
    label.good <- label.good[-1]
    plot.good <- TRUE
}

if (num.max>num.good) {
    xcoord.bad <- apply(matrix(wcp.bad[,1:nvar],ncol=nvar),1,sum)[1:min(num.bad,num.max-num.good)]
    ycoord.bad <- wcp.bad[,nvar+1][1:min(num.bad,num.max-num.good)]
    label.bad <- label.bad[1:min(num.bad,num.max-num.good)]
    plot.bad <- TRUE
} else {
    xcoord.bad <- 0
    ycoord.bad <- 0
    plot.bad <- FALSE
}

xlim.min <- min(xcoord.good, xcoord.bad, xcoord.best)
xlim.max <- max(xcoord.good, xcoord.bad, xcoord.best)

yetichetta <- "WCp"

if (log.scale) {
    ycoord.good <- log10(ycoord.good+min(ycoord.good,ycoord.bad,ycoord.best)+1)
    ycoord.bad <- log10(ycoord.bad+min(ycoord.good,ycoord.bad,ycoord.best)+1)
    ycoord.best <- log10(ycoord.best+min(ycoord.good,ycoord.bad,ycoord.best)+1)
    yetichetta <- "WCp log10 scale"
}

ylim.min <- min(ycoord.good, ycoord.bad, ycoord.best)
ylim.max <- max(ycoord.good, ycoord.bad, ycoord.best)

if (is.null(ylab)) {
    ylab <- yetichetta
}

if(plot.it)
{
plot(xcoord.best,ycoord.best,xlim=c(xlim.min,xlim.max),ylim=c(ylim.min,ylim.max),xlab=xlab,ylab=ylab,type="n")
text(xcoord.best,ycoord.best,col=4,labels=label.best)

if(plot.good)
{
text(xcoord.good,ycoord.good,col=3,labels=label.good)
}

if(plot.bad)
{
text(xcoord.bad,ycoord.bad,col=2,labels=label.bad)
}


if(!log.scale)
{
abline(base.line,1,col=2)
abline(0,1)
}
else
{
vettx <- seq(xlim.min,xlim.max,0.5)
vetty <- log10(vettx+min(ycoord.good,ycoord.bad,ycoord.best)+1)
vetty.base.line <- log10(vettx+min(ycoord.good,ycoord.bad,ycoord.best)+1+base.line)
lines(vettx,vetty.base.line,col=2,type="l")
lines(vettx,vetty,type="l")
}

}

invisible(list(num.good=num.good,num.bad=num.bad,wcp.good=wcp.good, wcp.bad=wcp.bad))
}
#############################################################
#                                                           #
#	plot.wle.lm function                                    #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: April, 17, 2003                                   #
#	Version: 0.5-1                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

plot.wle.lm <- function(x, roots, which=1:4, which.main, level.weight=0.5, ask=dev.interactive(), col=c(2, 1, 3), id.n=3, labels.id, cex.id = 0.75, verbose=FALSE, ...) {

   old.par <- par(no.readonly=TRUE)
   on.exit(par(old.par))

   if (!inherits(x, "wle.lm")) stop("Invalid 'wle.lm' object")
   if (ask) par(ask = TRUE)
   if (!is.numeric(which) || any(which < 0) || any(which > 4))
       stop("`which' must be in 0:4")

   if (level.weight < 0 | level.weight > 1) {
       if (verbose) cat("plot.wle.lm: level.weight should be between zero and one, set to 0.5 \n")
           level.weight <- 0.5
   }

   param <- x$coefficients
   res <- x$residuals
   y.fit <- x$fitted.values
   weight <- x$weights
   tot.weight <- x$tot.weights
   tot.sol <- x$tot.sol
   if (tot.sol > 1) {
       size <- ncol(y.fit)
       nomi <- dimnames(res)[[2]]
   } else {
       size <- length(y.fit)
       nomi <- names(res)
   }

   if (is.null(id.n)) {
       id.n <- 0
   } else {
       id.n <- as.integer(id.n)
       if (id.n < 0 || id.n > size)
	   stop(paste("`id.n' must be in { 1,..,", size,"}"))
   }
   if(id.n > 0) {
        if (missing(labels.id)) {
            if (is.null(nomi)) {
                labels.id <- paste(1:size)
            } else {
                labels.id <- nomi
            }
        } else {
            if (length(labels.id)!=size) {
                stop("the length of 'labels.id' must be equal to the number of observations")
            }
        }
        iid <- 1:id.n
        text.id <- function (x, y, ind, labels.id, adj.x = FALSE)
            text(x - if(adj.x) strwidth(" ")*cex.id else 0, y, labels.id[ind],
                 cex = cex.id, xpd = TRUE, adj = if(adj.x) 1)
   }

   if (missing(roots)) {
       plot.tot.sol <- x$tot.sol
       roots <- 1:plot.tot.sol
   } else {
       if (is.numeric(roots)) {
           plot.tot.sol <- length(roots)
           if (max(roots > tot.sol)) {
               stop("'roots' values must be not greater than the 'x$tot.sol'")
           }
       } else {
           stop("'roots' must be numeric")
       }
   }

   if (missing(which.main)) {
       which.main <- 1:(plot.tot.sol^2)
   } 
   if (!is.numeric(which.main) || any(which.main < 0) || any(which.main > plot.tot.sol^2))
       stop(paste("`which.main' must be in 0:", plot.tot.sol^2, sep=""))
   
   if (plot.tot.sol>1) {
       if (prod(old.par$mfcol)==(length(which.main)+length(roots)*length(which))) {
           par(mfcol=old.par$mfcol)           
       } else if (plot.tot.sol^2==length(which.main)) {
                  par(mfcol=c(plot.tot.sol, plot.tot.sol))
       }
       for (isol in roots) {
            for (jsol in roots) {
                 y.fit.i <- y.fit[isol,]
                 res.i <- res[isol,]
                 weight.i <- weight[isol,]

                 y.fit.j <- y.fit[jsol,]
                 res.j <- res[jsol,]
                 weight.j <- weight[jsol,]
 
                 level.i <- weight.i>=level.weight
                 level.j <- weight.j>=level.weight
 
                 color <- color.res <- color.w <- rep(col[1], size)
                 color[level.i] <- col[2]
                 color[level.j] <- col[3]

                 color.res[level.i & (res.i>res.j)] <- col[2]
                 color.res[level.j & (res.i<res.j)] <- col[3]

                 color.w[level.i & (weight.i>weight.j)] <- col[2]
                 color.w[level.j & (weight.i<weight.j)] <- col[3]


            if (any(which.main==((isol-1)*plot.tot.sol+jsol))) {
                 
                 if (isol==jsol) {
                     ylim <- range(weight.i, na.rm=TRUE)
	             if (id.n > 0)
	                 ylim <- ylim + c(-1,1)* 0.08 * diff(ylim)
                     plot(weight.i, col=color, xlab="Observations", ylab="Weights",main=paste("Weights of the root: ",isol), ylim=ylim)
      	             if (id.n > 0) {
                         show.w <- order(weight.i)[iid] 
	                 x.id <- (1:size)[show.w]
                         y.id <- weight.i[show.w]
#	                 y.id[y.id < 0] <- y.id[y.id < 0] - strheight(" ")/3
	                 text.id(x=x.id, y=y.id, ind=show.w, labels.id=labels.id,  adj.x = TRUE)
	             }
                 } else {
                     if (isol>jsol) {
                         plot(res.i, res.j, col=color.res, xlab=paste("Residuals of the root: ",isol), ylab=paste("Residuals of the root: ", jsol), main="Residuals")
                         abline(0,1)
                     } else {
                         plot(weight.i, weight.j, col=color.w, xlab=paste("Weights of the root: ", isol), ylab=paste("Weights of the root: ", jsol), main="Weights")
                         abline(0,1)
                     }
                 }
               }        # fine which.main
            }
       }

       for (isol in roots) {
            if (prod(old.par$mfcol)==length(which)) {     
                par(mfcol=old.par$mfcol)
            }
            
            y.fit.temp <- y.fit[isol,]
            res.temp <- res[isol,]
            weight.temp <- weight[isol,]
            level <- weight.temp>=level.weight
            color <- rep(col[1], size)
            color[level] <- col[2]

            if (any(which==1)) {
                ylim <- range(res.temp, na.rm=TRUE)
	        if (id.n > 0)
	            ylim <- ylim + c(-1,1)* 0.08 * diff(ylim)
                plot(y.fit.temp, res.temp, col=color, xlab="Fitted values", ylab="Residuals", ylim=ylim)
      	        if (id.n > 0) {
                    show.w <- order(weight.temp)[iid] 
	            x.id <- y.fit.temp[show.w]
                    y.id <- res.temp[show.w]
                    y.id[y.id < 0] <- y.id[y.id < 0] - strheight(" ")/3
	            text.id(x=x.id, y=y.id, ind=show.w, labels.id=labels.id, adj.x = TRUE)
	        }
            }

            if (any(which==2)) {
                res.temp.weight <- res.temp*weight.temp
                ylim <- range(res.temp.weight, na.rm=TRUE)
	        if (id.n > 0)
	            ylim <- ylim + c(-1,1)* 0.08 * diff(ylim)            
                plot(y.fit.temp, res.temp.weight, col=color, xlab="Fitted values", ylab="Weighted residuals", ylim=ylim)
      	        if (id.n > 0) {
                    show.w <- order(weight.temp)[iid] 
                    x.id <- y.fit.temp[show.w]
                    y.id <- res.temp.weight[show.w]
                    y.id[y.id < 0] <- y.id[y.id < 0] - strheight(" ")/3
	            text.id(x=x.id, y=y.id, ind=show.w, labels.id=labels.id, adj.x = TRUE)
	        }
            }

            if (any(which==3)) {
                qqnorm(res.temp, col=color)
                qqline(res.temp)
            }

            if (any(which==4)) {
                qqnorm(res.temp*weight.temp, col=color)
                qqline(res.temp*weight.temp)
            }
       }
   } else {

       if (tot.sol > 1) {
           param <- x$coefficients[roots,]
           res <- x$residuals[roots,]
           y.fit <- x$fitted.values[roots,]
           weight <- x$weights[roots,]
           tot.weight <- x$tot.weights[roots]
       }

       if (prod(old.par$mfcol)!=(length(which)+1)) {
           par(mfcol=c(1,1))
       }

       level.i <- weight>=level.weight
       color <- rep(col[1], size)
       color[level.i] <- col[3]
       show.w <- order(weight)[iid] 

       if (any(which.main!=0)) {            
           ylim <- range(weight, na.rm=TRUE)
           if (id.n > 0)
               ylim <- ylim + c(-1,1)* 0.08 * diff(ylim)
           plot(weight, col=color, xlab="Observations", ylab="Weights", main="Weights of the root", ylim=ylim)
           if (id.n > 0) {
               x.id <- (1:size)[show.w]
               y.id <- weight[show.w]
               y.id[y.id < 0] <- y.id[y.id < 0] - strheight(" ")/3
	       text.id(x=x.id, y=y.id, ind=show.w, labels.id=labels.id, adj.x = TRUE)
           }
       }
       if (prod(old.par$mfcol)==length(which)) {     
           par(mfcol=old.par$mfcol)
       }
       
       level <- weight>=level.weight
       color <- rep(col[1], size)
       color[level] <- col[2]

       if (any(which==1)) {
           ylim <- range(res, na.rm=TRUE)
           if (id.n > 0)
	       ylim <- ylim + c(-1,1)* 0.08 * diff(ylim)
               plot(y.fit, res, col=color, xlab="Fitted values", ylab="Residuals", ylim=ylim)
           if (id.n > 0) {
               x.id <- y.fit[show.w]
               y.id <- res[show.w]
               y.id[y.id < 0] <- y.id[y.id < 0] - strheight(" ")/3
	       text.id(x=x.id, y=y.id, ind=show.w, labels.id=labels.id, adj.x = TRUE)
	   }
        }

        if (any(which==2)) {
           res.weight <- res*weight
           ylim <- range(res.weight, na.rm=TRUE)
	   if (id.n > 0)
	       ylim <- ylim + c(-1,1)* 0.08 * diff(ylim)            
           plot(y.fit, res*weight, col=color, xlab="Fitted values", ylab="Weighted residuals", ylim=ylim)
     	   if (id.n > 0) {
               x.id <- y.fit[show.w]
               y.id <- res.weight[show.w]
               y.id[y.id < 0] <- y.id[y.id < 0] - strheight(" ")/3
	       text.id(x=x.id, y=y.id, ind=show.w, labels.id=labels.id, adj.x = TRUE)
	   }
        }

        if (any(which==3)) {
            qqnorm(res, col=color)
            qqline(res)
        }

       if (any(which==4)) {
            qqnorm(res*weight, col=color)
            qqline(res*weight)
        }
    }
}



#############################################################
#                                                           #
#	wle.aic function                                    #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.aic <- function(formula, data=list(), model=TRUE, x=FALSE, y=FALSE, boot=30, group, var.full=0, num.sol=1, raf="HD", smooth=0.031, tol=10^(-6), equal=10^(-3), max.iter=500, min.weight=0.5, method="full", alpha=2, contrasts=NULL, verbose=FALSE) {

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

type <- switch(method,
	full = 0,
	reduced = 1,
	-1)

if (type==-1) stop("Please, choose the method: full=wieghts based on full model, reduced=weights based on the actual model")

if (missing(group)) {
group <- 0
}

    ret.x <- x
    ret.y <- y
    result <- list()	
    mt <- terms(formula, data = data)
    mf <- cl <- match.call()
    mf$boot <- mf$group <- mf$smooth <- NULL
    mf$tol <- mf$equal <- mf$num.sol <- NULL
    mf$min.weight <- mf$max.iter <- mf$raf <- NULL
    mf$var.full <- mf$alpha <- mf$contrasts <- NULL
    mf$model <- mf$x <- mf$y <- mf$method <- NULL
    mf$verbose <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    xvars <- as.character(attr(mt, "variables"))[-1]
    inter <- attr(mt, "intercept")
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <-
	if(length(xvars) > 0) {
	    xlev <- lapply(mf[xvars], levels)
	    xlev[!sapply(xlev, is.null)]
	}
    ydata <- model.response(mf, "numeric")
    if (is.empty.model(mt)) 
	stop("The model is empty")
    else 
	xdata <- model.matrix(mt, mf, contrasts)

if (is.null(size <- nrow(xdata)) | is.null(nvar <- ncol(xdata))) stop("'x' must be a matrix")
if (length(ydata)!=size) stop("'y' and 'x' are not compatible")

nrep <- 2^nvar-1

if (size<nvar) {
    stop("Number of observations must be at least equal to the number of predictors (including intercept)")
}

if (group<nvar) {
    group <- max(round(size/4),nvar)
    if (verbose) cat("wle.aic: dimension of the subsample set to default value = ",group,"\n")
}

maxboot <- sum(log(1:size))-(sum(log(1:group))+sum(log(1:(size-group))))

if (boot<1 | log(boot) > maxboot) {
    stop("bootstrap replication not in the range")
}

if (!(num.sol>=1)) {
    if (verbose) cat("wle.aic: number of solution to report set to 1 \n")
    num.sol <- 1
}

if (max.iter<1) {
    if (verbose) cat("wle.aic: max number of iteration set to 500 \n")
    max.iter <- 500
}

if (smooth<10^(-5)) {
    if (verbose) cat("wle.aic: the smooth parameter seems too small \n")
}

if (tol<=0) {
    if (verbose) cat("wle.aic: the accuracy must be positive, using default value: 10^(-6) \n")
    tol <- 10^(-6)
}

if (equal<=tol) {
    if (verbose) cat("wle.aic: the equal parameter must be greater than tol, using default value: tol+10^(-3) \n")
    equal <- tol+10^(-3)
}

if (var.full<0) {
    if (verbose) cat("wle.aic: the variance of the full model can not be negative, using default value \n")
    var.full <- 0
}

if (min.weight<0) {
    if (verbose) cat("wle.aic: the minimum sum of the weights can not be negative, using default value \n")
    min.weight <- 0.5
}

  z <- .Fortran("wleaic",
	as.double(ydata),
	as.matrix(xdata),
	as.integer(0), 
	as.integer(size),
	as.integer(nvar),
	as.integer(boot),
	as.integer(group),
	as.integer(nrep),
	as.integer(raf),
	as.double(smooth),
	as.double(tol),
	as.double(equal),
	as.integer(max.iter),
	as.double(var.full),
	as.integer(num.sol),
	as.double(min.weight),
	as.integer(type),
	as.double(alpha),
	waic=mat.or.vec(nrep*num.sol,nvar+1),
	param=mat.or.vec(nrep*num.sol,nvar),
	var=double(nrep*num.sol),
	resid=mat.or.vec(nrep*num.sol,size),
	totweight=double(nrep*num.sol),
	weight=mat.or.vec(nrep*num.sol,size),
 	same=integer(nrep*num.sol),
	info=integer(1),
	PACKAGE="wle")

delnull <- z$same==0

result$waic <- z$waic[!delnull,]
result$coefficients <- z$param[!delnull,]
result$scale <- sqrt(z$var[!delnull])
result$residuals <- z$resid[!delnull]
result$weights <- z$weight[!delnull,]
result$tot.weights <- z$totweight[!delnull]
result$freq <- z$same[!delnull]
result$call <- cl
result$info <- z$info
result$contrasts <- attr(xdata, "contrasts")
result$xlevels <- xlev
result$terms <- mt

if (model)
    result$model <- mf
if (ret.x)
    result$x <- xdata
if (ret.y)
    result$y <- ydata

dn <- colnames(xdata)
dimnames(result$coefficients) <- list(NULL,dn)
dimnames(result$waic) <- list(NULL,c(dn,"waic"))

class(result) <- "wle.aic"

return(result)
}

#############################################################
#                                                           #
#	summary.wle.aic function                            #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4-1                                      #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

summary.wle.aic <- function (object, num.max=20, verbose=FALSE, ...) {

if (is.null(object$terms)) {
    stop("invalid \'wle.aic\' object")
}

if (num.max<1) {
    if (verbose) cat("summary.wle.aic: num.max can not less than 1, num.max=1 \n")
    num.max <- 1
}

ans <- list()
waic <- object$waic
if (is.null(nmodel <- nrow(waic))) nmodel <- 1
num.max <- min(nmodel,num.max)
if (nmodel!=1) { 
    nvar <- ncol(waic)-1
    waic <- waic[order(waic[,(nvar+1)]),]
    waic <- waic[1:num.max,]
}

ans$waic <- waic
ans$num.max <- num.max
ans$call <- object$call

class(ans) <- "summary.wle.aic"
return(ans)
}

#############################################################
#                                                           #
#	print.wle.aic function                                  #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: October, 27, 2003                                 #
#	Version: 0.4-1                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

print.wle.aic <- function (x, digits = max(3, getOption("digits") - 3), num.max=max(1, nrow(x$waic)), ...) {
    res <- summary.wle.aic(object=x, num.max=num.max, ...)
    print.summary.wle.aic(res, digits=digits, ...)
}

#############################################################
#                                                           #
#	print.summary.wle.aic function                      #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

print.summary.wle.aic <- function (x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep="\n", collapse = "\n"), "\n\n", sep="")

    cat("\nWeighted Akaike Information Criterion (WAIC):\n")
    if(x$num.max>1) {
    nvar <- ncol(x$waic)-1
    x$waic[,(nvar+1)] <- signif(x$waic[,(nvar+1)],digits)
    } else {
    nvar <- length(x$waic)-1
    x$waic[(nvar+1)] <- signif(x$waic[(nvar+1)],digits)
    }
    print(x$waic)
    cat("\n")

    cat("Printed the first ",x$num.max," best models \n") 
    invisible(x)
}








#############################################################
#                                                           #
#       wle.ar.ao function                                  #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: December, 20, 2003                            #
#	Version: 0.1-3                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

wle.ar.ao <- function(x, x.init, x.seasonal.init, coef, ncoef, ncoef.seasonal, period, sigma2, xreg=NULL, raf, smooth, w.level, verbose=FALSE, ao.list, population.size=20, population.choose=5, elements.random=4, num.max, approx.w=TRUE) {

   nused <- length(x)
   xx <- wle.ar.matrix(x=x, x.init=x.init, x.seasonal.init=x.seasonal.init, ncoef=ncoef, ncoef.seasonal=ncoef.seasonal, period=period, xreg=xreg)
resid <- x - xx%*%coef

   ww <- weights <- .Fortran("wlew",
	as.double(resid), 
	as.integer(nused),
	as.double(resid), 
	as.integer(nused), 
	as.integer(raf),
	as.double(smooth),
	as.double(sigma2),
	totweight=double(1),
	weights=double(nused),
	PACKAGE="wle")$weights

   ao.position <- 0
   pos.temp <- 1:nused
   pos.temp <- pos.temp[order(weights)]
   weights.sort <- sort(weights)
   ao.temp <- weights.sort <= w.level
   pos.temp <- pos.temp[ao.temp]
   ao <- rep(FALSE, nused)
   if (length(pos.temp)) {
       pos.temp <- pos.temp[1:min(length(pos.temp),num.max)]
       ao[pos.temp] <- TRUE
   }
   pos <- (1:nused)[ao]

   if (verbose) {
        cat("We have the following observations under the w.level=",w.level,":\n",pos,"\n")
   }

   if (any(ao)) {
       model.in <- vector(length=0)
       for (i in 1:length(ao.list)) {
            if (all(is.element(ao.list[[i]], pos))) {
            temp <- vector(length=0)
            for (j in 1:length(ao.list[[i]])) {
                 temp <- c(temp,(1:length(pos))[pos==ao.list[[i]][j]])
            }
            model.in <- c(model.in, sum(2^(temp-1)))
       }
   }

   num.model <- max(length(model.in),population.size)
   num.pos <- (2^sum(ao))-1
   dim.dim <- floor(log(num.pos,2))+1
   w.tilde <- rep(0,num.model)

   model.in <- c(model.in, sample(x=(1:num.pos), size=(num.model-length(model.in)), replace=TRUE))

   for (isearch in 1:num.model) {
        pos.ao <- sort(pos[binary(model.in[isearch],dim.dim)$dicotomy])
        num.ao <- length(pos.ao)
        x.ao <- x
        xx.ao <- xx
        for (t in pos.ao) {
             if (ncoef) {
                 x.ao[t] <- xx.ao[t,]%*%coef
                 for (tt in 1:ncoef) {
                      if ((t+tt)<=nused) {  
                          xx.ao[t+tt,tt] <- x.ao[t]
                      }
                 }
             }
             if (ncoef.seasonal) {
                 for (tt in 1:ncoef.seasonal) {
                      if ((t+tt*period)<=nused) {  
                          xx.ao[t+tt*period,tt+ncoef] <- x.ao[t]
                      }
                 }
             }
        }
        resid.ao <- x - xx.ao%*%coef
        resid.ao <- resid.ao[-pos.ao]

        if (approx.w) {
            weights.temp <- approx(x=resid, y=ww, xout=resid.ao)$y 
            weights.temp[is.na(weights.temp)] <- 0
            weights.temp[weights.temp > 1] <- 1
            weights.temp[weights.temp < 0] <- 0            
        } else {
            weights.temp <- wle.weights(x=resid.ao, smooth=smooth, sigma2=sigma2, raf=raf, location=TRUE)$weights
        }
        w.tilde[isearch] <- sum(weights.temp)/nused
   }
   model.in <- model.in[order(w.tilde)]
   w.tilde <- sort(w.tilde)
   while ((model.in[1]-model.in[num.model])!=0) {
          num.model.sel <- population.choose
          cum.wtilde <- cumsum(w.tilde)[num.model.sel:num.model]
          pos.child <- vector(length=0)
          while (length(pos.child)==0) {
                 temp <- runif(2,0,cum.wtilde[length(cum.wtilde)])
                 pos.aaa <- min((num.model.sel:num.model)[cum.wtilde > temp[1]])
                 pos.bbb <- min((num.model.sel:num.model)[cum.wtilde > temp[2]])
                 pos.aa <- pos[binary(model.in[pos.aaa],dim.dim)$dicotomy]
                 pos.bb <- pos[binary(model.in[pos.bbb],dim.dim)$dicotomy]
                 pos.child <- c(pos.aa,pos.bb,pos[sample(x=(1:length(pos)), size=elements.random, replace=TRUE)])
                 pos.child <- pos.child[as.logical(sample(x=c(0,1), size=length(pos.child), replace=TRUE))]
                 pos.child <- sort(unique(pos.child))
          }
          temp.child <- vector(length=0)
          for (i in 1:length(pos.child)) {
               temp.child <- c(temp.child,(1:length(pos))[pos==pos.child[i]])
          }
          model.child <- sum(2^(temp.child-1))
          num.child <- length(pos.child)
          x.ao <- x
          xx.ao <- xx
          for (t in pos.child) {
               x.ao[t] <- xx.ao[t,]%*%coef
               if (ncoef) {
                   for (tt in 1:ncoef) {
                        if ((t+tt)<=nused) {  
                            xx.ao[t+tt,tt] <- x.ao[t]
                        }
                   }
               }
               if (ncoef.seasonal) {
                   for (tt in 1:ncoef.seasonal) {
                        if ((t+tt*period)<=nused) {  
                            xx.ao[t+tt*period,tt+ncoef] <- x.ao[t]
                        }
                   }
               }  
          }
          resid.ao <- x - xx.ao%*%coef
          resid.ao <- resid.ao[-pos.child]
          if (approx.w) {
              weights.temp <- approx(x=resid, y=ww, xout=resid.ao)$y 
              weights.temp[is.na(weights.temp)] <- 0
              weights.temp[weights.temp > 1] <- 1
              weights.temp[weights.temp < 0] <- 0
          } else {
              weights.temp <- wle.weights(x=resid.ao, smooth=smooth, sigma2=sigma2, raf=raf, location=TRUE)$weights
          }
          w.tilde.child <- sum(weights.temp)/nused
          w.tilde <- c(w.tilde,w.tilde.child)
          model.in <- c(model.in,model.child)
          model.in <- model.in[order(w.tilde)][-1]
          w.tilde <- sort(w.tilde)[-1]
   }
   if (max(w.tilde)<(sum(weights)/nused)) {
       ao.position <- NULL
   } else {
       ao.position <- sort(pos[binary(model.in[1],dim.dim)$dicotomy])
   }
} else {
   ao.position <- NULL
}

x.ao <- x
xx.ao <- xx
for (t in ao.position) {
     x.ao[t] <- xx.ao[t,]%*%coef
     if (ncoef) {
         for (tt in 1:ncoef) {
              if ((t+tt)<=nused) {  
                  xx.ao[t+tt,tt] <- x.ao[t]
              }
         }
     }
     if (ncoef.seasonal) {
         for (tt in 1:ncoef.seasonal) {
              if ((t+tt*period)<=nused) {  
                  xx.ao[t+tt*period,tt+ncoef] <- x.ao[t]
              }
         }
     }    
}

resid.ao <- x - xx.ao%*%coef
w.temp <- wle.weights(x=resid.ao, smooth=smooth, sigma2=sigma2, raf=raf, location=TRUE)
resid.ao <- resid.ao - w.temp$location

if (verbose) {
    cat("Additive outliers: \n", ao.position, "\n")
}

return(list(x.ao=x.ao, resid.ao=resid.ao, ao.position=ao.position))
}

#############################################################
#                                                           #
#	wle.ar function                                     #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: January, 5, 2004                              #
#	Version: 0.1-5                                      #
#                                                           #
#	Copyright (C) 2004 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.ar <- function(x, order=c(1,0), seasonal=list(order=c(0,0), period=NA), group, group.start, group.step=group.start, xreg=NULL, include.mean=TRUE, na.action=na.fail, tol=10^(-6), tol.step=tol, equal=10^(-3), equal.step=equal, raf="HD", smooth=0.0031, smooth.ao=smooth,  boot=10, boot.start=10, boot.step=boot.start, num.sol=1, x.init=0, x.seasonal.init=0, max.iter.out=20, max.iter.in=50, max.iter.start=200, max.iter.step=500, verbose=FALSE, w.level=0.4, min.weights=0.5, population.size=10, population.choose=5, elements.random=2, wle.start=FALSE, init.values=NULL, num.max=NULL, num.sol.step=2, approx.w=TRUE) {

if (length(order)!=2) stop("order must have two components")
if (length(seasonal$order)!=2) stop("seasonal$order must have two components")

ncoef <- order[1]
ncoef.seasonal <- seasonal$order[1]

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

result <- list()
series <- deparse(substitute(x))
if(NCOL(x) > 1)
    stop("only implemented for univariate time series")

x <- na.action(as.ts(x))
n <- length(x)
if(is.null(seasonal$period) || is.na(seasonal$period)
    || seasonal$period == 0) seasonal$period <- frequency(x)

period <- seasonal$period
arma <- c(ncoef,0,ncoef.seasonal,0,period,order[2],seasonal$order[2])

if (!(length(x.init)==1 | length(x.init)==ncoef)) stop("x.init must have one or order[1] elements\n")
if (!(length(x.seasonal.init)==1 | length(x.seasonal.init)==ncoef.seasonal*period)) stop("x.seasonal.init must have one or seasonal$order[1]*period elements\n")

d <- order[2]
d.s <- seasonal$order[2]

if (d | d.s) {
    if (any(.packages(all.available=TRUE)=="ts")) {
        library(ts)
    } else {
        stop("For Integrated model you need function diff in package ts")
    }
}

if(d) x <- diff(x, 1, d)
if(d.s) x <- diff(x, seasonal$period, d.s)

xtsp <- tsp(x)
tsp(x) <- NULL
nd <- d+d.s
nused <- length(x)

if(is.null(xreg)) {
    ncxreg <- 0
} else {
    if(NROW(xreg) != nused) stop("lengths of x and xreg do not match")
        ncxreg <- NCOL(xreg)
}

class(xreg) <- NULL

if (include.mean && (nd==0)) {
    if (is.matrix(xreg) && is.null(colnames(xreg)))
        colnames(xreg) <- paste("xreg", 1:ncxreg, sep="")
    xreg <- cbind(intercept=rep(1, nused), xreg=xreg)
    ncxreg <- ncxreg + 1
}

if (ncxreg) {
    xreg <- as.matrix(xreg)
    if (qr(xreg)$rank < ncol(xreg)) stop("xreg is collinear")
}

if (ncxreg) {
    if (d) xreg <- diff(xreg, 1, d)
    if (d.s) xreg <- diff(xreg, seasonal$period, d.s)
    xreg <- as.matrix(xreg)
    if (qr(xreg)$rank < ncol(xreg)) stop("xreg is collinear")
}

if (is.null(num.max)) num.max <- nused

# start bootstrap iteration
first.time <- TRUE
iboot <- 1
tot.sol <- 0
not.conv <- 0

while(iboot<=boot & tot.sol<num.sol) {
   pos.iboot <- round(runif(1,(group+1),nused))
   x.boot <- x[(pos.iboot-group+1):pos.iboot]
   if (is.matrix(xreg))
       xreg.boot <- xreg[(pos.iboot-group+1):pos.iboot,]
   else
       xreg.boot <- xreg[(pos.iboot-group+1):pos.iboot]
   
   if (!is.null(init.values)) {
       temp <- list(conv=TRUE)
       temp.n <- length(init.values)
       temp$coef <- init.values[1:(temp.n-1)]
       temp$sigma2 <- init.values[temp.n]
   } else {
       temp <- wle.ar.start(x=x.boot, x.init=x.init, x.seasonal.init=x.seasonal.init, ncoef=ncoef, ncoef.seasonal=ncoef.seasonal, period=period, xreg=xreg.boot, raf=raf, smooth=smooth, group=group.start, boot=boot.start, max.iter=max.iter.start, wle.start=wle.start, verbose=verbose)
   }
    
   if (temp$conv) {
       coef.init <- temp$coef
       sigma2.init <- temp$sigma2

       xx <- wle.ar.matrix(x=x, x.init=x.init, x.seasonal.init=x.seasonal.init, ncoef=ncoef, ncoef.seasonal=ncoef.seasonal, period=period, xreg=xreg)
       resid.init <- x - xx%*%coef.init

      if (verbose) {
	  cat("Initial values from the subsample ",iboot,": \n parameters: ", coef.init,"\n sigma2: ",sigma2.init," \n") 
      }

   weights <- .Fortran("wlew",
    	as.double(resid.init),
    	as.integer(nused),
	as.double(resid.init),
	as.integer(nused),
	as.integer(raf),
	as.double(smooth.ao),
	as.double(sigma2.init),
	totweights=double(1),
	weights=double(nused),
	PACKAGE="wle")$weights

   if (sum(weights)/nused >= min.weights) {

      ao.list <- list(0)
      wres <- wle.ar.ao(x=x, x.init=x.init, x.seasonal.init=x.seasonal.init, coef=coef.init, ncoef=ncoef, ncoef.seasonal=ncoef.seasonal, period=period, sigma2=sigma2.init, xreg=xreg, raf=raf, smooth=smooth.ao, w.level=w.level, verbose=verbose, ao.list=ao.list, population.size=population.size, population.choose=population.choose, elements.random=elements.random, num.max=num.max, approx.w=approx.w)

      resid.ao <- wres$resid.ao
      x.ao <- wres$x.ao
      ao.position <- wres$ao.position
      if (!is.null(ao.position)) {
      ao.list <- c(ao.list,list(ao.position))
      }
      ao.position.old <- c(ao.position,0)
      conv <- TRUE
      iter <- 0

      while (!setequal(ao.position,ao.position.old) & conv) {

    	iter <- iter + 1
    	max.tol <- tol + 1
    	ao.position.old <- ao.position	
        iter.int <- 0
    	while(max.tol>tol & conv) {
            iter.int <- iter.int + 1
	    coef.old <- coef.init

	    res <- wle.ar.step(coef=coef.init, ncoef=ncoef, ncoef.seasonal=ncoef.seasonal, period=period, x=x, xreg=xreg, x.init=x.init, x.seasonal.init=x.seasonal.init, raf=raf, smooth=smooth, sigma2=sigma2.init, num.sol=num.sol.step, ao.position=ao.position, group=group.step, boot=boot.step, max.iter=max.iter.step, verbose=verbose, tol=tol.step, equal=equal.step)

	    coef.init <- res$coef
	    sigma2.init <- res$sigma2
            
	    max.tol <- max(abs(coef.old-coef.init))

	    if (iter.int > max.iter.in) {
                if (verbose) cat("Convergence problem: maximum iteration number reached in the inner loop\n")
                conv <- FALSE
            }

	    if(any(!is.finite(coef.init)) | any(!is.finite(sigma2.init)) | (sum(res$weights)/nused < min.weights)) {
	     	if (verbose) {
                    cat("Convergence problem: some values are not finite, bad starting point or sum of the weights less than min.weights\n")
                    cat("Parameters: ",coef.init,"\n")
                    cat("Sigma2: ",sigma2.init,"\n")
                    cat("Sum of weights/size: ",sum(res$weights)/nused,"\n")
                }
	   	conv <- FALSE
	    }
      }
# end while(max.tol>tol & conv)

      if (conv) {      

	    if(verbose) {
	    	cat("iteration: ",iter," \n parameters: ",coef.init," \n sigma2: ",sigma2.init," \n")
	    }

      wres <- wle.ar.ao(x=x, x.init=x.init, x.seasonal.init=x.seasonal.init, coef=coef.init, ncoef=ncoef, ncoef.seasonal=ncoef.seasonal, period=period, sigma2=sigma2.init, xreg=xreg, raf=raf, smooth=smooth.ao, w.level=w.level, verbose=verbose, ao.list=ao.list, population.size=population.size, population.choose=population.choose, elements.random=elements.random, num.max=num.max, approx.w=approx.w)

      resid.ao <- wres$resid.ao
      x.ao <- wres$x.ao
      ao.position <- wres$ao.position
      if (!is.null(ao.position)) {
      ao.list <- c(ao.list,list(ao.position))
      }

      if ((lao <- length(ao.list))>2) {
         for (i.ao in 1:(lao-2)) {
            if (setequal(ao.list[[lao]],ao.list[[i.ao]])) {
                conv <- FALSE
            }
         } 
      }

      if(iter > max.iter.out) {
      if (verbose) cat("Convergence problem: maximum iteration number reached in the outer loop\n")
      conv <- FALSE
      }

    } 

    }
# end while (!setequal(ao.position,ao.position.old) & conv)

    if (conv) {

    xx <- wle.ar.matrix(x=x, x.init=x.init, x.seasonal.init=x.seasonal.init, ncoef=ncoef, ncoef.seasonal=ncoef.seasonal, period=period, xreg=xreg)
    resid.init <- c(x - xx%*%coef.init)  
    resid.init <- ts(resid.init, start=start(x), end=end(x), frequency=frequency(x))
    class(resid.init) <- "ts"

    weights.with.ao <- wle.weights(x=resid.init, smooth=smooth, sigma2=res$sigma2, raf=raf, tol=tol, location=TRUE)$weights
    
    resid <- ts(res$resid, start=start(x), end=end(x), frequency=frequency(x))        
    class(resid) <- "ts" 

    xx.ao <- wle.ar.matrix(x=x.ao, x.init=x.init, x.seasonal.init=x.seasonal.init, ncoef=ncoef, ncoef.seasonal=ncoef.seasonal, period=period, xreg=xreg)
    resid.ao <- c(x - xx.ao%*%coef.init)  
    resid.ao <- ts(resid.ao, start=start(x), end=end(x), frequency=frequency(x))

    weights.without.ao <- wle.weights(x=resid.ao, smooth=smooth, sigma2=res$sigma2, raf=raf, tol=tol, location=TRUE)$weights
    
    class(resid.ao) <- "ts" 
    x.ao <- ts(res$x.ao, start=start(x), end=end(x), frequency=frequency(x))
    class(x.ao) <- "ts" 

    if(first.time) {
    coef.final <- res$coef
    sigma2.coef.final <- res$sigma2.coef
    weights.final <- res$weights
    weights.final.with.ao <- weights.with.ao
    weights.final.without.ao <- weights.without.ao   
    sigma2.final <- res$sigma2
    resid.final <- resid
    resid.ao.final <- resid.ao
    x.ao.final <- x.ao
    resid.init.final <- resid.init
    ao.position.final <- list(wres$ao.position)
    first.time <- FALSE	
    tot.sol <- 1
    } else {
    if(min(abs(coef.final-res$coef))>equal) {
	tot.sol <- tot.sol+1
	coef.final <- rbind(coef.final,res$coef)
        sigma2.coef.final <- rbind(sigma2.coef.final,res$sigma2.coef)
	weights.final <- rbind(weights.final,res$weights)
        weights.final.with.ao <- rbind(weights.final.with.ao, weights.with.ao)
        weights.final.without.ao <- rbind(weights.final.without.ao, weights.without.ao)        
	sigma2.final <- c(sigma2.final,res$sigma2)
	resid.final <- rbind(resid.final,resid)
        ao.position.final <- c(ao.position.final,list(wres$ao.position))        
	resid.ao.final <- rbind(resid.ao.final,resid.ao)
        x.ao.final <- rbind(x.ao.final,x.ao)
        resid.init.final <- rbind(resid.init.final,resid.init)
	}
    }
    } else {
    	not.conv <- not.conv+1
    }
    } else {
    	not.conv <- not.conv+1
    }
    } else {
    	not.conv <- not.conv+1
    }    

iboot <- iboot+1
}
# end bootstrap iteration

if(tot.sol==0) {
   
    result$coef <- NULL
    result$sigma2.coef <- NULL
    result$sigma2 <- NULL
    result$arma <- arma
    result$resid <- NULL
    result$resid.with.ao <- NULL
    result$resid.without.ao <- NULL
    result$x.ao <- NULL
    result$call <- match.call()
    result$series <- series
    result$weights <- NULL
    result$weights.with.ao <- NULL
    result$weights.without.ao <- NULL   
    result$tot.sol <- tot.sol
    result$not.conv <- not.conv
    result$ao.position <- NULL

} else {

    nm <- NULL
    if(arma[1] > 0) nm <- c(nm, paste("ar", 1:arma[1], sep=""))
    if(arma[2] > 0) nm <- c(nm, paste("ma", 1:arma[2], sep=""))
    if(arma[3] > 0) nm <- c(nm, paste("sar", 1:arma[3], sep=""))
    if(arma[4] > 0) nm <- c(nm, paste("sma", 1:arma[4], sep=""))
    if(ncxreg > 0)
        if(!is.null(cn <- colnames(xreg))) nm <- c(nm, cn)
        else nm <- c(nm, paste("xreg", 1:ncxreg, sep=""))
    if(tot.sol==1) {
    	names(coef.final) <- nm
        names(sigma2.coef.final) <- nm
    } else {
	colnames(coef.final) <- nm
	rownames(coef.final) <- paste("root", 1:tot.sol, sep=" ")
	colnames(sigma2.coef.final) <- nm
	rownames(sigma2.coef.final) <- paste("root", 1:tot.sol, sep=" ")
	rownames(weights.final) <- paste("root", 1:tot.sol, sep=" ")
	rownames(resid.init.final) <- paste("root", 1:tot.sol, sep=" ")
	rownames(resid.final) <- paste("root", 1:tot.sol, sep=" ")
	rownames(resid.ao.final) <- paste("root", 1:tot.sol, sep=" ")
	rownames(x.ao.final) <- paste("root", 1:tot.sol, sep=" ")
    }	
    names(arma) <- c("ar", "ma", "sar", "sma", "period", "diff", "sdiff")


    result$coef <- coef.final
    result$sigma2.coef <- sigma2.coef.final
    result$sigma2 <- sigma2.final
    result$arma <- arma
    result$resid <- resid.final
    result$resid.without.ao <- resid.ao.final
    result$resid.with.ao <- resid.init.final
    result$x.ao <- x.ao.final
    result$call <- match.call()
    result$series <- series
    result$weights <- weights.final
    result$weights.with.ao <- weights.final.with.ao
    result$weights.without.ao <- weights.final.without.ao   
    result$tot.sol <- tot.sol
    result$not.conv <- not.conv
    result$ao.position <- ao.position.final
    }

    class(result) <- "wle.arima"
    
return(result)
}

#############################################################
#                                                           #
#	wle.ar.step function                                #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: December, 30, 2003                            #
#	Version: 0.1-3                                      #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.ar.step <- function(coef, ncoef, ncoef.seasonal, period, x, xreg, x.init, x.seasonal.init, raf, smooth, sigma2, ao.position, group, boot, max.iter, verbose, num.sol=2, tol, equal) {

result <- list()
nused <- length(x)

if (is.null(xreg)) {
    ncxreg <- 0
} else {
    ncxreg <- NCOL(xreg)
}
 
x.ao <- x
xx.ao <- wle.ar.matrix(x=x.ao, x.init=x.init, x.seasonal.init=x.seasonal.init, ncoef=ncoef, ncoef.seasonal=ncoef.seasonal, period=period, xreg=xreg)
for (t in ao.position) {
     x.ao[t] <- xx.ao[t,]%*%coef
     if (ncoef) {
         for (tt in 1:ncoef) {
              if ((t+tt)<=nused) {  
                  xx.ao[t+tt,tt] <- x.ao[t]
              }
         }
     }
     if (ncoef.seasonal) {
         for (tt in 1:ncoef.seasonal) {
              if ((t+tt*period)<=nused) {  
                  xx.ao[t+tt*period,tt+ncoef] <- x.ao[t]
              }
         }
     }
}

#     print(coef)
#     print(cbind(ao.position,x.ao[ao.position]))

if (qr(xx.ao)$rank==NCOL(xx.ao)) {
    temp.wle <- wle.lm(x.ao~xx.ao -1, boot=boot, smooth=smooth, num.sol=num.sol, group=group, max.iter=max.iter, tol=tol, equal=equal)
} else {
    if (verbose) cat("wle.ar.step: the matrix is not full rank\n")
    temp.wle <- list()
    temp.wle$tot.sol==0
}

if (temp.wle$tot.sol!=0) {
  
    if (verbose) {
        cat("Number of solutions: ",temp.wle$tot.sol," found on ",num.sol,"\n")
        cat("Parameters: ",temp.wle$coefficients,"\n")
        cat("Sigma2: ",temp.wle$scale^2,"\n")
    }

if (temp.wle$tot.sol>1) {
    ccc <- c(coef,sigma2)
    dist <- rep(0,temp.wle$tot.sol)
    for (k in 1:temp.wle$tot.sol) {
         dist[k] <- sum((ccc-c(temp.wle$coefficients[k,],temp.wle$scale[k]^2))^2)
    }
    root <- (1:temp.wle$tot.sol)[dist==min(dist)]
    if (verbose) cat("We use root: ",root,"\n")
    ttt <- list()
    ttt$coefficients <- temp.wle$coefficients[root,]
    ttt$residuals <- temp.wle$residuals[root,]
    ttt$scale <- temp.wle$scale[root]
    ttt$weights <- temp.wle$weights[root,]
    temp.wle <- ttt
}

   result$coef <- temp.wle$coefficients
   result$resid <- temp.wle$residuals
   result$sigma2 <- temp.wle$scale^2
   result$weights <- temp.wle$weights
   result$weights[ao.position] <- 0 
   result$sigma2.coef <- diag(result$sigma2*solve(t(xx.ao)%*%diag(result$weights)%*%xx.ao, tol=1e-10))
   result$resid.ao <- temp.wle$residuals
   result$x.ao <- x.ao
   result$sol <- 1
} else {
   result$sol <- 0
   result$coef <- rep(NA,ncol(xx.ao))
   result$sigma2 <- NA
}

return(result)
}

#############################################################
#                                                           #
#	wle.ar.matrix function                              #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: September, 26, 2001                           #
#	Version: 0.1                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.ar.matrix <- function(x, x.init=0, x.seasonal.init=0, ncoef, ncoef.seasonal, period, xreg=NULL) {

nused <- length(x)

if(is.null(xreg)) {
    ncxreg <- 0
    xreg <- NULL
} else {
    ncxreg <- NCOL(xreg)
}

xx <- vector(length=0)
if (length(x.init)==ncoef) {
    x.temp <- c(x.init,x)
} else {
    x.temp <- c(rep(x.init,ncoef),x)
}

for (i in 1:ncoef) {
     xx <- cbind(xx,x.temp[(ncoef-i+1):(nused+ncoef-i)])
}

if (ncoef.seasonal) {
    if (length(x.seasonal.init)==ncoef.seasonal*period) {
        x.temp <- c(x.seasonal.init,x)
    } else {
        x.temp <- c(rep(x.seasonal.init,ncoef.seasonal*period),x)
    }

    for (i in 1:ncoef.seasonal) {
        xx <- cbind(xx,x.temp[((ncoef.seasonal-i)*period+1):(nused+(ncoef.seasonal-i)*period)])
    }
}

if (ncxreg) xx <- cbind(xx,xreg)

return(xx)
}



#############################################################
#                                                           #
#	wle.ar.start function                               #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: September, 26, 2001                           #
#	Version: 0.1                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.ar.start <- function(x, x.init, x.seasonal.init, ncoef, ncoef.seasonal, period, xreg, raf, smooth, group, boot, max.iter, wle.start, verbose=FALSE) {

result <- list()
nused <- length(x)

xx <- wle.ar.matrix(x=x, x.init=x.init, x.seasonal.init=x.seasonal.init, ncoef=ncoef, ncoef.seasonal=ncoef.seasonal, period=period, xreg=xreg)

if (qr(xx)$rank==NCOL(xx)) {

    if (wle.start) {
        temp <- wle.lm(x~xx -1, raf=raf, smooth=smooth, group=group, boot=boot, max.iter=max.iter, verbose=verbose, num.sol=1)
        tot.sol <- temp$tot.sol
    } else {
        temp <- lm(x~xx -1)
        tot.sol <- 1
    }

    if (tot.sol) {
        resid <- temp$resid
        result$coef <- temp$coef
        result$resid <- temp$resid
        if (wle.start) {
            result$sigma2 <- temp$scale^2
        } else {
            result$sigma2 <- (summary(temp)$sigma)^2
        }
        result$conv <- TRUE
    } else {
        result$coef <- rep(NA,ncoef)
        result$resid <- rep(NA,nused)
        result$sigma2 <- NA
        result$conv <- FALSE
    }
} else {
    result$coef <- rep(NA,ncoef)
    result$resid <- rep(NA,nused)
    result$sigma2 <- NA
    result$conv <- FALSE
}
     
return(result)
}

#############################################################
#                                                           #
#	wle.binomial function                               #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.2                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.binomial <- function(x, size, boot=30, group, num.sol=1, raf="HD", tol=10^(-6), equal=10^(-3), max.iter=500, verbose=FALSE) {

result <- list()

if (raf!="HD" & raf!="NED" & raf!="SCHI2") stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

if (missing(group)) {
group <- 0
}

x <- as.vector(x)
nsize <- length(x)
result <- list()

if (nsize<1) {
stop("Number of observation must be at least equal to 1")
}

if (group<1) {
    group <- max(round(nsize/4),1)
    if (verbose) cat("wle.binomial: dimension of the subsample set to default value: ",group,"\n")
}

maxboot <- sum(log(1:nsize))-(sum(log(1:group))+sum(log(1:(nsize-group))))

if (boot<1 | log(boot) > maxboot) {
    stop("Bootstrap replication not in the range")
}

if (!(num.sol>=1)) {
    if (verbose) cat("wle.binomial: number of solution to report set to 1 \n")
    num.sol <- 1
}

if (max.iter<1) {
    if (verbose) cat("wle.binomial: max number of iteration set to 500 \n")
    max.iter <- 500
}

if (tol<=0) {
    if (verbose) cat("wle.binomial: the accuracy must be positive, using default value: 10^(-6) \n")
    tol <- 10^(-6)
}

if (equal<=tol) {
    if (verbose) cat("wle.binomial: the equal parameter must be greater than tol, using default value: tol+10^(-3) \n")
    equal <- tol+10^(-3)
}

tot.sol <- 0
not.conv <- 0
iboot <- 0

while (tot.sol < num.sol & iboot < boot) {
   iboot <- iboot + 1
   x.boot <- x[round(runif(group,0.501,nsize+0.499))]
   p <- sum(x.boot)/(size*group)

   ff <- rep(0,nsize)
   x.diff <- tol + 1
   iter <- 0
   while (x.diff > tol & iter < max.iter) {
   iter <- iter + 1
   p.old <- p 
       tff <- table(x)/nsize
       nff <- as.numeric(names(tff))
       for (i in 1:nsize) {
           ff[i] <- tff[nff==x[i]] 
       }
       mm <- dbinom(x,size=size,prob=p)
       dd <- ff/mm - 1
       
       ww <- switch(raf,
                 HD =  2*(sqrt(dd + 1) - 1) ,
	         NED =  2 - (2 + dd)*exp(-dd) ,
	         SCHI2 =  1-(dd^2/(dd^2 +2)) )       

       if (raf=="HD" | raf=="NED") {
            ww <- (ww + 1)/(dd + 1)
       }

       ww[ww > 1] <- 1
       ww[ww < 0] <- 0

       p <- ww%*%x/(sum(ww)*size)

       x.diff <- abs(p - p.old)
   }
#### end of while (x.diff > tol & iter < max.iter)

   if (iter < max.iter) {

   if (tot.sol==0) {
      p.store <- p
      w.store <- ww
      m.store <- mm
      f.store <- ff
      d.store <- dd
      tot.sol <- 1
   } else {
      if (min(abs(p.store-p))>equal) {
          p.store <- c(p.store,p)
          w.store <- rbind(w.store,ww)
          m.store <- rbind(m.store,mm)
          f.store <- rbind(f.store,ff)
          d.store <- rbind(d.store,dd)
          tot.sol <- tot.sol + 1
      }
   }

   } else not.conv <- not.conv + 1
   

}
##### end of while (tot.sol < num.sol & iboot < boot)

if (tot.sol) {
    result$p <- p.store
    result$tot.weights <- sum(ww)/nsize
    result$weights <- w.store
    result$delta <- d.store
    result$f.density <- f.store
    result$m.density <- m.store
    result$tot.sol <- tot.sol
    result$not.conv <- not.conv
    result$call <- match.call()
} else {
    if (verbose) cat("wle.binomial: No solutions are fuond, checks the parameters\n")
    result$p <- NA
    result$tot.weights <- NA
    result$weights <- rep(NA,nsize)
    result$delta <- rep(NA,nsize)
    result$f.density <- rep(NA,nsize)
    result$m.density <- rep(NA,nsize)
    result$tot.sol <- 0
    result$not.conv <- boot
    result$call <- match.call()
}

class(result) <- "wle.binomial"

return(result)
}

#############################################################
#                                                           #
#	print.wle.binomial function                         #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.2                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

print.wle.binomial <- function(x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    cat("p:\n")
    print.default(format(x$p, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("\nNumber of solutions ",x$tot.sol,"\n")
    cat("\n")
    invisible(x)
}



#############################################################
#                                                           #
#	wle.cp function                                     #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.cp <- function(formula, data=list(), model=TRUE, x=FALSE, y=FALSE, boot=30, group, var.full=0, num.sol=1, raf="HD", smooth=0.031, tol=10^(-6), equal=10^(-3), max.iter=500, min.weight=0.5, method="full", alpha=2, contrasts=NULL, verbose=FALSE) {

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

type <- switch(method,
	full = 0,
	reduced = 1,
	-1)

if (type==-1) stop("Please, choose the method: full=wieghts based on full model, reduced=weights based on the actual model")

if (missing(group)) {
group <- 0
}

    ret.x <- x
    ret.y <- y
    result <- list()	
    mt <- terms(formula, data = data)
    mf <- cl <- match.call()
    mf$boot <- mf$group <- mf$smooth <- NULL
    mf$tol <- mf$equal <- mf$num.sol <- NULL
    mf$min.weight <- mf$max.iter <- mf$raf <- NULL
    mf$var.full <- mf$alpha <- mf$contrasts <- NULL
    mf$model <- mf$x <- mf$y <- mf$method <- NULL
    mf$verbose <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    xvars <- as.character(attr(mt, "variables"))[-1]
    inter <- attr(mt, "intercept")
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <-
	if(length(xvars) > 0) {
	    xlev <- lapply(mf[xvars], levels)
	    xlev[!sapply(xlev, is.null)]
	}
    ydata <- model.response(mf, "numeric")
    if (is.empty.model(mt)) 
	stop("The model is empty")
    else 
	xdata <- model.matrix(mt, mf, contrasts)

if (is.null(size <- nrow(xdata)) | is.null(nvar <- ncol(xdata))) stop("'x' must be a matrix")
if (length(ydata)!=size) stop("'y' and 'x' are not compatible")

nrep <- 2^nvar-1

if (size<nvar) {
stop("Number of observations must be at least equal to the number of predictors (including intercept)")
}

if (group<nvar) {
    group <- max(round(size/4),nvar)
    if (verbose) cat("wle.cp: dimension of the subsample set to default value = ",group,"\n")
}

maxboot <- sum(log(1:size))-(sum(log(1:group))+sum(log(1:(size-group))))

if (boot<1 | log(boot) > maxboot) {
    stop("Bootstrap replication not in the range")
}


if (!(num.sol>=1)) {
    if (verbose) cat("wle.cp: number of solution to report set to 1 \n")
    num.sol <- 1
}

if (max.iter<1) {
    if (verbose) cat("wle.cp: max number of iteration set to 500 \n")
    max.iter <- 500
}

if (smooth<10^(-5)) {
    if (verbose) cat("wle.cp: the smooth parameter seems too small \n")
}

if (tol<=0) {
    if (verbose) cat("wle.cp: the accuracy must be positive, using default value:  10^(-6) \n")
    tol <- 10^(-6)
}
if (equal<=tol) {
    if (verbose) cat("wle.cp: the equal parameter must be greater than tol, using default value: tol+10^(-3)\n")
    equal <- tol+10^(-3)
}

if (var.full<0) {
    if (verbose) cat("wle.cp: the variance of the full model can not be negative, using default value \n")
    var.full <- 0
}

if (min.weight<0) {
    if (verbose) cat("wle.cp: the minimum sum of the weights can not be negative, using default value \n")
    min.weight <- 0.5
}

  z <- .Fortran("wlecp",
	as.double(ydata),
	as.matrix(xdata),
	as.integer(0), 
	as.integer(size),
	as.integer(nvar),
	as.integer(boot),
	as.integer(group),
	as.integer(nrep),
	as.integer(raf),
	as.double(smooth),
	as.double(tol),
	as.double(equal),
	as.integer(max.iter),
	as.double(var.full),
	as.integer(num.sol),
	as.double(min.weight),
	as.integer(type),
	as.double(alpha),
	wcp=mat.or.vec(nrep*num.sol,nvar+1),
        param=mat.or.vec(nrep*num.sol,nvar),
	var=double(nrep*num.sol),
	resid=mat.or.vec(nrep*num.sol,size),
	totweight=double(nrep*num.sol),
	weight=mat.or.vec(nrep*num.sol,size),
	same=integer(nrep*num.sol),
	info=integer(1),
	PACKAGE = "wle")

delnull <- z$same==0

result$wcp <- z$wcp[!delnull,]
result$coefficients <- z$param[!delnull,]
result$scale <- sqrt(z$var[!delnull])
result$residuals <- z$resid[!delnull]
result$weights <- z$weight[!delnull,]
result$tot.weights <- z$totweight[!delnull]
result$freq <- z$same[!delnull]
result$call <- cl
result$info <- z$info
result$contrasts <- attr(xdata, "contrasts")
result$xlevels <- xlev
result$terms <- mt

if (model)
    result$model <- mf
if (ret.x)
    result$x <- xdata
if (ret.y)
    result$y <- ydata

dn <- colnames(xdata)
dimnames(result$coefficients) <- list(NULL,dn)
dimnames(result$wcp) <- list(NULL,c(dn,"wcp"))

class(result) <- "wle.cp"

return(result)

}

#############################################################
#                                                           #
#	summary.wle.cp function                                 #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: October, 28, 2003                                 #
#	Version: 0.4-1                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

summary.wle.cp <- function (object, num.max=20, verbose=FALSE, ...) {

if (is.null(object$terms)) {
    stop("invalid \'wle.cp\' object")
}

if (num.max<1) {
    if (verbose) cat("summary.wle.cp: num.max can not less than 1, num.max=1 \n")
    num.max <- 1
}

ans <- list()
wcp <- object$wcp
if(is.null(nmodel <- nrow(wcp))) nmodel <- 1
num.max <- min(nmodel,num.max)

if (nmodel!=1) { 
    nvar <- ncol(wcp)-1
    nparam <- apply(wcp[,(1:nvar)],1,sum)
    wcp <- wcp[wcp[,(nvar+1)]<=(nparam+0.00001),]
    if (!is.null(nrow(wcp)) && nrow(wcp)>1) {
	num.max <- min(nrow(wcp),num.max)
    	wcp <- wcp[order(wcp[,(nvar+1)]),]
    	wcp <- wcp[1:num.max,]
    } else num.max <- 1
}

ans$wcp <- wcp
ans$num.max <- num.max
ans$call <- object$call

class(ans) <- "summary.wle.cp"
return(ans)
}

#############################################################
#                                                           #
#	print.wle.cp function                                   #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: October, 27, 2003                                 #
#	Version: 0.4-1                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

print.wle.cp <- function (x, digits = max(3, getOption("digits") - 3), num.max=max(1, nrow(x$wcp)),  ...) {
    res <- summary.wle.cp(object=x, num.max=num.max, ...)
    print.summary.wle.cp(res, digits=digits, ...)
}

#############################################################
#                                                           #
#	print.summary.wle.cp function                       #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

print.summary.wle.cp <- function (x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep="\n", collapse = "\n"), "\n\n", sep="")

    cat("\nWeighted Mallows Cp:\n")
    if(x$num.max>1) {
    nvar <- ncol(x$wcp)-1
    x$wcp[,(nvar+1)] <- signif(x$wcp[,(nvar+1)],digits)
    } else {
    nvar <- length(x$wcp)-1
    x$wcp[(nvar+1)] <- signif(x$wcp[(nvar+1)],digits)
    }
    print(x$wcp)
    cat("\n")

    cat("Printed the first ",x$num.max," best models \n") 
    invisible(x)
}



#############################################################
#                                                           #
#	wle.cv function                                         #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: April, 02, 2002                                   #
#	Version: 0.4-1                                          #
#                                                           #
#	Copyright (C) 2002 Claudio Agostinelli                  #
#                                                           #
#############################################################

wle.cv <- function(formula, data=list(), model=TRUE, x=FALSE, y=FALSE, monte.carlo=500, split, boot=30, group, num.sol=1, raf="HD", smooth=0.031, tol=10^(-6), equal=10^(-3), max.iter=500, min.weight=0.5, contrasts=NULL, verbose=FALSE) {

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

if (missing(group)) {
group <- 0
}

if (missing(split)) {
split <- 0
}

    ret.x <- x
    ret.y <- y
    result <- list()	
    mt <- terms(formula, data = data)
    mf <- cl <- match.call()
    mf$monte.carlo <- mf$split <- NULL
    mf$boot <- mf$group <- mf$smooth <- NULL
    mf$tol <- mf$equal <- mf$num.sol <- NULL
    mf$min.weight <- mf$max.iter <- mf$raf <- NULL
    mf$contrasts <- NULL
    mf$model <- mf$x <- mf$y <- NULL
    mf$verbose <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    xvars <- as.character(attr(mt, "variables"))[-1]
    inter <- attr(mt, "intercept")
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <-
	if(length(xvars) > 0) {
	    xlev <- lapply(mf[xvars], levels)
	    xlev[!sapply(xlev, is.null)]
	}
    ydata <- model.response(mf, "numeric")
    if (is.empty.model(mt)) 
	stop("The model is empty")
    else 
	xdata <- model.matrix(mt, mf, contrasts)

if (is.null(size <- nrow(xdata)) | is.null(nvar <- ncol(xdata))) stop("'x' must be a matrix")
if (length(ydata)!=size) stop("'y' and 'x' are not compatible")

nrep <- 2^nvar-1

if (size<nvar) {
stop("Number of observations must be at least equal to the number of predictors (including intercept)")
}

if (group<nvar) {
    group <- max(round(size/4),nvar)
    if (verbose) cat("wle.cv: dimension of the subsample set to default value = ",group,"\n")
}

maxboot <- sum(log(1:size))-(sum(log(1:group))+sum(log(1:(size-group))))

if (boot<1 | log(boot) > maxboot) {
    stop("Bootstrap replication not in the range")
}

if (split<nvar+2 | split>(size-2)) {
    split <- max(round(size^(3/4)),nvar+2)
    if (verbose) cat("wle.cv: dimension of the split subsample set to default value = ",split,"\n")
}

maxcarlo <- sum(log(1:size))-(sum(log(1:split))+sum(log(1:(size-split))))

if (monte.carlo<1 | log(monte.carlo) > maxcarlo) {
    stop("MonteCarlo replication not in the range")
}

if (!(num.sol>=1)) {
    if (verbose) cat("wle.cv:number of solution to report set to 1 \n")
    num.sol <- 1
}

if (max.iter<1) {
    if (verbose) cat("wle.cv: max number of iteration set to 500 \n")
    max.iter <- 500
}

if (smooth<10^(-5)) {
    if (verbose) cat("wle.cv: the smooth parameter seems too small \n")
}

if (tol<=0) {
    if (verbose) cat("wle.cv: the accuracy must be positive, using default value: 10^(-6) \n")
    tol <- 10^(-6)
}

if (equal<=tol) {
    if (verbose) cat("wle.cv: the equal parameter must be greater than tol, using default value: tol+10^(-3) \n")
    equal <- tol+10^(-3)
}

if (min.weight<0) {
    if (verbose) cat("wle.cv: the minimum sum of the weights can not be negative, using default value \n")
    min.weight <- 0.5
}

  z <- .Fortran("wlecv",
	as.double(ydata),
	as.matrix(xdata),
	as.integer(0), 
	as.integer(size),
	as.integer(nvar),
	as.integer(boot),
	as.integer(group),
	as.integer(nrep),
	as.integer(monte.carlo),
	as.integer(split),
	as.integer(raf),
	as.double(smooth),
	as.double(tol),
	as.double(equal),
	as.integer(max.iter),
	as.integer(num.sol),
	as.double(min.weight),
	wcv=mat.or.vec(nrep,nvar+1),
	param=mat.or.vec(num.sol,nvar),
	var=double(num.sol),
	resid=mat.or.vec(num.sol,size),
	totweight=double(num.sol),
	weight=mat.or.vec(num.sol,size),
	same=integer(num.sol),
	index=integer(1),
	info=integer(1),
	PACKAGE="wle")

delnull <- z$same==0

result$wcv <- z$wcv
result$coefficients <- z$param[!delnull,]
result$scale <- sqrt(z$var[!delnull])
result$residuals <- z$resid[!delnull]
result$weights <- z$weight[!delnull,]
result$tot.weights <- z$totweight[!delnull]
result$freq <- z$same[!delnull]
result$call <- cl
result$info <- z$info
result$index <- z$index
result$contrasts <- attr(xdata, "contrasts")
result$xlevels <- xlev
result$terms <- mt

if (model)
    result$model <- mf
if (ret.x)
    result$x <- xdata
if (ret.y)
    result$y <- ydata

dn <- colnames(xdata)
if (is.null(nrow(result$coefficients))) {
names(result$coefficients) <- dn
} else {
dimnames(result$coefficients) <- list(NULL,dn)
}
dimnames(result$wcv) <- list(NULL,c(dn,"wcv"))

class(result) <- "wle.cv"

return(result)
}

#############################################################
#                                                           #
#	summary.wle.cv function                             #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: December, 3, 2001                             #
#	Version: 0.4-1                                      #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

summary.wle.cv <- function (object, num.max=20, verbose=FALSE, ...) {

if (is.null(object$terms)) {
    stop("invalid \'wle.cv\' object")
}

if (num.max<1) {
    if (verbose) cat("summary.wle.cv: num.max can not less than 1, num.max=1 \n")
    num.max <- 1
}

ans <- list()
wcv <- object$wcv
if(is.null(nmodel <- nrow(wcv))) nmodel <- 1
num.max <- min(nmodel,num.max)
if (nmodel!=1) { 
nvar <- ncol(wcv)-1
wcv <- wcv[order(wcv[,(nvar+1)]),]
wcv <- wcv[1:num.max,]
}

ans$wcv <- wcv
ans$num.max <- num.max
ans$call <- object$call

class(ans) <- "summary.wle.cv"
return(ans)
}

#############################################################
#                                                           #
#	print.wle.cv function                                   #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: October, 27, 2003                                 #
#	Version: 0.4-1                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

print.wle.cv <- function (x, digits = max(3, getOption("digits") - 3), num.max=max(1, nrow(x$wcv)), ...) {
    res <- summary.wle.cv(object=x, num.max=num.max, ...)
    print.summary.wle.cv(res, digits=digits, ...)
}

#############################################################
#                                                           #
#	print.summary.wle.cv function                       #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

print.summary.wle.cv <- function (x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep="\n", collapse = "\n"), "\n\n", sep="")

    cat("\nWeighted Cross Validation selection criteria:\n")
    if(x$num.max>1) {
    nvar <- ncol(x$wcv)-1
    x$wcv[,(nvar+1)] <- signif(x$wcv[,(nvar+1)],digits)
    } else {
    nvar <- length(x$wcv)-1
    x$wcv[(nvar+1)] <- signif(x$wcv[(nvar+1)],digits)
    }
    print(x$wcv)
    cat("\n")

    cat("Printed the first ",x$num.max," best models \n") 
    invisible(x)
}



#############################################################
#                                                           #
#	wle.fracdiff.ao function                                #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: April, 08, 2002                                   #
#	Version: 0.2-2                                          #
#                                                           #
#     Copyright (C) 2002 Claudio Agostinelli                #
#                                                           #
#############################################################

wle.fracdiff.ao <- function(d, sigma2, x, M=100, x.init=rep(0,M), x.mean=0, use.init=FALSE, raf=1, smooth=0.0031, w.level=0.5, verbose=FALSE, ao.list=list(0), population.size=20, population.choose=5, elements.random=4, num.max=length(x)) {

    if (use.init) {
        MM <- 0
    } else {
        MM <- M
    }

    nused <- length(x)
    resid <- wle.fracdiff.residuals(d=d, M=M, x=x, x.ao=x, x.init=x.init, x.mean=x.mean, use.init=use.init)  
    nresid <- length(resid)

    weights <- .Fortran("wlew",
	as.double(resid), 
	as.integer(nresid),
	as.double(resid), 
	as.integer(nresid), 
	as.integer(raf),
	as.double(smooth),
	as.double(sigma2),
	totweight=double(1),
	weights=double(nresid),
	PACKAGE="wle")$weights

    ao.position <- 0
    pos.temp <- 1:nresid
    pos.temp <- pos.temp[order(weights)]
    weights.sort <- sort(weights)
    ao.temp <- weights.sort <= w.level
    pos.temp <- pos.temp[ao.temp]+MM
    ao <- rep(FALSE,nused)
    if (length(pos.temp)) {
        pos.temp <- pos.temp[1:min(length(pos.temp),num.max)]
        ao[pos.temp] <- TRUE
    }

    pos <- (1:nused)[ao]

    if (verbose) {
        cat("We have the following observations under the w.level=",w.level,":\n",pos,"\n")
    }

    if (any(ao)) {
        model.in <- vector(length=0)

        for (i in 1:length(ao.list)) {
             if (all(is.element(ao.list[[i]],pos))) {
                 temp <- vector(length=0)
                 for (j in 1:length(ao.list[[i]])) {
                      temp <- c(temp,(1:length(pos))[pos==ao.list[[i]][j]])
                 }
                 model.in <- c(model.in,sum(2^(temp-1)))
             }
         }

         num.model <- max(length(model.in),population.size)
         num.pos <- (2^sum(ao))-1
         dim.dim <- floor(log(num.pos,2))+1
         w.tilde <- rep(0,num.model)

         model.in <- c(model.in, sample(x=(1:num.pos), size=(num.model-length(model.in)), replace=TRUE))
#################wle.riunif((num.model-length(model.in)),1,num.pos))

         for (isearch in 1:num.model) {
              pos.ao <- sort(pos[binary(model.in[isearch],dim.dim)$dicotomy])
              num.ao <- length(pos.ao)
              x.ao <- x
              for (t in pos.ao) {
                   x.ao[t] <- wle.fracdiff.fitted(t=t, d=d, M=M, x=x.ao, x.init=x.init, x.mean=x.mean, use.init=use.init)
              }
              resid.ao <- wle.fracdiff.residuals(d=d, M=M, x=x, x.ao=x.ao, x.init=x.init, x.mean=x.mean, use.init=use.init) 
              resid.ao <- resid.ao[-pos.ao]
              w.temp <- wle.weights(x=resid.ao, smooth=smooth, sigma2=sigma2, raf=raf, location=TRUE)

              weights.temp <- w.temp$weights
              w.tilde[isearch] <- sum(weights.temp)/nresid
         }

         model.in <- model.in[order(w.tilde)]
         w.tilde <- sort(w.tilde)

         while ((model.in[1]-model.in[num.model])!=0) {
                num.model.sel <- population.choose
                cum.wtilde <- cumsum(w.tilde)[num.model.sel:num.model]
                pos.child <- vector(length=0)

                while (length(pos.child)==0) {
                       temp <- runif(2,0,cum.wtilde[length(cum.wtilde)])
                       pos.aaa <- min((num.model.sel:num.model)[cum.wtilde > temp[1]])
                       pos.bbb <- min((num.model.sel:num.model)[cum.wtilde > temp[2]])

                       pos.aa <- pos[binary(model.in[pos.aaa],dim.dim)$dicotomy]
                       pos.bb <- pos[binary(model.in[pos.bbb],dim.dim)$dicotomy]

                       pos.child <- c(pos.aa,pos.bb,pos[sample(x=(1:length(pos)), size=elements.random, replace=TRUE)])
#####################wle.riunif(elements.random,1,length(pos))])
                       
                       pos.child <- pos.child[as.logical(sample(x=c(0,1), size=length(pos.child), replace=TRUE))]
######################wle.riunif(length(pos.child),0,1))]
                       pos.child <- sort(unique(pos.child))
                }

                temp.child <- vector(length=0)
                for (i in 1:length(pos.child)) {
                     temp.child <- c(temp.child,(1:length(pos))[pos==pos.child[i]])
                }

                model.child <- sum(2^(temp.child-1))

                num.child <- length(pos.child)
                x.ao <- x
                for (t in pos.child) {
                     x.ao[t] <- wle.fracdiff.fitted(t=t, d=d, M=M, x=x.ao, x.init=x.init, x.mean=x.mean, use.init=use.init)
                }

                resid.ao <- wle.fracdiff.residuals(d=d, M=M, x=x, x.ao=x.ao, x.init=x.init, x.mean=x.mean, use.init=use.init)
                resid.ao <- resid.ao[-pos.child]

                w.temp <- wle.weights(x=resid.ao, smooth=smooth, sigma2=sigma2, raf=raf, location=TRUE)

                weights.temp <- w.temp$weights
                w.tilde.child <- sum(weights.temp)/nresid

                w.tilde <- c(w.tilde,w.tilde.child)
                model.in <- c(model.in,model.child)

                model.in <- model.in[order(w.tilde)][-1]
                w.tilde <- sort(w.tilde)[-1]
         }

         if (max(w.tilde)<(sum(weights)/nresid)) {
             ao.position <- NULL
         } else {
             ao.position <- sort(pos[binary(model.in[1],dim.dim)$dicotomy])
         }

    } else {
        ao.position <- NULL
    }

    x.ao <- x
    for (t in ao.position) {
         x.ao[t] <- wle.fracdiff.fitted(t=t, d=d, M=M, x=x.ao, x.init=x.init, x.mean=x.mean, use.init=use.init)
    }

    resid.ao <- wle.fracdiff.residuals(d=d, M=M, x=x, x.ao=x.ao, x.init=x.init, x.mean=x.mean, use.init=use.init)
    w.temp <- wle.weights(x=resid.ao, smooth=smooth, sigma2=sigma2, raf=raf, location=TRUE)
    resid.ao <- resid.ao - w.temp$location

    if (verbose) {
        cat("Additive outliers: \n", ao.position, "\n")
    }

    return(x.ao=x.ao, resid.ao=resid.ao, ao.position=ao.position)
}

#############################################################
#                                                           #
#	wle.fracdiff function                              	    #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: April, 02, 2002                                   #
#	Version: 0.1-2                                          #
#                                                           #
#	Copyright (C) 2002 Claudio Agostinelli                  #
#                                                           #
#############################################################

wle.fracdiff <- function(x, lower, upper, M, group, na.action=na.fail, tol=10^(-6), equal=10^(-3), raf="HD", smooth=0.0031, smooth.ao=smooth, boot=10, num.sol=1, x.init=rep(0,M), use.uniroot=FALSE, use.init=FALSE, max.iter.out=20, max.iter.in=100, max.iter.step=5000, max.iter.start=max.iter.step,  verbose=FALSE, w.level=0.4, min.weights=0.5, population.size=10, population.choose=5, elements.random=2, init.values=NULL, num.max=length(x), include.mean=FALSE, ao.list=list(0)) {

    if (use.init) {
        MM <- 0
    } else {
        MM <- M
    }

    raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

    if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

    result <- list()
    series <- deparse(substitute(x))
    if(NCOL(x) > 1) stop("only implemented for univariate time series")

    x <- na.action(as.ts(x))
    nused <- length(x)

    if (length(x.init)!=M) stop("x.init must have M elements\n")

# start bootstrap iteration
    first.time <- TRUE
    iboot <- 1
    tot.sol <- 0
    not.conv <- 0

    while (iboot<=boot & tot.sol<num.sol) {
           pos.iboot <- round(runif(1,(group+1),nused))
           x.boot <- x[(pos.iboot-group+1):pos.iboot]

           if (!is.null(init.values)) {
               temp <- list(conv=TRUE)
               temp$d <- init.values[1]
               temp$sigma2 <- init.values[2]
               temp$x.mean <- init.values[3]
               temp$resid <- wle.fracdiff.residuals(d=temp$d, M=M, x=x, x.ao=x, x.init=x.init, x.mean=temp$x.mean, use.init=use.init)
           } else {
               temp <- wle.fracdiff.solve(x=x.boot, x.init=x.init, max.iter=max.iter.start, verbose=verbose, M=M,  lower, upper, tol=tol, use.uniroot=use.uniroot, use.init=use.init, include.mean=include.mean)
               temp$resid <- wle.fracdiff.residuals(temp$d, M=M, x=x, x.ao=x, x.init=x.init, x.mean=temp$x.mean, use.init=use.init)
               temp$sigma2 <- wle.fracdiff.sigma2(resid=temp$resid)
           }
    
           if (temp$conv) {
               d <- temp$d
               sigma2 <- temp$sigma2
               x.mean <- temp$x.mean
               resid <- temp$resid
               nresid <- length(resid)

               if (verbose) {
	           cat("Initial values from the subsample ",iboot,": \n parameters, d: ", d,"\n sigma2: ",sigma2," \n x.mean: ",x.mean, " \n") 
               }

               weights <- .Fortran("wlew",
    	            as.double(resid),
    	            as.integer(nresid),
	            as.double(resid),
	            as.integer(nresid),
	            as.integer(raf),
	            as.double(smooth.ao),
	            as.double(sigma2),
	            totweights=double(1),
	            weights=double(nresid),
				PACKAGE="wle")$weights

               if (sum(weights)/nresid >= min.weights) {
                   wres <- wle.fracdiff.ao(d=d, sigma2=sigma2, x=x, M=M, x.init=x.init, x.mean=x.mean, use.init=use.init, raf=raf, smooth=smooth.ao, w.level=w.level, verbose=verbose, ao.list=ao.list, population.size=population.size, population.choose=population.choose, elements.random=elements.random, num.max=num.max)

                   x.ao <- wres$x.ao
                   ao.position <- wres$ao.position
                   resid <- wle.fracdiff.residuals(d, M=M, x=x, x.ao=x.ao, x.init=x.init, x.mean=x.mean, use.init=use.init)
                   weights <- wle.weights(x=resid, smooth=smooth, sigma2=sigma2, raf=raf, location=TRUE)$weights

                   if (!is.null(ao.position)) {
                       ao.list <- c(ao.list,list(ao.position))
                   }
                   ao.position.old <- c(ao.position,0)
                   conv <- TRUE
                   iter.out <- 0

                   while (!setequal(ao.position,ao.position.old) & conv) {
    	                  iter.out <- iter.out + 1
    	                  ao.position.old <- ao.position	
                          maxtol <- tol + 1
                          iter.in <- 0
                          while (maxtol > tol & conv) {
                                 iter.in <- iter.in + 1
                                 d.old <- d
                                 sigma2.old <- sigma2
                                 x.mean.old <- x.mean
	                         res <- wle.fracdiff.solve(x=x.ao, M=M, x.init=x.init, lower=lower, upper=upper, w=weights, tol=tol, max.iter=max.iter.step, verbose=verbose, use.uniroot=use.uniroot, use.init=use.init, include.mean=include.mean)
	                         d <- res$d
                                 x.mean <- res$x.mean
                                 resid <- wle.fracdiff.residuals(d=d, M=M, x=x, x.ao=x.ao, x.init=x.init, x.mean=x.mean, use.init=use.init)
	                         sigma2 <- wle.fracdiff.sigma2(resid=resid, w=weights)
                                 weights <- wle.weights(x=resid, smooth=smooth, sigma2=sigma2, raf=raf, location=TRUE)$weights
                                 conv <- res$conv            

                                 if (iter.in > max.iter.in) {
                                     if (verbose) cat("Convergence problem: maximum iteration number reached in the outer loop\n")
                                     conv <- FALSE
                                 }
                                 maxtol <- max(abs(d-d.old),abs(sigma2-sigma2.old), abs(x.mean-x.mean.old))
                                  if (verbose)  {
	    	                      cat("inner loop, iteration: ",iter.in," \n parameters, d: ",d," \n sigma2: ",sigma2," \n x.mean: ",x.mean," \n")
	                          }
                          }

                          if (conv) {      
	                      if (verbose) {
	    	                  cat("outer loop, iteration: ",iter.out," convergence achieved for the inner loop \n")
	                      }

                              wres <- wle.fracdiff.ao(d=d, sigma2=sigma2, x=x, M=M, x.init=x.init, x.mean=x.mean, use.init=use.init, raf=raf, smooth=smooth.ao, w.level=w.level, verbose=verbose, ao.list=ao.list, population.size=population.size, population.choose=population.choose, elements.random=elements.random, num.max=num.max)

                              x.ao <- wres$x.ao
                              ao.position <- wres$ao.position
                              resid <- wle.fracdiff.residuals(d, M=M, x=x, x.ao=x.ao, x.init=x.init, x.mean=x.mean, use.init=use.init)
                              sigma2 <- wle.fracdiff.sigma2(resid=resid, w=weights)
                              weights <- wle.weights(x=resid, smooth=smooth, sigma2=sigma2, raf=raf, location=TRUE)$weights

                              if (!is.null(ao.position)) {
                                  ao.list <- c(ao.list,list(ao.position))
                              }

                              if ((lao <- length(ao.list))>2) {
                                  for (i.ao in 1:(lao-2)) {
                                       if (setequal(ao.list[[lao]],ao.list[[i.ao]])) {
                                           conv <- FALSE
                                       }
                                   } 
                               }

                               if (iter.out > max.iter.out) {
                                   if (verbose) cat("Convergence problem: maximum iteration number reached in the outer loop\n")
                                   conv <- FALSE
                               }

                          }

                   }
# end while (!setequal(ao.position,ao.position.old) & conv)

                   if (conv) {
                       resid.with.ao <- wle.fracdiff.residuals(d, M=M, x=x, x.ao=x, x.init=x.init, x.mean=x.mean, use.init=use.init) 
                       resid.with.ao <- ts(resid.with.ao, start=(start(x)+MM), end=end(x), frequency=frequency(x))
                       class(resid.with.ao) <- "ts"

                       weights.with.ao <- wle.weights(x=resid.with.ao, smooth=smooth, sigma2=sigma2, raf=raf, tol=tol, location=TRUE)$weights

                       resid <- ts(resid, start=(start(x)+MM), end=end(x), frequency=frequency(x))        
                       class(resid) <- "ts" 

                       resid.without.ao <- wle.fracdiff.residuals(d, M=M, x=x.ao, x.ao=x.ao, x.init=x.init, x.mean=x.mean, use.init=use.init) 
                       resid.without.ao <- ts(resid.without.ao, start=(start(x)+MM), end=end(x), frequency=frequency(x))
                       class(resid.without.ao) <- "ts"
 
                       weights.without.ao <- wle.weights(x=resid.without.ao, smooth=smooth, sigma2=sigma2, raf=raf, tol=tol, location=TRUE)$weights
 
                       x.ao <- ts(x.ao, start=start(x), end=end(x), frequency=frequency(x))
                       class(x.ao) <- "ts" 

    if (first.time) {
        d.final <- d
        sigma2.final <- sigma2
        x.mean.final <- c(x.mean)
        weights.final <- weights
        weights.with.ao.final <- weights.with.ao
        weights.without.ao.final <- weights.without.ao   
        resid.final <- resid
        resid.with.ao.final <- resid.with.ao
        resid.without.ao.final <- resid.without.ao
        x.ao.final <- x.ao
        ao.position.final <- list(ao.position)
        first.time <- FALSE	
        tot.sol <- 1
    } else {
        if (min(abs(d.final-d))>equal) {
	    tot.sol <- tot.sol+1
	    d.final <- c(d.final,d)
            sigma2.final <- c(sigma2.final,sigma2)
            x.mean.final <- c(x.mean.final,c(x.mean))
	    weights.final <- rbind(weights.final,weights)
            weights.with.ao.final <- rbind(weights.with.ao.final, weights.with.ao)
            weights.without.ao.final <- rbind(weights.without.ao.final, weights.without.ao)
	    resid.final <- rbind(resid.final,resid)
            resid.with.ao.final <- rbind(resid.with.ao.final,resid.with.ao)
            resid.without.ao.final <- rbind(resid.without.ao.final,resid.without.ao)
            ao.position.final <- c(ao.position.final,list(ao.position))
            x.ao.final <- rbind(x.ao.final,x.ao)
        }
    }

                   } else {
    	               not.conv <- not.conv+1
                   }
               } else {
    	           not.conv <- not.conv+1
               }
           } else {
    	       not.conv <- not.conv+1
           }    

        iboot <- iboot+1
    }
# end bootstrap iteration

if(tot.sol==0) {
   
    result$d <- NULL
    result$sigma2 <- NULL
    result$x.mean <- NULL
    result$resid <- NULL
    result$resid.with.ao <- NULL
    result$resid.without.ao <- NULL
    result$x.ao <- NULL
    result$call <- match.call()
    result$weights <- NULL
    result$weights.with.ao <- NULL
    result$weights.without.ao <- NULL   
    result$tot.sol <- 0
    result$not.conv <- not.conv
    result$ao.position <- NULL
} else { 
    result$d <- d.final
    result$sigma2 <- sigma2.final
    result$x.mean <- x.mean.final
    result$resid <- resid.final
    result$resid.without.ao <- resid.without.ao.final
    result$resid.with.ao <- resid.with.ao.final
    result$x.ao <- x.ao.final
    result$call <- match.call()
    result$weights <- weights.final
    result$weights.with.ao <- weights.with.ao.final
    result$weights.without.ao <- weights.without.ao.final
    result$tot.sol <- tot.sol
    result$not.conv <- not.conv
    result$ao.position <- ao.position.final
    }

    class(result) <- "wle.farima"
    
return(result)
}


#############################################################
#                                                           #
#	wle.fracdiff.solve function                         #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@stat.unipd.it                       #
#	Date: December, 11, 2001                            #
#	Version: 0.1-1                                      #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.fracdiff.solve <- function(x, M=100, x.init=rep(0,M), lower, upper, w=rep(1,length(x)), tol=.Machine$double.eps^0.25, max.iter=1000, verbose=FALSE, use.uniroot=FALSE, use.init=FALSE, include.mean=FALSE) {

    result <- list()

    if (include.mean) {
        x.mean <- w%*%x/sum(w)
        x <- x - x.mean
    } else {
        x.mean <- 0
    }

    result$x.mean <- x.mean
    result$call <- match.call()

    if (use.uniroot) {
        temp <- uniroot(wle.fracdiff.equation, x=x, M=M, w=w, x.init=x.init, lower=lower, upper=upper, use.uniroot=use.uniroot, tol=tol, maxiter=max.iter, verbose=verbose, use.init=use.init)
        if (temp$iter < max.iter) {
            result$d <- temp$root
            result$conv <- TRUE
        } else {
            result$d <- NA
            result$conv <- FALSE
        }
    } else {
        temp <- optimize(wle.fracdiff.equation, x=x, M=M, w=w, x.init=x.init, lower=lower, upper=upper, use.uniroot=use.uniroot, tol=tol, verbose=verbose, use.init=use.init)
        result$d <- temp$minimum
        result$conv <- TRUE
    }
    return(result)
}

#############################################################
#                                                           #
#	wle.fracdiff.equation function                      #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: November, 30, 2001                            #
#	Version: 0.1                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################


wle.fracdiff.equation <- function(d, M, x, x.init=rep(0,M), w=rep(1,length(x)), use.uniroot=FALSE, use.init=FALSE, verbose=FALSE) {
 
    if (use.init) {
        MM <- 0
    } else {
        MM <- M
    }
    nused <- length(x)
    pi.coef <- wle.fracdiff.pi.coef(d,M)
    if (use.uniroot) {
        xi.coef <- wle.fracdiff.xi.coef(d,M)
    }
    y <- c(x.init,x)

    somma <- 0
    if (use.uniroot) {
        for (t in (1+MM):nused) {
             somma <- somma + w[t]*(x[t]+pi.coef%*%y[(t-1+M):t])*(xi.coef%*%y[(t-1+M):t])
        }
    } else {
        for (t in (1+MM):nused) {
             somma <- somma + w[t]*(x[t]+pi.coef%*%y[(t-1+M):t])^2
        }
    }

    if (verbose) cat("value of d: ",d," value of the function: ",somma,"\n")

    return(as.vector(somma))
}


#############################################################
#                                                           #
#	wle.fracdiff.pi.coef function                       #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: November, 30, 2001                            #
#	Version: 0.1                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.fracdiff.pi.coef <- function(d,M) {
     pi.coef <- rep(0,M)
     pi.coef[1] <- -d
     for (j in 2:M) {
          pi.coef[j] <- pi.coef[j-1]*(j-1-d)/j
     }
return(pi.coef)
}

#############################################################
#                                                           #
#	wle.fracdiff.xi.coef function                       #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: November, 30, 2001                            #
#	Version: 0.1                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.fracdiff.xi.coef <- function(d,M) {
     xi.coef <- rep(0,M)
     secondo.termine <- (1+d*digamma(1-d))/gamma(1-d)    
     for (j in 1:M) {
          primo.termine <- gamma(j-d)/gamma(j+1)
          if (is.nan(primo.termine)) {
              primo.termine <- j^(-(1+d))*exp(d)
          }
          xi.coef[j] <- - primo.termine*(secondo.termine+digamma(j-d)/gamma(-d))
     }
return(xi.coef)
}

#############################################################
#                                                           #
#	wle.fracdiff.residuals function                     #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: December, 11, 2001                            #
#	Version: 0.1-1                                      #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.fracdiff.residuals <- function(d, M, x, x.ao, x.init=rep(0,M), x.mean=0, use.init=FALSE) {

    x <- x - x.mean
    x.ao <- x.ao - x.mean

    if (use.init) {
        MM <- 0
    } else {
        MM <- M
    }
    nused <- length(x) 
    pi.coef <- wle.fracdiff.pi.coef(d,M)
    y <- c(x.init,x.ao)
    resid <- rep(0,nused)

    for (t in (1+MM):nused) {
         resid[t] <- x[t]+pi.coef%*%y[(t-1+M):t]
    }
    resid <- resid[(MM+1):nused]

    return(resid)
}

#############################################################
#                                                           #
#	wle.fracdiff.sigma2 function                        #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: December, 1, 2001                             #
#	Version: 0.1                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.fracdiff.sigma2 <- function(resid, w=rep(1,length(resid))) {
    sigma2 <- sum(w*resid^2)/(sum(w) - 1)
    return(sigma2)
}

#############################################################
#                                                           #
#	wle.fracdiff.fitted function                        #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: December, 5, 2001                             #
#	Version: 0.1-1                                      #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.fracdiff.fitted <- function(t, d, M, x, x.init=rep(0,M), x.mean=0, use.init=FALSE) {
 
    x <- x - x.mean

    if (use.init) {
        MM <- 0
    } else {
        MM <- M
    }
    nused <- length(x)
    pi.coef <- wle.fracdiff.pi.coef(d,M)
    y <- c(x.init,x)
    return((-pi.coef%*%y[(t-1+M):t]+x.mean))
}







#############################################################
#                                                           #
#	wle.gamma function                                      #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: February, 28, 2003                                #
#	Version: 0.3                                            #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

wle.gamma <- function(x, boot=30, group, num.sol=1, raf="HD", smooth=0.008, tol=10^(-6), equal=10^(-3), max.iter=500, shape.int=c(0.01, 100), use.smooth=TRUE, tol.int, verbose=FALSE, maxiter=1000) {

sem <- options()$show.error.messages

wsolve <- function (o, media, medialog) {
   medialog + log(o/media) - digamma(o)
}

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

if (missing(group)) {
group <- 0
}

x <- as.vector(x)
size <- length(x)
result <- list()

if (size<2) {
stop("Number of observation must be at least equal to 2")
}

if (group<2) {
    group <- max(round(size/4),2)
    if (verbose) cat("wle.gamma: dimension of the subsample set to default value: ",group,"\n")
}

maxboot <- sum(log(1:size))-(sum(log(1:group))+sum(log(1:(size-group))))

if (boot<1 | log(boot) > maxboot) {
    stop("Bootstrap replication not in the range")
}

if (!(num.sol>=1)) {
    if (verbose) cat("wle.gamma: number of solution to report set to 1 \n")
    num.sol <- 1
}

if (max.iter<1) {
    if (verbose) cat("wle.gamma: max number of iterations set to 500 \n")
    max.iter <- 500
}

if (max.iter<1) {
    if (verbose) cat("wle.gamma: max number of iterations for the uniroot function set to 1000 \n")
    max.iter <- 1000
}

if (smooth<10^(-5)) {
    if (verbose) cat("wle.gamma: the smooth parameter seems too small \n")
}

if (tol<=0) {
    if (verbose) cat("wle.gamma: the accuracy must be positive, using default value: 10^(-6) \n")
    tol <- 10^(-6)
}

if (equal<=tol) {
    if (verbose) cat("wle.gamma: the equal parameter must be positive, using default value: tol+10^(-3) \n")
    equal <- tol+10^(-3)
}

if (!is.logical(use.smooth)) {
    if (verbose) cat("wle.gamma: the use.smooth must be a logical value, using default value \n")
    use.smooth <- TRUE
}

if (length(shape.int)!=2) stop("shape.int must be a vector of length 2 \n")

shape.int <- sort(shape.int, decreasing = FALSE)

if (shape.int[2] <= 0) {
    stop("the elements of shape.int must be positive \n")
}

if (shape.int[1] <= 0) {
    if (verbose) cat("wle.gamma: the elements of shape.int must be positive, using default value \n")
    shape.int[1] <- tol
}

if (missing(tol.int)) {
   tol.int <- tol*10^(-4)
} else {
   if (tol.int <=0) {
       if (verbose) cat("wle.gamma: tol.int must be positive, using default value \n")
       tol.int <- tol*10^(-4) 
   } 
}

tot.sol <- 0
not.conv <- 0
iboot <- 0

xlog <- log(x)

while (tot.sol < num.sol & iboot <= boot) {
   cont <- TRUE
   i <- 0
   while (cont & iboot <= boot) {
          i <- i + 1
          iboot <- iboot + 1
          x.boot <- x[sample(1:size, group, replace = FALSE)]
          xlog.boot <- log(x.boot)

          media <- sum(x.boot)/group
          medialog<- sum(xlog.boot)/group

          options(show.error.messages=FALSE)
          o <- try(uniroot(wsolve, interval=shape.int, media=media, medialog=medialog, tol=tol, maxiter=maxiter)$root)
          options(show.error.messages=sem)
          
          if (!is.character(o)) {
              cont <- FALSE
          }
   }

   if (!is.character(o)) {
   
       if (o < tol) o <- 2*tol

       l <- media/o

       xdiff <- tol + 1
       iter <- 0
       while (xdiff > tol & iter < max.iter) {

       iter <- iter + 1
       shape <- o
       lambda <- 1/l
       temp <- shape/lambda^2
       dsup <- max(x)+ 3*smooth*temp

       z <- .Fortran("wlegamma",
	    as.double(x), 
	    as.integer(size),
	    as.integer(raf),
	    as.double(smooth*temp),
        as.integer(1*use.smooth),
        as.double(dsup),
	    as.double(tol),
        as.double(tol.int),
	    as.double(lambda),
	    as.double(shape),
	    weights=double(size),
	    density=double(size),
	    model=double(size),
        PACKAGE = "wle")

       ww <- z$weights
       wsum <- sum(ww)
       wmedia <- ww%*%x/wsum
       wmedialog <- ww%*%xlog/wsum

       options(show.error.messages=FALSE)
       o <- try(uniroot(wsolve, interval=shape.int, media=wmedia, medialog=wmedialog, tol=tol, maxiter=maxiter)$root)
       options(show.error.messages=sem)
       
       if (!is.character(o)) {
           if (o < tol) o <- 2*tol

           l <- wmedia/o

           xdiff <- max(abs(c(o-shape,l-1/lambda)))
       } else {
           xdiff <- 0
           iter <- max.iter+1
       }
   }

   if (iter <= max.iter) {

   if (tot.sol==0) {
      o.store <- o
      l.store <- l
      w.store <- ww
      f.store <- z$density
      m.store <- z$model
      d.store <- f.store/m.store - 1
      tot.sol <- 1
   } else {
      if (min(abs(o.store-o))>equal & min(abs(l.store-l))>equal) {
          o.store <- c(o.store,o)
          l.store <- c(l.store,l)
          w.store <- rbind(w.store,ww)
          f.store <- rbind(f.store,z$density)
          m.store <- rbind(m.store,z$model)
          d.store <- rbind(d.store,z$density/z$model - 1)
          tot.sol <- tot.sol + 1
      }
   }

   } else not.conv <- not.conv + 1
   } else not.conv <- not.conv + i

}
##### end of while (tot.sol < num.sol & iboot < boot)

if (tot.sol) {
   result$scale <- c(l.store)
   result$rate <- c(1/l.store)  
   result$shape <- o.store
   
   if (tot.sol>1) {
       tot.w <- apply(w.store,1,sum)/size
   } else tot.w <- sum(w.store)/size
  
   result$tot.weights <- tot.w
   result$weights <- w.store
   result$delta <- d.store
   result$f.density <- f.store
   result$m.density <- m.store
   result$tot.sol <- tot.sol
   result$not.conv <- not.conv
   result$call <- match.call()
} else{
   if (verbose) cat("wle.gamma: No solutions are fuond, checks the parameters\n")
   result$scale <- NA
   result$rate <- NA
   result$shape <- NA
   result$tot.weights <- NA
   result$weights <- rep(NA,size)
   result$delta <- rep(NA,size)
   result$f.density <- rep(NA,size)
   result$m.density <- rep(NA,size)
   result$tot.sol <- 0
   result$not.conv <- boot
   result$call <- match.call()
}

   class(result) <- "wle.gamma"
   return(result)
}

#############################################################
#                                                           #
#	print.wle.gamma function                                #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: August, 28, 2003                                  #
#	Version: 0.3                                            #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

print.wle.gamma <- function(x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    cat("Scale:\n")
    print.default(format(x$scale, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("Rate:\n")
    print.default(format(x$rate, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")  
    cat("Shape:\n")
    print.default(format(x$shape, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("\nNumber of solutions ",x$tot.sol,"\n")
    cat("\n")
    invisible(x)
}






#############################################################
#                                                           #
#	wle.lm function                                     #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: April, 5, 2003                                #
#	Version: 0.4-1                                      #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.lm <- function (formula, data=list(), model=TRUE, x=FALSE, y=FALSE, boot=30, group, num.sol=1, raf="HD", smooth=0.031, tol=10^(-6), equal=10^(-3), max.iter=500, contrasts=NULL, verbose=FALSE) {

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

if (missing(group)) {
    group <- 0
}

    ret.x <- x
    ret.y <- y
    result <- list()	
    mt <- terms(formula, data = data)
    mf <- cl <- match.call()
    mf$boot <- mf$group <- mf$smooth <- NULL
    mf$tol <- mf$equal <- mf$num.sol <- NULL
    mf$max.iter <- mf$raf <- mf$contrasts <- NULL
    mf$model <- mf$x <- mf$y <- NULL
    mf$verbose <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    xvars <- as.character(attr(mt, "variables"))[-1]
    inter <- attr(mt, "intercept")
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <-
	if(length(xvars) > 0) {
	    xlev <- lapply(mf[xvars], levels)
	    xlev[!sapply(xlev, is.null)]
	}
    ydata <- model.response(mf, "numeric")
    nomi <- names(ydata)
    if (is.empty.model(mt)) 
	stop("The model is empty")
    else 
	xdata <- model.matrix(mt, mf, contrasts)

if (is.null(size <- nrow(xdata)) | is.null(nvar <- ncol(xdata))) stop("'x' must be a matrix")
if (length(ydata)!=size) stop("'y' and 'x' are not compatible")

if (size <= nvar+2) {
    if (verbose) cat("wle.lm: since the number of observations is less than the number of variables plus 2 we perform ordinary least square using function 'lm' \n")
    res <- lm(formula=formula, data=data, model=model, x=x, y=y, contrasts=contrasts)
    res.s <- summary(res)
    result$coefficients <- res$coefficients
    result$standard.error <- res.s$coefficients[,2]
    result$scale <- res.s$sigma
    result$residuals <- res$residuals
    result$fitted.values <- res$fitted.values
    result$weights <- rep(1, size)
    names(result$weights) <- nomi
    result$f.density <- rep(NA,size)
    result$m.density <- rep(NA,size)
    result$delta <- rep(NA,size)
    result$tot.weights <- 1
    result$tot.sol <- 1
    result$not.conv <- 0
    result$freq <- boot
    result$info <- 0
} else {
    if (group<=nvar) {
        group <- max(round(size/4),(nvar+1))
        if (verbose) cat("wle.lm: dimension of the subsample set to default value: ", group,"\n")
    }

    maxboot <- sum(log(1:size))-(sum(log(1:group))+sum(log(1:(size-group))))

    if (boot<1 | log(boot) > maxboot) {
        stop("Bootstrap replication not in the range")
    }

    if (!(num.sol>=1)) {
        if (verbose) cat("wle.lm: number of solution to report set to 1 \n")
        num.sol <- 1
    }

    if (max.iter<1) {
        if (verbose) cat("wle.lm: max number of iteration set to 500 \n")
        max.iter <- 500
    }

    if (smooth<10^(-5)) {
        if (verbose) cat("wle.lm: the smooth parameter seems too small \n")
    }

    if (tol<=0) {
        if (verbose) cat("wle.lm: the accuracy must be positive, using default value: 10^(-6) \n")
        tol <- 10^(-6)
    }

    if (equal<=tol) {
        if (verbose) cat("wle.lm: the equal parameter must be greater than tol, using default value: tol+10^(-3) \n")
        equal <- tol+10^(-3)
    }

    z <- .Fortran("wleregfix",
	as.double(ydata),
	as.matrix(xdata),
	as.integer(0), 
	as.integer(size),
	as.integer(nvar),
	as.integer(nvar),
	as.integer(boot),
	as.integer(group),
	as.integer(num.sol),
	as.integer(raf),
	as.double(smooth),
	as.double(tol),
	as.double(equal),
	as.integer(max.iter),
	param=mat.or.vec(num.sol,nvar),
	var=double(num.sol),
	resid=mat.or.vec(num.sol,size),
	totweight=double(num.sol),
	weight=mat.or.vec(num.sol,size),
        density=mat.or.vec(num.sol,size),
        model=mat.or.vec(num.sol,size),
        delta=mat.or.vec(num.sol,size),
	same=integer(num.sol),
	nsol=integer(1),
	nconv=integer(1),
	PACKAGE = "wle")

    if (z$nsol>0) {
        z$var <- z$var[1:z$nsol]
        z$totweight <- z$totweight[1:z$nsol]
        z$same <- z$same[1:z$nsol]

        if (num.sol==1) {
            z$param <- c(z$param)
            z$resid <- c(z$resid)
            z$weight <- c(z$weight)
            z$density <- c(z$density)
            z$model <- c(z$model)
            z$delta <- c(z$delta)        
        } else {
            if (nvar==1) {      
                z$param <- z$param[1:z$nsol]
            } else {
                z$param <- z$param[1:z$nsol,]
            }  
            z$resid <- z$resid[1:z$nsol,]
            z$weight <- z$weight[1:z$nsol,]
            z$density <- z$density[1:z$nsol,]
            z$model <- z$model[1:z$nsol,]
            z$delta <- z$delta[1:z$nsol,]
        }

        y.fit <- t(xdata%*%matrix(z$param,ncol=z$nsol,byrow=TRUE))

        if (z$nsol==1) {
            devparam <- sqrt(z$var*diag(solve(t(xdata)%*%diag(z$weight)%*%xdata,tol=1e-100)))
            y.fit <- as.vector(y.fit)
        } else {
            devparam <- sqrt(z$var[1]*diag(solve(t(xdata)%*%diag(z$weight[1,])%*%xdata,tol=1e-100)))
            for (i in 2:z$nsol) {
                 devparam <- rbind(devparam,sqrt(z$var[i]*diag(solve(t(xdata)%*%diag(z$weight[i,])%*%xdata,tol=1e-100))))
            }
        }

        result$coefficients <- z$param
        result$standard.error <- devparam
        result$scale <- sqrt(z$var)
        result$residuals <- z$resid
        result$fitted.values <- y.fit
        result$weights <- z$weight
        result$f.density <- z$density
        result$m.density <- z$model
        result$delta <- z$delta
        result$tot.weights <- z$totweight
        result$tot.sol <- z$nsol
        result$not.conv <- z$nconv
        result$freq <- z$same
    } else {
        if (verbose) cat("wle.lm: No solutions are fuond, checks the parameters\n")
        result$coefficients <- rep(NA,nvar)
        result$standard.error <- rep(NA,nvar)
        result$scale <- NA
        result$residuals <- rep(NA,size)
        result$fitted.values <- rep(NA,size)
        result$weights <- rep(NA,size)
        result$f.density <- rep(NA,size)
        result$m.density <- rep(NA,size)
        result$delta <- rep(NA,size)
        result$tot.weights <- NA
        result$tot.sol <- 0
        result$not.conv <- boot
        result$freq <- NA
    }

result$info <- z$info

}

result$call <- cl
result$contrasts <- attr(xdata, "contrasts")
result$xlevels <- xlev
result$terms <- mt 


if (model)
    result$model <- mf
if (ret.x)
    result$x <- xdata
if (ret.y)
    result$y <- ydata

dn <- colnames(xdata)

if (is.null(nrow(result$coefficients))) {
    names(result$coefficients) <- dn
} else {
    dimnames(result$coefficients) <- list(NULL,dn)
}

if (is.null(nrow(result$residuals))) {
    names(result$residuals) <- names(result$fitted.values) <- names(result$weights) <- names(result$f.density) <- names(result$m.density) <- names(result$delta) <- nomi
} else {
    dimnames(result$residuals) <- dimnames(result$fitted.values) <- dimnames(result$weights) <- dimnames(result$f.density) <- dimnames(result$m.density) <- dimnames(result$delta) <- list(NULL, nomi)
}

class(result) <- "wle.lm"

return(result)
}

#############################################################
#                                                           #
#	print.wle.lm function                               #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: December, 3, 2001                             #
#	Version: 0.1                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

print.wle.lm <- function(x, digits = max(3, getOption("digits") - 3), ...)
{
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    cat("Coefficients:\n")
    print.default(format(coef(x), digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("Scale estimate: ",format(x$scale, digits=digits))
    cat("\n")
    cat("\nNumber of solutions ",x$tot.sol,"\n")
    cat("\n")
    invisible(x)
}

#############################################################
#                                                           #
#	summary.wle.lm function                             #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: December, 3, 2001                             #
#	Version: 0.1                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

summary.wle.lm <- function(object, root="ALL", ...) {

if (is.null(object$terms)) stop("invalid \'wle.lm\' object")

tot.sol <- object$tot.sol

if (root!="ALL" & !is.numeric(root)) {
    stop("Please, choose one root, for print all root ALL")
} else if (root=="ALL") {
    root <- 1:tot.sol
} else if (tot.sol<root) {
    stop(paste("Root ",root," not found"))
}

ans <- list()
for (iroot in root) {
ans <- c(ans,list(summary.wle.lm.root(object=object, root=iroot)))
}
class(ans) <- "summary.wle.lm" 

return(ans)
}

print.summary.wle.lm <- function (x, digits = max(3, getOption("digits") - 3), signif.stars= getOption("show.signif.stars"),	...)
{
for (i in 1:length(x)) {
print.summary.wle.lm.root(x[[i]], digits = max(3, getOption("digits") - 3), signif.stars= getOption("show.signif.stars"))
}
}

#############################################################
#                                                           #
#	summary.wle.lm.root function                        #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: December, 3, 2001                             #
#	Version: 0.1                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

summary.wle.lm.root <- function (object, root=1, ...) {

if (is.null(object$terms)) stop("invalid \'wle.lm\' object")

tot.sol <- object$tot.sol
if (tot.sol<root) {
    stop(paste("Root ",root," not found"))
}
if (tot.sol!=1) {
n <- ncol(object$residuals)
p <- ncol(object$coefficients)
} else {
n <- length(object$residuals)
p <- length(object$coefficients)
}

rdf <- object$tot.weights[root]*n - p 
if (tot.sol>1) {   
    r <- object$residuals[root,]
    f <- object$fitted.values[root,]
    w <- object$weights[root,]
    est <- object$coefficients[root,]
    se <- object$standard.error[root,]
} else {
    r <- object$residuals
    f <- object$fitted.values
    w <- object$weights
    est <- object$coefficients
    se <- object$standard.error
}

    mss <- if (attr(object$terms, "intercept")) {
    		m <- sum(w * f /sum(w))
        	sum(w * (f - m)^2)
        	} else sum(w * f^2)
    rss <- sum(w * r^2)
  
    resvar <- rss/rdf
    tval <- est/se
    ans <- object[c("call", "terms")]
    ans$residuals <- sqrt(w)*r
    ans$coefficients <- cbind(est, se, tval, 2*(1 - pt(abs(tval), rdf)))
    dimnames(ans$coefficients)<-
	list(names(est),
	     c("Estimate", "Std. Error", "t value", "Pr(>|t|)"))
    ans$sigma <- sqrt(resvar)
    ans$df <- c(p, rdf, p)
    if (p != attr(object$terms, "intercept")) {
	df.int <- if (attr(object$terms, "intercept")) 1 else 0
	ans$r.squared <- mss/(mss + rss)
	ans$adj.r.squared <- 1 - (1 - ans$r.squared) *
	    ((sum(w) - df.int)/rdf)
	ans$fstatistic <- c(value = (mss/(p - df.int))/resvar,
			    numdf = p - df.int, dendf = rdf)
    }

    ans$root <- root
    return(ans)
}

#############################################################
#                                                           #
#	print.summary.wle.lm.root function                      #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: October, 15, 2003                                 #
#	Version: 0.2-1                                          #
#                                                           #
#	Copyright (C) 2002 Claudio Agostinelli                  #
#                                                           #
#############################################################

print.summary.wle.lm.root <- function (x, digits = max(3, getOption("digits") - 3), signif.stars= getOption("show.signif.stars"),	...) {
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep="\n", collapse = "\n"), "\n\n", sep="")
    resid <- x$residuals
    df <- x$df
    rdf <- df[2]
 
   cat("Root ",x$root)
   cat("\n\nWeighted Residuals:\n", sep="")
    if (rdf > 5) {
	nam <- c("Min", "1Q", "Median", "3Q", "Max")
	rq <- if (length(dim(resid)) == 2)
	    structure(apply(t(resid), 1, quantile),
		      dimnames = list(nam, dimnames(resid)[[2]]))
	else  structure(quantile(resid), names = nam)
	print(rq, digits = digits, ...)
    }
    else if (rdf > 0) {
	print(resid, digits = digits, ...)
    } else { # rdf == 0 : perfect fit!
	cat("ALL", df[1], "residuals are 0: no residual degrees of freedom!\n")
    }
    if (nsingular <- df[3] - df[1])
	cat("\nCoefficients: (", nsingular,
	    " not defined because of singularities)\n", sep = "")
    else cat("\nCoefficients:\n")


    printCoefmat(x$coef, digits=digits, signif.stars=signif.stars, ...)
    ##
    cat("\nResidual standard error:",
	format(signif(x$sigma, digits)), "on", rdf, "degrees of freedom\n")
    if (!is.null(x$fstatistic)) {
	cat("Multiple R-Squared:", formatC(x$r.squared, digits=digits))
	cat(",\tAdjusted R-squared:",formatC(x$adj.r.squared,digits=digits),
	    "\nF-statistic:", formatC(x$fstatistic[1], digits=digits),
	    "on", x$fstatistic[2], "and",
	    x$fstatistic[3], "degrees of freedom,\tp-value:",
	    formatC(1 - pf(x$fstatistic[1], x$fstatistic[2],
			   x$fstatistic[3]), digits=digits),
	    "\n")
    }

    cat("\n")
    invisible(x)
}

fitted.wle.lm <- function(object, ...) object$fitted.values
coef.wle.lm <- function(object, ...) object$coefficients
weights.wle.lm  <- function(object, ...) object$weights
formula.wle.lm <- function(x, ...) formula(x$terms)

model.frame.wle.lm <-
    function(formula, data, na.action, ...) {
	if (is.null(formula$model)) {
	    fcall <- formula$call
	    fcall$method <- "model.frame"
	    fcall[[1]] <- as.name("wle.lm")
	    eval(fcall, sys.frame(sys.parent()))
	}
	else formula$model
    }

#############################################################
#                                                           #
#	wle.normal function                                 #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.normal <- function(x, boot=30, group, num.sol=1, raf="HD", smooth=0.003, tol=10^(-6), equal=10^(-3), max.iter=500, verbose=FALSE) {

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

if (missing(group)) {
group <- 0
}

x <- as.vector(x)
size <- length(x)
result <- list()

if (size<2) {
    stop("Number of observation must be at least equal to 2")
}

if (group<2) {
    group <- max(round(size/4),2)
    if (verbose) cat("wle.normal: dimension of the subsample set to default value: ",group,"\n")
}

maxboot <- sum(log(1:size))-(sum(log(1:group))+sum(log(1:(size-group))))

if (boot<1 | log(boot) > maxboot) {
    stop("Bootstrap replication not in the range")
}

if (!(num.sol>=1)) {
    if (verbose) cat("wle.normal: number of solution to report set to 1 \n")
    num.sol <- 1
}

if (max.iter<1) {
    if (verbose) cat("wle.normal: max number of iteration set to 500 \n")
    max.iter <- 500
}

if (smooth<10^(-5)) {
    if (verbose) cat("wle.normal: the smooth parameter seems too small \n")
}

if (tol<=0) {
    if (verbose) cat("wle.normal: the accuracy must be positive, using default value: 10^(-6) \n")
    tol <- 10^(-6)
}

if (equal<0) {
    if (verbose) cat("wle.normal: the equal parameter must be greater than tol, using default value: tol+10^(-3) \n")
    equal <- tol+10^(-3)
}

  z <- .Fortran("wlenorm",
	as.double(x), 
	as.integer(size),
        as.integer(size),
	as.integer(boot),
	as.integer(group),
	as.integer(num.sol),
	as.integer(raf),
	as.double(smooth),
	as.double(tol),
	as.double(equal),
	as.integer(max.iter),
	mean=double(num.sol),
	var=double(num.sol),
	totweight=double(num.sol),
	weight=mat.or.vec(num.sol,size),
	density=mat.or.vec(num.sol,size),
	model=mat.or.vec(num.sol,size),
	delta=mat.or.vec(num.sol,size),
	same=integer(num.sol),
	nsol=integer(1),
	nconv=integer(1),
	PACKAGE = "wle")

if (z$nsol>0) {
    result$location <- z$mean[1:z$nsol]
    result$scale <- sqrt(z$var[1:z$nsol])
       if (z$nsol>1) {
           result$residuals <- matrix(rep(x,z$nsol),nrow=z$nsol,byrow=TRUE) - matrix(rep(z$mean[1:z$nsol],size),nrow=z$nsol,byrow=FALSE)
       } else {
          result$residuals <- x - result$location
       }
    result$tot.weights <- z$totweight[1:z$nsol]/size
    result$weights <- z$weight[1:z$nsol,]
    result$f.density <- z$density[1:z$nsol,]
    result$m.density <- z$model[1:z$nsol,]
    result$delta <- z$delta[1:z$nsol,]
    result$freq <- z$same[1:z$nsol]
    result$tot.sol <- z$nsol
    result$not.conv <- z$nconv

} else{
    if (verbose) cat("wle.normal: No solutions are fuond, checks the parameters\n")
    result$location <- NA
    result$scale <- NA
    result$residuals <- rep(NA,size)
    result$tot.weights <- NA
    result$weights <- rep(NA,size)
    result$f.density <- rep(NA,size)
    result$m.density <- rep(NA,size)
    result$delta <- rep(NA,size)
    result$freq <- NA
    result$tot.sol <- 0
    result$not.conv <- boot
}

result$call <- match.call()
class(result) <- "wle.normal"
return(result)
}

#############################################################
#                                                           #
#	print.wle.normal function                           #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 2, 2001                               #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

print.wle.normal <- function(x, digits = max(3, getOption("digits") - 3), ...)
{
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    cat("Location:\n")
    print.default(format(x$location, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("Scale:\n")
    print.default(format(x$scale, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("\nNumber of solutions ",x$tot.sol,"\n")
    cat("\n")
    invisible(x)
}



#############################################################
#                                                           #
#	wle.normal.mixture function                             #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: November, 19, 2003                                #
#	Version: 0.2-1                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

wle.normal.mixture <- function(x, m, boot=5, group, num.sol=1, raf="HD", smooth=0.003, tol=10^(-15), equal=10^(-2), max.iter=1000, all.comp=TRUE, min.size=0.02, min.weights=0.3, boot.start=10, group.start=3, tol.start=10^(-6), equal.start=10^(-3), smooth.start=0.003, max.iter.start=500, max.iter.boot=25, verbose=FALSE) {

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

if (missing(m)) {
    m <-2
    if (verbose) cat("wle.normal.mixture: number of component set to default value: 2 \n")
}

if (m<2) {
    m <-2
    if (verbose) cat("wle.normal.mixture: number of component set to default value: 2\n")
}

if (missing(group)) {
    group <- 0
}

x <- as.vector(x)
size <- length(x)
result <- list()

if (size<2) {
    stop("Number of observation must be at least equal to 2")
}

if (group<2) {
    group <- max(2,round(size/4))
    if (verbose) cat("wle.normal.mixture: dimension of the subsample set to default value: ",group,"\n")
}

if (group.start<2 | group.start>=group) {
    group.start <- max(2,round(group/4))
    if (verbose) cat("wle.normal.mixture: dimension of the subsample of the starting values set to default value: ",group.start,"\n")
}


maxboot <- sum(log(1:size))-(sum(log(1:group))+sum(log(1:(size-group))))

if (boot<1 | log(boot) > maxboot) {
    stop("Bootstrap replication not in the range")
}

maxboots <- sum(log(1:group))-(sum(log(1:group.start))+sum(log(1:(group-group.start))))

if (boot.start<1 | log(boot.start) > maxboots) {
    stop("Bootstrap replication for the starting values not in the range")
}


if (!(num.sol>=1)) {
    if (verbose) cat("wle.normal.mixture: number of solution to report set to 1 \n")
    num.sol <- 1
}

if (max.iter<1) {
    if (verbose) cat("wle.normal.mixture: max number of iteration set to 1000 \n")
    max.iter <- 1000
}

if (max.iter.boot<1) {
    if (verbose) cat("wle.normal.mixture: max number of iteration in the boot step set to 20 \n")
    max.iter.boot <- 20
}

if (max.iter.start<1) {
    if (verbose) cat("wle.normal.mixture: max number of iteration in the starting process set to 500 \n")
    max.iter.start <- 500
}

if (!is.logical(all.comp)) {
    if (verbose) cat("wle.normal.mixture: all.comp must be logical, set to the default value: all.comp \n")
    all.comp <- TRUE 
}

all.comp <- as.numeric(all.comp)

if (smooth<10^(-5)) {
    if (verbose) cat("wle.normal.mixture: the smooth parameter seems too small \n")
}

if (smooth.start<10^(-5)) {
    if (verbose) cat("wle.normal.mixture: the smooth.start parameter seems too small \n")
}

if (tol<=0) {
    if (verbose) cat("wle.normal.mixture: the accuracy must be positive, using default value: 10^(-6) \n")
tol <- 10^(-6)
}

if (equal<=tol) {
    if (verbose) cat("wle.normal.mixture: the equal parameter can not be less than or equal to tol, using default value: tol+10^(-3)\n")
equal <- tol+10^(-3)
}
if (tol.start<=0) {
    if (verbose) cat("wle.normal.mixture: the accuracy in the starting process must be positive, using default value: 10^(-6) \n")
tol.start <- 10^(-6)
}

if (equal.start<=tol.start) {
    if (verbose) cat("wle.normal.mixture: the equal parameter can not be less than or equal to tol.start, using default value: tol.start+10^(-3)\n")
equal.start <- tol.start+10^(-3)
}

loc.boot <- matrix(0,nrow=boot,ncol=m)
var.boot <- matrix(0,nrow=boot,ncol=m)
prop.boot <- matrix(0,nrow=boot,ncol=m)

iboot <- 0
mboot <- 0
while (iboot < boot & mboot <= max.iter.boot) {

    mboot <- mboot + 1
    mmboot <- 0    

    samp <- sample(x,group,replace=FALSE)
    temp.location <- vector(length=0,mode="numeric")
    temp.scale <- vector(length=0,mode="numeric")
    temp.prop <- vector(length=0,mode="numeric")
    temp.weights <- vector(length=0,mode="numeric")
    tot.size <- 1

    while (tot.size > min.size & mmboot <= max.iter.boot) {

           nsamp <- length(samp)
           group.start <- min(group.start,nsamp)
           maxboots <- sum(log(1:nsamp))-(sum(log(1:group.start))+sum(log(1:(nsamp-group.start))))
           if (log(boot.start)>maxboots) boot.start <- max(1,maxboots)

           temp <- wle.normal(samp,num.sol=(m+1),
                              group=group.start,
                              boot=boot.start,
                              smooth=smooth.start,
                              tol=tol.start,equal=equal.start,
                              raf=raf,
                              max.iter=max.iter.start,
                              verbose=verbose)

#       if (verbose) print(temp)

       if (temp$tot.sol>0) {
           if (temp$tot.sol>1) {
               t.location <- temp$location[!(temp$tot.weights==max(temp$tot.weights))]
               t.scale <- temp$scale[!(temp$tot.weights==max(temp$tot.weights))]
               t.weights <- temp$tot.weights[!(temp$tot.weights==max(temp$tot.weights))]
               m.weights <- matrix(temp$weights[!(temp$tot.weights==max(temp$tot.weights)),],nrow=max(1,(temp$tot.sol-1)),byrow=FALSE)
           } else {
               t.location <- temp$location
               t.scale <- temp$scale
               t.weights <- temp$tot.weights
               m.weights <- matrix(temp$weights,nrow=temp$tot.sol)
           }

           temp.location <- c(temp.location,t.location)
           temp.scale <- c(temp.scale,t.scale)
           temp.weights <- c(temp.weights,t.weights)

           samp <- samp[apply(m.weights,2,max)<min.weights]

           tot.size <- length(samp)/group       
     
           if (length(samp)<3 | length(temp.location)>=m) {
               tot.size <- 0
           }

       } else {
           mmboot <- mmboot + 1
       }
       
    }
# end of while (tot.size > min.size)
    mmm <- length(temp.location)
    if (mmm>=m) {
        iboot <- iboot + 1
        if (verbose) cat("Found ",iboot," starting points \n")
        loc.boot[iboot,] <- (temp.location[order(temp.weights)])[(mmm-m+1):mmm]
        var.boot[iboot,] <- ((temp.scale[order(temp.weights)])[(mmm-m+1):mmm])^2
        temp.prop <- (temp.weights[order(temp.weights)])[(mmm-m+1):mmm]
        prop.boot[iboot,] <- temp.prop/sum(temp.prop)
    }

}

if (iboot>0) {


if (verbose) {
    cat("Starting points: \n")
    cat("Location: \n")
    print.default(format(loc.boot, digits=3),
		  print.gap = 2, quote = FALSE)
    cat("Scale: \n")
    print.default(format(sqrt(var.boot), digits=3),
		  print.gap = 2, quote = FALSE)
    cat("Proportion: \n")
    print.default(format(prop.boot, digits=3),
		  print.gap = 2, quote = FALSE)
}

  z <- .Fortran("wlenmix",
	as.double(x), 
	as.integer(size),
        as.integer(m),
        as.matrix(loc.boot),
        as.matrix(var.boot),
        as.matrix(prop.boot),
	as.integer(boot),
	as.integer(num.sol),
	as.integer(raf),
	as.double(smooth),
	as.double(tol),
	as.double(equal),
	as.integer(max.iter),
        as.integer(all.comp),
        as.double(min.weights),
	mean=mat.or.vec(num.sol,m),
	var=mat.or.vec(num.sol,m),
        pi=mat.or.vec(num.sol,m),
	totweight=double(num.sol),
	weight=mat.or.vec(num.sol,size),
	density=mat.or.vec(num.sol,size),
	model=mat.or.vec(num.sol,size),
	delta=mat.or.vec(num.sol,size),
	same=integer(num.sol),
	nsol=integer(1),
	nconv=integer(1),
	PACKAGE = "wle")

keep.col <- 1:z$nsol

if (z$nsol>0) {

    if (num.sol==1) {
        if (any(is.nan(z$mean))) z$nsol <- 0
    } else {
        del.nan <- apply(is.nan(z$mean),1,any)
        keep <- as.numeric(!del.nan)
        keep.col <- c(keep.col,rep(0,num.sol))[1:num.sol]
        keep.col <- keep*keep.col
        keep.col <- keep.col[keep.col!=0]
        z$nsol <- length(keep.col)
    }
}
          
if (z$nsol>0) {

    if (num.sol>1) {
        result$location <- z$mean[keep.col,]
        result$scale <- sqrt(z$var[keep.col,])
        result$pi <- z$pi[keep.col,]
    } else {
        result$location <- z$mean
        result$scale <- sqrt(z$var)
        result$pi <- z$pi
    }
    result$tot.weights <- z$totweight[keep.col]/size
    result$weights <- z$weight[keep.col,]
    result$f.density <- z$density[keep.col,]
    result$m.density <- z$model[keep.col,]
    result$delta <- z$delta[keep.col,]
    result$freq <- z$same[keep.col]
    result$tot.sol <- z$nsol
    result$not.conv <- z$nconv
} else {
    if (verbose) cat("wle.normal.mixture: No solutions are fuond, checks the parameters\n")

    result$location <- rep(NA,m)
    result$scale <- rep(NA,m)
    result$pi <- rep(NA,m)
    result$tot.weights <- NA
    result$weights <- rep(NA,size)
    result$f.density <- rep(NA,size)
    result$m.density <- rep(NA,size)
    result$delta <- rep(NA,size)
    result$freq <- NA
    result$tot.sol <- 0
    result$not.conv <- boot
}

} else {
    if (verbose) cat("wle.normal.mixture: Not able to find a good starting values\n")

    result$location <- rep(NA,m)
    result$scale <- rep(NA,m)
    result$pi <- rep(NA,m)
    result$tot.weights <- NA
    result$weights <- rep(NA,size)
    result$f.density <- rep(NA,size)
    result$m.density <- rep(NA,size)
    result$delta <- rep(NA,size)
    result$freq <- NA
    result$tot.sol <- 0
    result$not.conv <- boot

}

result$call <- match.call()
class(result) <- "wle.normal.mixture"
return(result)
}

#############################################################
#                                                           #
#	print.wle.normal.mixture function                   #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: October, 3, 2001                              #
#	Version: 0.2                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

print.wle.normal.mixture <- function(x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    cat("Location:\n")
    print.default(format(x$location, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("Scale:\n")
    print.default(format(x$scale, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("Proportion:\n")
    print.default(format(x$pi, digits=digits),
		  print.gap = 2, quote = FALSE)


    cat("\n")
    cat("\nNumber of solutions ",x$tot.sol,"\n")
    cat("\n")
    invisible(x)
}






     




#############################################################
#                                                           #
#	wle.normal.mixture.start function                   #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: October, 3, 2001                              #
#	Version: 0.1                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.normal.mixture.start <- function(x, m, boot=5, group, raf="HD", smooth=0.003, tol=10^(-15), equal=10^(-2), min.size=0.02, min.weights=0.3, boot.start=20, group.start=3, max.iter.start=500, max.iter.boot=20, verbose=FALSE) {

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

if (missing(m)) {
    m <-2
    if (verbose) cat("wle.normal.mixture.start: number of component set to default value: 2 \n")
}

if (m<2) {
    m <-2
    if (verbose) cat("wle.normal.mixture.start: number of component set to default value: 2\n")
}

if (missing(group)) {
    group <- 0
}

x <- as.vector(x)
size <- length(x)
result <- list()

if (size<2) {
    stop("Number of observation must be at least equal to 2")
}

if (group<2) {
    group <- max(2,round(size/4))
    if (verbose) cat("wle.normal.mixture.start: dimension of the subsample set to default value: ",group,"\n")
}

if (group.start<2 | group.start>=group) {
    group.start <- max(2,round(group/4))
    if (verbose) cat("wle.normal.mixture.start: dimension of the subsample of the starting values set to default value: ",group.start,"\n")
}


maxboot <- sum(log(1:size))-(sum(log(1:group))+sum(log(1:(size-group))))

if (boot<1 | log(boot) > maxboot) {
    stop("Bootstrap replication not in the range")
}

maxboots <- sum(log(1:group))-(sum(log(1:group.start))+sum(log(1:(group-group.start))))

if (boot.start<1 | log(boot.start) > maxboots) {
    stop("Bootstrap replication for the starting values not in the range")
}

if (max.iter.boot<1) {
    if (verbose) cat("wle.normal.mixture.start: max number of iteration in the boot step set to 20 \n")
    max.iter.boot <- 20
}

if (max.iter.start<1) {
    if (verbose) cat("wle.normal.mixture.start: max number of iteration in the starting process set to 500 \n")
    max.iter <- 500
}

if (smooth<10^(-5)) {
    if (verbose) cat("wle.normal.mixture.start: the smooth parameter seems too small \n")
}

if (tol<=0) {
    if (verbose) cat("wle.normal.mixture.start: the accuracy must be positive, using default value: 10^(-6) \n")
tol <- 10^(-6)
}

if (equal<=tol) {
    if (verbose) cat("wle.normal.mixture.start: the equal parameter can not be less than or equal to tol, using default value: tol+10^(-3)\n")
equal <- tol+10^(-3)
}

loc.boot <- matrix(0,nrow=boot,ncol=m)
var.boot <- matrix(0,nrow=boot,ncol=m)
prop.boot <- matrix(0,nrow=boot,ncol=m)

iboot <- 0
mboot <- 0
while (iboot < boot & mboot <= max.iter.boot) {

    mboot <- mboot + 1
    mmboot <- 0    

    samp <- sample(x,group,replace=FALSE)
    temp.location <- vector(length=0,mode="numeric")
    temp.scale <- vector(length=0,mode="numeric")
    temp.prop <- vector(length=0,mode="numeric")
    temp.weights <- vector(length=0,mode="numeric")
    tot.size <- 1

    while (tot.size > min.size & mmboot <= max.iter.boot) {

           nsamp <- length(samp)
           group.start <- min(group.start,nsamp)
           maxboots <- sum(log(1:nsamp))-(sum(log(1:group.start))+sum(log(1:(nsamp-group.start))))
           if (log(boot.start)>maxboots) boot.start <- max(1,maxboots)

           temp <- wle.normal(samp,num.sol=(m+1),
                              group=group.start,
                              boot=boot.start,
                              smooth=smooth,
                              tol=tol,equal=equal,
                              raf=raf,
                              max.iter=max.iter.start,
                              verbose=verbose)

#       if (verbose) print(temp)

       if (temp$tot.sol>0) {
           if (temp$tot.sol>1) {
               t.location <- temp$location[!(temp$tot.weights==max(temp$tot.weights))]
               t.scale <- temp$scale[!(temp$tot.weights==max(temp$tot.weights))]
               t.weights <- temp$tot.weights[!(temp$tot.weights==max(temp$tot.weights))]
               m.weights <- matrix(temp$weights[!(temp$tot.weights==max(temp$tot.weights)),],nrow=max(1,(temp$tot.sol-1)),byrow=FALSE)
           } else {
               t.location <- temp$location
               t.scale <- temp$scale
               t.weights <- temp$tot.weights
               m.weights <- matrix(temp$weights,nrow=temp$tot.sol)
           }

           temp.location <- c(temp.location,t.location)
           temp.scale <- c(temp.scale,t.scale)
           temp.weights <- c(temp.weights,t.weights)

           samp <- samp[apply(m.weights,2,max)<min.weights]

           tot.size <- length(samp)/group       
     
           if (length(samp)<3 | length(temp.location)>=m) {
               tot.size <- 0
           }

       } else {
           mmboot <- mmboot + 1
       }
       
    }
# end of while (tot.size > min.size)
    mmm <- length(temp.location)
    if (mmm>=m) {
        iboot <- iboot + 1
        if (verbose) cat("Found ",iboot," starting points \n")
        loc.boot[iboot,] <- (temp.location[order(temp.weights)])[(mmm-m+1):mmm]
        var.boot[iboot,] <- ((temp.scale[order(temp.weights)])[(mmm-m+1):mmm])^2
        temp.prop <- (temp.weights[order(temp.weights)])[(mmm-m+1):mmm]
        prop.boot[iboot,] <- temp.prop/sum(temp.prop)
    }

}

if (iboot>0) {
  if (verbose) {
    cat("Starting points: \n")
    cat("Location: \n")
    print.default(format(loc.boot, digits=3),
		  print.gap = 2, quote = FALSE)
    cat("Scale: \n")
    print.default(format(sqrt(var.boot), digits=3),
		  print.gap = 2, quote = FALSE)
    cat("Proportion: \n")
    print.default(format(prop.boot, digits=3),
		  print.gap = 2, quote = FALSE)
  }

    result$location <- as.matrix(loc.boot)[1:iboot,]
    result$scale <- as.matrix(sqrt(var.boot))[1:iboot,]
    result$pi <- as.matrix(prop.boot)[1:iboot,]
    result$boot <- iboot
    result$not.conv <- boot - iboot
} else {
    if (verbose) cat("wle.normal.mixture.start: Not able to find a good starting values\n")

    result$location <- rep(NA,m)
    result$scale <- rep(NA,m)
    result$pi <- rep(NA,m)
    result$boot <- 0
    result$not.conv <- boot

}

result$call <- match.call()
class(result) <- "wle.normal.mixture.start"
return(result)
}






     




#############################################################
#                                                           #
#	wle.normal.multi function                               #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: April, 02, 2002                                   #
#	Version: 0.4-1                                          #
#                                                           #
#	Copyright (C) 2002 Claudio Agostinelli                  #
#                                                           #
#############################################################

wle.normal.multi <- function(x, boot=30, group, num.sol=1, raf="HD", smooth, tol=10^(-6), equal=10^(-3), max.iter=500, verbose=FALSE) {

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

if (missing(group)) {
    group <- 0
}

if (is.null(size <- nrow(x)) | is.null(nvar <- ncol(x))) {
    if (is.vector(x)) {
	return(wle.normal(x=x, boot=boot, group=group, num.sol=num.sol, raf=raf, smooth=smooth, tol=tol, equal=equal, max.iter=max.iter)) 
    } else {
	stop("'x' must be a matrix or a vector")
    }
}

if (missing(smooth)) {
    smooth <- wle.smooth(dimension=nvar,costant=4,weight=0.5,interval=c(0.0001,20))$root
}

result <- list()

if (size<(nvar*(nvar+1)/2+nvar)) {
stop(paste("Number of observation must be at least equal to ",nvar*nvar))
}
if (group<(nvar*(nvar+1)/2+nvar)) {
    group <- max(round(size/4),(nvar*(nvar+1)/2+nvar))
    if (verbose) cat("wle.normal.multi: dimension of the subsample set to default value: ",group,"\n")
}

maxboot <- sum(log(1:size))-(sum(log(1:group))+sum(log(1:(size-group))))

if (boot<1 | log(boot) > maxboot) {
    stop("Bootstrap replication not in the range")
}

if (!(num.sol>=1)) {
    if (verbose) cat("wle.normal.multi: number of solution to report set to 1 \n")
    num.sol <- 1
}

if (max.iter<1) {
    if (verbose) cat("wle.normal.multi: max number of iteration set to 500 \n")
    max.iter <- 500
}

if (smooth<10^(-5)) {
    if (verbose) cat("wle.normal.multi: the smooth parameter seems too small \n")
}

if (tol<=0) {
    if (verbose) cat("wle.normal.multi: the accuracy must be positive, using default value: 10^(-6)\n")
    tol <- 10^(-6)
}

if (equal<=tol) {
    if (verbose) cat("wle.normal.multi: the equal parameter must be greater than tol, using default value: tol+10^(-3) \n")
    equal <- tol+10^(-3)
}

  z <- .Fortran("wlenormmulti",
	as.double(x), 
	as.integer(size),
	as.integer(nvar),
	as.integer(boot),
	as.integer(group),
	as.integer(num.sol),
	as.integer(raf),
	as.double(smooth),
	as.double(tol),
	as.double(equal),
	as.integer(max.iter),
	mean=mat.or.vec(num.sol,nvar),
	var=mat.or.vec(num.sol,nvar*nvar),
	totweight=double(num.sol),
	weight=mat.or.vec(num.sol,size),
	density=mat.or.vec(num.sol,size),
	model=mat.or.vec(num.sol,size),
	delta=mat.or.vec(num.sol,size),
	same=integer(num.sol),
	nsol=integer(1),
	nconv=integer(1),
	PACKAGE="wle")

dn <- colnames(x)

if (z$nsol>0) {

temp <- z$var[1:z$nsol,]
if (z$nsol>1) {
    temp.a <- matrix(temp[1,],ncol=nvar)
    dimnames(temp.a) <- list(dn,dn)
    temp.b <- list(temp.a)
    for (i in 2:z$nsol) {
         temp.a <- matrix(temp[i,],ncol=nvar)
         dimnames(temp.a) <- list(dn,dn)
         temp.b <- c(temp.b,list(temp.a))
    }
} else {
    temp.a <- matrix(temp,ncol=nvar)
    dimnames(temp.a) <- list(dn,dn)
    temp.b <- list(temp.a)
}
    result$location <- z$mean[1:z$nsol,]
    result$variance <- temp.b
    result$tot.weights <- z$totweight[1:z$nsol]/size
    result$weights <- z$weight[1:z$nsol,]
    result$f.density <- z$density[1:z$nsol,]
    result$m.density <- z$model[1:z$nsol,]
    result$delta <- z$delta[1:z$nsol,]
    result$freq <- z$same[1:z$nsol]
    result$tot.sol <- z$nsol
    result$not.conv <- z$nconv
} else {
    if (verbose) cat("wle.normal.multi: No solutions are fuond, checks the parameters\n")

    result$location <- rep(NA,nvar)
    result$variance <- matrix(NA,ncol=nvar,nrow=nvar)
    result$tot.weights <- NA
    result$weights <- rep(NA,size)
    result$f.density <- rep(NA,size)
    result$m.density <-rep(NA,size)
    result$delta <- rep(NA,size)
    result$freq <- NA
    result$tot.sol <- 0
    result$not.conv <- boot
}

if (is.null(nrow(result$location))) {
    names(result$location) <- dn
} else {
    dimnames(result$location) <- list(NULL,dn)
}
result$call <- match.call()
result$smooth <- smooth

class(result) <- "wle.normal.multi"

return(result)
}

print.wle.normal.multi <- function(x, digits = max(3, getOption("digits") - 3), ...)
{
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    cat("Location:\n")
    print.default(format(x$location, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("\nVariance-Covariance matrix:\n")
    print.default(x$variance, digits=digits,
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("\nNumber of solutions ",x$tot.sol,"\n")
    cat("\n")
    invisible(x)
}







#############################################################
#                                                           #
#	wle.onestep function                                #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@stat.unipd.it                       #
#	Date: December, 19, 2000                            #
#	Version: 0.3                                        #
#                                                           #
#	Copyright (C) 2000 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.onestep <- function(formula, data=list(), model=TRUE, x=FALSE, y=FALSE, ini.param, ini.scale, raf="HD", smooth=0.031, num.step=1, contrasts=NULL, verbose=FALSE) {

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

    ret.x <- x
    ret.y <- y
    result <- list()	
    mt <- terms(formula, data = data)
    mf <- cl <- match.call()
    mf$ini.param <- mf$ini.scale <- mf$smooth <- NULL
    mf$num.step <- mf$raf <- mf$contrasts <- NULL
    mf$model <- mf$x <- mf$y <- NULL
    mf$verbose <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    xvars <- as.character(attr(mt, "variables"))[-1]
    inter <- attr(mt, "intercept")
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <-
	if(length(xvars) > 0) {
	    xlev <- lapply(mf[xvars], levels)
	    xlev[!sapply(xlev, is.null)]
	}
    ydata <- model.response(mf, "numeric")
    if (is.empty.model(mt)) 
	stop("The model is empty")
    else 
	xdata <- model.matrix(mt, mf, contrasts)

if (is.null(size <- nrow(xdata)) | is.null(nvar <- ncol(xdata))) stop("'x' must be a matrix")
if (length(ydata)!=size) stop("'y' and 'x' are not compatible")

if (size<(nvar+1)) {stop("Number of observation must be at least equal to the number of predictors (including intercept) + 1")}

if (!(ini.scale>=0)) {
stop("The initial scale error must be non negative")
}

if (!(num.step>=1)) {
    if (verbose) cat("wle.onestep: number of steps can not be negative, set to 1 \n")
    num.step <- 1
}

if (smooth<10^(-5)) {
    if (verbose) cat("wle.onestep: the smooth parameter seems too small \n")
}

ini.var <- ini.scale^2

  z <- .Fortran("wleonestepfix",
	as.double(ydata),
	as.matrix(xdata),
	as.integer(0), 
	as.integer(size),
	as.integer(nvar),
	as.integer(nvar),
	as.double(ini.param),
	as.double(ini.var),
	as.integer(raf),
	as.double(smooth),
	as.integer(num.step),
	param=double(nvar),
	var=double(1),
	resid=double(size),
	totweight=double(1),
	weight=double(size),
	density=double(size),
	model=double(size),
	delta=double(size),
        PACKAGE = "wle")

if (z$var>0) {

    devparam <- sqrt(z$var*diag(solve(t(xdata)%*%diag(z$weight)%*%xdata)))

    result$coefficients <- z$param
    result$standard.error <- devparam
    result$scale <- sqrt(z$var)
    result$residuals <- z$resid
    result$fitted.values <- as.vector(xdata%*%z$param)
    result$weights <- z$weight
    result$f.density <- z$density
    result$m.density <- z$model
    result$delta <- z$delta
    result$tot.weights <- z$totweight

} else {
    if (verbose) cat("The initial estimates do not seems very good: the total sum of the weights is less than number of independent variables\n")


    result$coefficients <- rep(NA,nvar)
    result$standard.error <- rep(NA,nvar)
    result$scale <- NA
    result$residuals <- rep(NA,size)
    result$fitted.values <- rep(NA,size)
    result$weights <- rep(NA,size)
    result$f.density <- rep(NA,size)
    result$m.density <- rep(NA,size)
    result$delta <- rep(NA,size)
    result$tot.weights <- NA
}

result$call <- cl
result$contrasts <- attr(xdata, "contrasts")
result$xlevels <- xlev
result$terms <- mt

if (model)
    result$model <- mf
if (ret.x)
    result$x <- xdata
if (ret.y)
    result$y <- ydata

if (is.null(names(ini.param))) {
    dn <- colnames(xdata)
} else {
    dn <- names(ini.param)
}

if (is.null(nrow(result$coefficients))) {
    names(result$coefficients) <- dn
} else {
    dimnames(result$coefficients) <- list(NULL,dn)
}

class(result) <- "wle.onestep"
return(result)
}

#############################################################
#                                                           #
#	print.wle.onestep function                          #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@stat.unipd.it                       #
#	Date: December, 19, 2000                            #
#	Version: 0.3                                        #
#                                                           #
#	Copyright (C) 2000 Claudio Agostinelli              #
#                                                           #
#############################################################

print.wle.onestep <- function(x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    cat("Coefficients:\n")
    print.default(format(coef(x), digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("Scale estimate: ",format(x$scale, digits=digits))
    cat("\n")

    invisible(x)
}
#############################################################
#                                                           #
#	wle.poisson function                                #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 3, 2001                               #
#	Version: 0.2                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.poisson <- function(x, boot=30, group, num.sol=1, raf="HD", tol=10^(-6), equal=10^(-3), max.iter=500, verbose=FALSE) {

result <- list()

if (raf!="HD" & raf!="NED" & raf!="SCHI2") stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

if (missing(group)) {
group <- 0
}

x <- as.vector(x)
size <- length(x)
result <- list()

if (size<1) {
stop("Number of observation must be at least equal to 1")
}

if (group<1) {
    group <- max(round(size/4),1)
    if (verbose) cat("wle.poisson: dimension of the subsample set to default value: ",group,"\n")
}

maxboot <- sum(log(1:size))-(sum(log(1:group))+sum(log(1:(size-group))))

if (boot<1 | log(boot) > maxboot) {
    stop("Bootstrap replication not in the range")
}

if (!(num.sol>=1)) {
    if (verbose) cat("wle.poisson: number of solution to report set to 1 \n")
    num.sol <- 1
}

if (max.iter<1) {
    if (verbose) cat("wle.poisson: max number of iteration set to 500 \n")
    max.iter <- 500
}

if (tol<=0) {
    if (verbose) cat("wle.poisson: the accuracy must be positive, using default value: 10^(-6) \n")
    tol <- 10^(-6)
}

if (equal<=tol) {
    if (verbose) cat("wle.poisson: the equal parameter must be greater than tol, using default value: tol+10^(-3)\n")
equal <- tol+10^(-3)
}

tot.sol <- 0
not.conv <- 0
iboot <- 0

while (tot.sol < num.sol & iboot < boot) {
   iboot <- iboot + 1
   x.boot <- x[round(runif(group,0.501,size+0.499))]
   p <- sum(x.boot)/group

   ff <- rep(0,size)
   x.diff <- tol + 1
   iter <- 0
   while (x.diff > tol & iter < max.iter) {
   iter <- iter + 1
   p.old <- p 
       tff <- table(x)/size
       nff <- as.numeric(names(tff))
       for (i in 1:size) {
           ff[i] <- tff[nff==x[i]] 
       }
       mm <- dpois(x,lambda=p)
       dd <- ff/mm - 1
       
       ww <- switch(raf,
                 HD =  2*(sqrt(dd + 1) - 1) ,
	         NED =  2 - (2 + dd)*exp(-dd) ,
	         SCHI2 =  1-(dd^2/(dd^2 +2)) )       

       if (raf=="HD" | raf=="NED") {
            ww <- (ww + 1)/(dd + 1)
       }

       ww[ww > 1] <- 1
       ww[ww < 0] <- 0

       p <- ww%*%x/sum(ww)

       x.diff <- abs(p - p.old)
   }
#### end of while (x.diff > tol & iter < max.iter)

   if (iter < max.iter) {

   if (tot.sol==0) {
      p.store <- p
      w.store <- ww
      f.store <- ff
      m.store <- mm
      d.store <- dd
      tot.sol <- 1
   } else {
      if (min(abs(p.store-p))>equal) {
          p.store <- c(p.store,p)
          w.store <- rbind(w.store,ww)
          f.store <- rbind(f.store,ff)
          m.store <- rbind(m.store,mm)
          d.store <- rbind(d.store,dd)
          tot.sol <- tot.sol + 1
      }
   }

   } else not.conv <- not.conv + 1
   
}
##### end of while (tot.sol < num.sol & iboot < boot)

if (tot.sol) {
    result$lambda <- c(p.store)
    result$tot.weights <- sum(ww)/size
    result$weights <- w.store
    result$f.density <- f.store
    result$m.density <- m.store
    result$delta <- d.store
    result$tot.sol <- tot.sol
    result$not.conv <- not.conv
} else {
    if (verbose) cat("wle.poisson: No solutions are fuond, checks the parameters\n")
    result$lambda <- NA
    result$tot.weights <- NA
    result$weights <- rep(NA,size)
    result$f.density <- rep(NA,size)
    result$m.density <- rep(NA,size)
    result$delta <- rep(NA,size)
    result$tot.sol <- 0
    result$not.conv <- boot
}

result$call <- match.call()
class(result) <- "wle.poisson"
return(result)
}

#############################################################
#                                                           #
#	print.wle.poisson function                          #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: August, 3, 2001                               #
#	Version: 0.2                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

print.wle.poisson <- function(x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    cat("lambda:\n")
    print.default(format(x$lambda, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("\nNumber of solutions ",x$tot.sol,"\n")
    cat("\n")
    invisible(x)
}



#############################################################
#                                                           #
#	wle.smooth function                                 #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: October, 10, 2000                             #
#	Version: 0.3                                        #
#                                                           #
#	Copyright (C) 2000 Claudio Agostinelli              #
#                                                           #
#############################################################

wle.smooth <- function(weight=0.31,costant=3,level=0.2,dimension=1,raf="HD",interval=c(0.00001,0.5),tol=10^-6,max.iter=1000) {

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

delta <- function(smooth,costant,level,dimension){
level*(((smooth+1)/smooth)^(dimension/2)*exp(costant^2/(2*(dimension+1)))-1)}

if (raf==3) {w <- function(smooth,costant,level,dimension,weight){(1-((delta(smooth,costant,level,dimension)**2)/((delta(smooth,costant,level,dimension)**2) + 2)))-weight}
} else {
if (raf==2) {
adelta <- function(d) {2-(2+d)*exp(-d)} 
} else {
adelta <- function(d) {2*(sqrt(d+1)-1)}
}
w <- function(smooth,costant,level,dimension,weight){
(adelta(delta(smooth,costant,level,dimension))+1)/(delta(smooth,costant,level,dimension)+1)-weight
}
}

result <- uniroot(w,interval=interval,costant=costant,level=level,dimension=dimension,weight=weight,maxiter=max.iter,tol=tol)

result$call <- match.call()

class(result) <- "wle.smooth"

return(result)
}

#############################################################
#                                                           #
#	print.wle.smooth function                           #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: October, 10, 2000                             #
#	Version: 0.3                                        #
#                                                           #
#	Copyright (C) 2000 Claudio Agostinelli              #
#                                                           #
#############################################################

print.wle.smooth <- function(x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    cat("\nBandwidth: ",format(x$root, digits=digits))
    cat("\n")
    invisible(x)
}



#############################################################
#                                                           #
#	wle.stepwise function                                   #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: October, 27, 2003                                 #
#	Version: 0.4-2                                          #
#                                                           #
#	Copyright (C) 2002 Claudio Agostinelli                  #
#                                                           #
#############################################################

wle.stepwise <- function(formula, data=list(), model=TRUE, x=FALSE, y=FALSE, boot=30, group, num.sol=1, raf="HD", smooth=0.031, tol=10^(-6), equal=10^(-3), max.iter=500, min.weight=0.5, type="Forward", f.in=4.0, f.out=4.0, method="WLE", contrasts=NULL, verbose=FALSE)
{

raf <- switch(raf,
	HD = 1,
	NED = 2,
	SCHI2 = 3,
	-1)

if (raf==-1) stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

ntype <- switch(type,
	Forward = 1,
	Backward = 2,
	Stepwise = 3,
	-1)

if (ntype==-1) stop("The type must be Forward, Backward or Stepwise")

nmethod <- switch(method,
		WLE = 0,
	    WLS = 1,
		-1)

if (nmethod==-1) stop("The method must be WLE, or WLS the default value is WLE")

if (missing(group)) {
group <- 0
}

    ret.x <- x
    ret.y <- y
    result <- list()	
    mt <- terms(formula, data = data)
    mf <- cl <- match.call()
    mf$boot <- mf$group <- mf$smooth <- NULL
    mf$tol <- mf$equal <- mf$num.sol <- NULL
    mf$max.iter <- mf$raf <- mf$contrasts <- NULL
    mf$min.weight <- NULL
    mf$type <- mf$f.in <- mf$f.out <- NULL
    mf$model <- mf$x <- mf$y <- mf$method <- NULL
    mf$verbose <- NULL
    mf$drop.unused.levels <- TRUE
    mf[[1]] <- as.name("model.frame")
    mf <- eval(mf, sys.frame(sys.parent()))
    xvars <- as.character(attr(mt, "variables"))[-1]
    inter <- attr(mt, "intercept")
    if((yvar <- attr(mt, "response")) > 0) xvars <- xvars[-yvar]
    xlev <-
	if(length(xvars) > 0) {
	    xlev <- lapply(mf[xvars], levels)
	    xlev[!sapply(xlev, is.null)]
	}
    ydata <- model.response(mf, "numeric")
    if (is.empty.model(mt)) 
	stop("The model is empty")
    else 
	xdata <- model.matrix(mt, mf, contrasts)

if (is.null(size <- nrow(xdata)) | is.null(nvar <- ncol(xdata))) stop("'x' must be a matrix")
if (length(ydata)!=size) stop("'y' and 'x' are not compatible")

if (size<nvar) {
    stop("Number of observations must be at least equal to the number of predictors (including intercept)")
}

if (f.in<0 | f.out<0) {
    stop("f.in and f.out can not be negative")
}

if (group<1) {
    group <- max(round(size/4),nvar)
    if (verbose) cat("wle.stepwise: dimension of the subsample set to default value: ",group,"\n")
}

maxboot <- sum(log(1:size))-(sum(log(1:group))+sum(log(1:(size-group))))

if (boot<1 | log(boot) > maxboot) {
    stop("Bootstrap replication not in the range")
}

if (!(num.sol>=1)) {
    if (verbose) cat("wle.stepwise: number of solution to report set to 1 \n")
    num.sol <- 1
}

if (max.iter<1) {
    if (verbose) cat("wle.stepwise: max number of iteration set to 500 \n")
    max.iter <- 500
}

if (smooth<10^(-5)) {
    if (verbose) cat("wle.stepwise: the smooth parameter seems too small \n")
}

if (tol<=0) {
    if (verbose) cat("wle.stepwise: the accuracy must be positive, using default value: 10^(-6)\n")
    tol <- 10^(-6)
}

if (equal<=tol) {
    if (verbose) cat("wle.stepwise: the equal parameter must be greater than tol, using default value: tol+10^(-3)\n")
    equal <- tol+10^(-3)
}

if (min.weight<0) {
    if (verbose) cat("wle.stepwise: the minimum sum of the weights can not be negative, using default value \n")
    min.weight <- 0.5
}

nrep <- 2^nvar-1

  z <- .Fortran("wstep",
	as.double(ydata),
	as.matrix(xdata),
	as.integer(0), 
	as.integer(size),
	as.integer(nvar),
	as.integer(boot),
	as.integer(group),
	as.integer(nrep),
	as.integer(raf),
	as.double(smooth),
	as.integer(ntype),
	as.double(tol),
	as.double(equal),
	as.integer(max.iter),
	as.integer(num.sol),
	as.double(min.weight),
	as.double(f.in),
	as.double(f.out),
	as.integer(nmethod),
	wstep=mat.or.vec(nrep,nvar+1),
	param=mat.or.vec(num.sol,nvar),
	var=double(num.sol),
	resid=mat.or.vec(num.sol,size),
	totweight=double(num.sol),
	weight=mat.or.vec(num.sol,size),
	same=integer(num.sol),
	indice=integer(1),
	info=integer(1),
	imodel=integer(1),
	nsol=integer(1),
	PACKAGE="wle")

result$wstep <- z$wstep[1:z$imodel,]
result$coefficients <- z$param[1:z$nsol,]
result$scale <- sqrt(z$var[1:z$nsol])
result$residuals <- z$resid[1:z$nsol,]
result$tot.weights <- z$totweight[1:z$nsol]
result$weights <- z$weight[1:z$nsol,]
result$freq <- z$same[1:z$nsol]
result$index <- z$indice
result$info <- z$info
result$call <- cl
result$contrasts <- attr(xdata, "contrasts")
result$xlevels <- xlev
result$terms <- mt
result$type <- type
result$method <- method
result$f.in <- f.in
result$f.out <- f.out

if (model)
    result$model <- mf
if (ret.x)
    result$x <- xdata
if (ret.y)
    result$y <- ydata

dn <- colnames(xdata)

if (is.null(nrow(result$coefficients))) {
names(result$coefficients) <- dn
} else {
dimnames(result$coefficients) <- list(NULL,dn)
}

if (z$imodel<=1) {
names(result$wstep) <- c(dn," ")
} else {
dimnames(result$wstep) <- list(NULL,c(dn," "))
}

class(result) <- "wle.stepwise"

return(result)

}

#############################################################
#                                                           #
#	summary.wle.stepwise function                       #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: December, 3, 2001                             #
#	Version: 0.4-1                                      #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

summary.wle.stepwise <- function (object, num.max=20, verbose=FALSE, ...) {

if (is.null(object$terms)) {
    stop("invalid \'wle.stepwise\' object")
}

if (num.max<1) {
    if (verbose) cat("summary.wle.stepwise: num.max can not less than 1, num.max=1 \n")
    num.max <- 1
}

ans <- list()
wstep <- object$wstep
if(is.null(nmodel <- nrow(wstep))) nmodel <- 1
num.max <- min(nmodel,num.max)
if (nmodel!=1) { 
    wstep <- wstep[(nmodel-num.max+1):nmodel,]
}

ans$wstep <- wstep
ans$num.max <- num.max
ans$type <- object$type
ans$f.in <- object$f.in
ans$f.out <- object$f.out
ans$call <- object$call

class(ans) <- "summary.wle.stepwise"
return(ans)
}

#############################################################
#                                                           #
#	print.wle.stepwise function                             #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: October, 27, 2003                                 #
#	Version: 0.4-1                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

print.wle.stepwise <- function (x, digits = max(3, getOption("digits") - 3), num.max=max(1, nrow(x$wstep)), ...) {
res <- summary.wle.stepwise(object=x, num.max=num.max, ...)
print.summary.wle.stepwise(res, digits=digits, ...)
}

#############################################################
#                                                           #
#	print.summary.wle.stepwise function                 #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: December, 3, 2001                             #
#	Version: 0.4                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#############################################################

print.summary.wle.stepwise <- function (x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n")
    cat(paste(deparse(x$call), sep="\n", collapse = "\n"), "\n\n", sep="")

    cat("\n",x$type," selection procedure\n")
    if (x$type=="Forward" | x$type=="Stepwise") {
	cat("\nF.in: ",x$f.in)
    } 
    if (x$type=="Backward" | x$type=="Stepwise") {
	cat("\nF.out: ",x$f.out)
    }
    cat(" \n")
    cat("\nLast ",x$num.max," iterations:\n")

    if(x$num.max>1) {
    nvar <- ncol(x$wstep)-1
    x$wstep[,(nvar+1)] <- signif(x$wstep[,(nvar+1)],digits)
    } else {
    nvar <- length(x$wstep)-1
    x$wstep[(nvar+1)] <- signif(x$wstep[(nvar+1)],digits)
    }
    print(x$wstep)
    cat("\n")
    invisible(x)
}







#############################################################
#                                                           #
#	wle.t.test function                                 #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: Febraury 9, 2001                              #
#	Version: 0.1                                        #
#                                                           #
#	Copyright (C) 2001 Claudio Agostinelli              #
#                                                           #
#	Based on t.test function in                         #
#       ctest package version 1.2.0                         #
#                                                           #
#############################################################

wle.t.test <- function(x, y=NULL, alternative = c("two.sided", "less", "greater"), mu=0, paired = FALSE, var.equal = FALSE, conf.level = 0.95, boot=30, group, num.sol=1, raf="HD", smooth=0.003, tol=10^(-6), equal=10^(-3), max.iter=500) {

    alternative <- match.arg(alternative)
    wy <- NULL
    x.out <- x
    y.out <- y

    if(!missing(mu) && (length(mu) != 1 || is.na(mu)))
        stop("mu must be a single number")
    if(!missing(conf.level) &&
       (length(conf.level) != 1 || !is.finite(conf.level) ||
        conf.level < 0 || conf.level > 1))
        stop("conf.level must be a single number between 0 and 1")
    if( !is.null(y) ) {
	dname <- paste(deparse(substitute(x)),"and",
		       deparse(substitute(y)))
	if(paired)
	    xok <- yok <- complete.cases(x,y)
	else {
	    yok <- !is.na(y)
	    xok <- !is.na(x)
	}
	y <- y[yok]
    }
    else {
	dname <- deparse(substitute(x))
	if( paired ) stop("y is missing for paired test")
	xok <- !is.na(x)
	yok <- NULL
    }
    x <- x[xok]
    if( paired ) {
	x <- x-y
	y <- NULL
    }

    nx <- length(x)
    if(nx < 2) stop("not enough x observations")
    x.est <- wle.normal(x=x,boot=boot, group=group, num.sol=num.sol, raf=raf, smooth=smooth, tol=tol, equal=equal, max.iter=max.iter)
    x.tot.sol <- x.est$tot.sol
    y.tot.sol <- 1
    y.root <- 1
     
    if( !is.null(y) ) {
    ny <- length(y)
    if(ny < 2) stop("not enough y observations")
    y.est <- wle.normal(x=y,boot=boot, group=group, num.sol=num.sol, raf=raf, smooth=smooth, tol=tol, equal=equal, max.iter=max.iter)
    y.tot.sol <- y.est$tot.sol
    }

    wtstat <- matrix(0,ncol=y.tot.sol,nrow=x.tot.sol)
    wdf <- matrix(0,ncol=y.tot.sol,nrow=x.tot.sol)
    num.col <- 1
    if (!is.null(y) & paired==FALSE) num.col <- 2
    westimate <- matrix(0,nrow=x.tot.sol*y.tot.sol,ncol=num.col) 

    for (x.root in 1:x.tot.sol) {

    if (x.tot.sol==1) {
    mx <- x.est$location
    vx <- x.est$scale^2
    wx <- x.est$weights
    if (is.nan(mx) | is.nan(vx)) stop("no solutions are found for location and scale of 'x'")
    } else {
    mx <- x.est$location[x.root]
    vx <- (x.est$scale^2)[x.root]
    wx <- x.est$weights[x.root,]    
    }

    sumwx <- sum(wx)

    estimate <- mx
    if(is.null(y)) {
	df <- sumwx-1
	stderr <- sqrt(vx/sumwx)
	tstat <- (mx-mu)/stderr
	method <- ifelse(paired,"Paired wt-test for normal distributed data","One Sample wt-test for normal distributed data")
	names(estimate) <- ifelse(paired,"mean of the differences","mean of x")
    wtstat[x.root,y.root] <- tstat
    wdf[x.root,y.root] <- df
    westimate[x.root*y.root,] <- estimate

    } else {

        for (y.root in 1:y.tot.sol) {

        if (y.tot.sol==1) {
            my <- y.est$location
            vy <- y.est$scale^2
            wy <- y.est$weights
            if (is.nan(my) | is.nan(vy)) stop("no solutions are found for location and scale of 'y'")
        } else {
            my <- y.est$location[y.root]
            vy <- (y.est$scale^2)[y.root]
            wy <- y.est$weights[y.root,]    
        }

        sumwy <- sum(wy)

	method <- paste(if(!var.equal) "Welch", "Two Sample wt-test for normal distributed data")
	estimate <- c(mx,my)
	names(estimate) <- c("mean of x","mean of y")
	if(var.equal) {
	    df <- sumwx+sumwy-2
	    v <- ((sumwx-1)*vx + (sumwy-1)*vy)/df
	    stderr <- sqrt(v*(1/sumwx+1/sumwy))
	} else {
	    stderrx <- sqrt(vx/sumwx)
	    stderry <- sqrt(vy/sumwy)
	    stderr <- sqrt(stderrx^2 + stderry^2)
	    df <- stderr^4/(stderrx^4/(sumwx-1) + stderry^4/(sumwy-1))
	}
        tstat <- (mx - my - mu)/stderr
        wtstat[x.root,y.root] <- tstat
        wdf[x.root,y.root] <- df
        westimate[x.root*y.root,] <- estimate
    }
    }
    }

    result <- list()

    for (x.root in 1:x.tot.sol) {

    result.x <- list()
    for (y.root in 1:y.tot.sol) {

    tstat <- wtstat[x.root,y.root]
    df <- wdf[x.root,y.root]
    estimate <- westimate[x.root*y.root,]

    if (alternative == "less") {
	pval <- pt(tstat, df)
	cint <- c(NA, tstat + qt(conf.level, df) )
    }
    else if (alternative == "greater") {
	pval <- pt(tstat, df, lower = FALSE)
	cint <- c(tstat - qt(conf.level, df), NA)
    }
    else {
	pval <- 2 * pt(-abs(tstat), df)
	alpha <- 1 - conf.level
        cint <- qt(1 - alpha/2, df)
	cint <- tstat + c(-cint, cint)
    }
    cint <- mu + cint * stderr
    names(tstat) <- "wt"
    names(df) <- "df"
    names(mu) <- if(paired || !is.null(y)) "difference in means" else "mean"
    attr(cint,"conf.level") <- conf.level
    if (x.tot.sol>1) {
       wx <- x.est$weights[x.root,]
    } else {
       wx <- x.est$weights
    }


    if (!is.null(y)) { 
       if (y.tot.sol>1) {
           wy <- y.est$weights[y.root,]
       } else {
           wy <- y.est$weights
       }
    }

    rval <- list(statistic = tstat, parameter = df, p.value = pval,
	       conf.int=cint, estimate=estimate, null.value = mu,
	       alternative=alternative,
	       method=method, data.name=dname, 
               x.weights=wx, y.weights=wy, 
               x.root=x.root, y.root=y.root)

    class(rval) <- "htest"

    result.x <-  c(result.x,list(rval))
    }
    result$test <- c(result$test,list(result.x))
    result.x <- list()
    }

    result$x.tot.sol <- x.tot.sol
    result$y.tot.sol <- y.tot.sol
    result$call <- match.call()   
    result$paired <- paired
    result$x <- x.out
    result$y <- y.out

    class(result) <- "wle.t.test"

    return(result)
}

#############################################################
#                                                           #
#	print.wle.t.test function                           #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: December 23, 2003                              #
#	Version: 0.1-1                                        #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli              #
#
#   The printhtest is a copy of the print.htest function to avoid error until a better fix is used. 
#                                        #
#############################################################

print.wle.t.test <- function(x, x.root="ALL", y.root="ALL", digits = 4, quote = TRUE, prefix = "", ...) {


printhtest <-
function(x, digits = 4, quote = TRUE, prefix = "", ...)
{
    cat("\n")
    writeLines(strwrap(x$method, prefix = "\t"))
    cat("\n")
    cat("data: ", x$data.name, "\n")
    out <- character()
    if(!is.null(x$statistic))
        out <- c(out, paste(names(x$statistic), "=",
                            format(round(x$statistic, 4))))
    if(!is.null(x$parameter))
        out <- c(out, paste(names(x$parameter), "=",
                            format(round(x$parameter, 3))))
    if(!is.null(x$p.value))
        out <- c(out, paste("p-value =",
                            format.pval(x$p.value, digits = digits)))
    writeLines(strwrap(paste(out, collapse = ", ")))
    if(!is.null(x$alternative)) {
        cat("alternative hypothesis: ")
	if(!is.null(x$null.value)) {
	    if(length(x$null.value) == 1) {
                alt.char <-
                    switch(x$alternative,
                           two.sided = "not equal to",
                           less = "less than",
                           greater = "greater than")
		cat("true", names(x$null.value), "is", alt.char,
                    x$null.value, "\n")
	    }
	    else {
		cat(x$alternative, "\nnull values:\n")
		print(x$null.value, ...)
	    }
	}
	else cat(x$alternative, "\n")
    }
    if(!is.null(x$conf.int)) {
	cat(format(100 * attr(x$conf.int, "conf.level")),
	    "percent confidence interval:\n",
            format(c(x$conf.int[1], x$conf.int[2])), "\n")
    }
    if(!is.null(x$estimate)) {
	cat("sample estimates:\n")
	print(x$estimate, ...)
    }
    cat("\n")
    invisible(x)
}
  
x.tot.sol <- x$x.tot.sol
y.tot.sol <- x$y.tot.sol

if (x.root!="ALL" & !is.numeric(x.root)) {
    stop("Please, choose one 'x' root, for print all root ALL")
} else if (x.root=="ALL") {
    x.root <- 1:x.tot.sol
} else if (x.tot.sol<x.root) {
    stop(paste("'x' Root ",root," not found"))
}

if (y.root!="ALL" & !is.numeric(y.root)) {
    stop("Please, choose one 'y' root, for print all root ALL")
} else if (y.root=="ALL") {
    y.root <- 1:y.tot.sol
} else if (y.tot.sol<y.root) {
    stop(paste("'y' Root ",root," not found"))
}

cat("\nCall:\n")
cat(paste(deparse(x$call), sep="\n", collapse = "\n"), "\n\n", sep="") 
cat("\n\nWeighted t test:\n", sep="")

for (xx.root in x.root) {
for (yy.root in y.root) {
    cat("\n'x' Root ",xx.root)
    if (!is.null(x$y) & x$paired==FALSE) cat (" 'y' Root ",yy.root)    
    printhtest(x$test[[xx.root]][[yy.root]], digits=digits, quote=quote, prefix=prefix, ...)
}
}
 
    cat("\nNumber of 'x' solutions ",x.tot.sol,"\n")
    if (!is.null(x$y) & x$paired==FALSE) cat("\nNumber of 'y' solutions ",y.tot.sol,"\n")
    cat("\n")
    invisible(x)

}


#############################################################
#                                                           #
#	wle.var.test function                               #
#	Author: Claudio Agostinelli                         #
#	E-mail: claudio@unive.it                            #
#	Date: April 3, 2003                                 #
#	Version: 0.2                                        #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli              #
#                                                           #
#	Based on var.test function in                       #
#       ctest package version 1.2.0                         #
#                                                           #
#############################################################

wle.var.test <- function(x, y, ratio = 1, alternative = c("two.sided", "less", "greater"), conf.level = 0.95, x.root=1, y.root=1) {

    if (!((length(ratio) == 1) && is.finite(ratio) && (ratio > 0)))
        stop("ratio must be a single positive number")

    alternative <- match.arg(alternative)

    if (!((length(conf.level) == 1) && is.finite(conf.level) &&
          (conf.level > 0) && (conf.level < 1)))
        stop("conf.level must be a single number between 0 and 1")

    DNAME <- paste(deparse(substitute(x)), "and", deparse(substitute(y)))

    if (inherits(x, "wle.lm") && inherits(y, "wle.lm")) {

        x.tot.sol <- x$tot.sol
        if (x.tot.sol<x.root) {
            stop(paste("'x' Root ",x.root," not found"))
        }
        if (x.tot.sol!=1) {
            x.res <- x$residuals[x.root,]
            x.c <- x$coefficients[x.root,]
            x.w <- x$weights[x.root,]
        } else {
            x.res <- x$residuals
            x.c <- x$coefficients
            x.w <- x$weights
        }

            x.n <- length(x.res)
            x.p <- length(x.c)
        
        DF.x <- x$tot.weights[x.root]*x.n - x.p 

        y.tot.sol <- y$tot.sol
        if (y.tot.sol<y.root) {
            stop(paste("'y' Root ",y.root," not found"))
        }

        if (y.tot.sol!=1) {
            y.res <- y$residuals[y.root,]
            y.c <- y$coefficients[y.root,]
            y.w <- y$weights[y.root,]
        } else {
            y.res <- y$residuals
            y.c <- y$coefficients
            y.w <- y$weights
        }

            y.n <- length(y.res)
            y.p <- length(y.c)

        DF.y <- y$tot.weights[y.root]*y.n - y.p 

    } else {

    if (inherits(x, "wle.normal") && inherits(y, "wle.normal")) {

       x.tot.sol <- x$tot.sol
        if (x.tot.sol<x.root) {
            stop(paste("'x' Root ",x.root," not found"))
        }
        if (x.tot.sol!=1) {
            x.res <- x$residuals[x.root,]
            x.w <- x$weights[x.root,]
        } else {
            x.res <- x$residuals
            x.w <- x$weights
        }
        x.n <- length(x.w)
       
        DF.x <- x$tot.weights[x.root]*x.n - 1 

        y.tot.sol <- y$tot.sol
        if (y.tot.sol<y.root) {
            stop(paste("'y' Root ",y.root," not found"))
        }

        if (y.tot.sol!=1) {
            y.res <- c(y$residuals[y.root,])
            y.w <- y$weights[y.root,]
        } else {
            y.res <- y$residuals
            y.w <- y$weights
        }
        y.n <- length(y.w)
       
        DF.y <- y$tot.weights[y.root]*y.n - 1
    
      } else {
          stop("'x' and 'y' must be of class wle.lm or wle.normal")
      }
      }
      
    V.x <- c(x.w%*%(x.res^2) / DF.x)
    V.y <- c(y.w%*%(y.res^2) / DF.y)

    ESTIMATE <- V.x / V.y
    STATISTIC <- ESTIMATE / ratio
    PARAMETER <- c(DF.x, DF.y)

    PVAL <- pf(STATISTIC, DF.x, DF.y)
    if (alternative == "two.sided") {
        PVAL <- 2 * min(PVAL, 1 - PVAL)
        BETA <- (1 - conf.level) / 2
        CINT <- c(ESTIMATE / qf(1 - BETA, DF.x, DF.y),
                  ESTIMATE / qf(BETA, DF.x, DF.y))
    }
    else if (alternative == "greater") {
        PVAL <- 1 - PVAL
        CINT <- c(ESTIMATE / qf(conf.level, DF.x, DF.y), Inf)
    }
    else
        CINT <- c(0, ESTIMATE / qf(1 - conf.level, DF.x, DF.y))
    names(STATISTIC) <- "WF"
    names(PARAMETER) <- c("num df", "denom df")
    names(ESTIMATE) <- names(ratio) <- "ratio of variances"
    attr(CINT, "conf.level") <- conf.level
    RVAL <- list(statistic = STATISTIC,
                 parameter = PARAMETER,
                 p.value = PVAL,
                 conf.int = CINT,
                 estimate = ESTIMATE,
                 null.value = ratio,
                 alternative = alternative,
                 method = "WF test to compare two variances",
                 data.name = DNAME)
    attr(RVAL, "class") <- "htest"
    return(RVAL)
}


#############################################################
#                                                           #
#	wle.vonmises function                                   #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: October, 15, 2003                                 #
#	Version: 0.1-8                                          #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

wle.vonmises <- function(x, boot=30, group, num.sol=1, raf="HD", smooth, tol=10^(-6), equal=10^(-3), max.iter=500, bias=FALSE, mle.bias=FALSE, max.kappa=500, min.kappa=0.01, use.smooth=TRUE,  p=2, verbose=FALSE) {

##############################################################
## convoluzione di due vonmises

dvm.convolution <- function(theta, mu1, mu2, kappa1, kappa2) {

  if (kappa1 < 0) stop("dvm.convolution: kappa1 must be not negative")
  if (kappa2 < 0) stop("dvm.convolution: kappa2 must be not negative")

  return(besselI(sqrt(kappa1^2+kappa2^2+2*kappa1*kappa2*cos(theta - (mu1+mu2))), 0)/(2*pi*besselI(kappa1, 0)*besselI(kappa2, 0)))
}

if (require(circular)) {

    result <- list()

    if (raf!="HD" & raf!="NED" & raf!="SCHI2") stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

    if (missing(group)) {
        group <- 0
    }

    x <- as.vector(x)
    size <- length(x)

    if (size<2) {
        stop("Number of observation must be at least equal to 2")
    }

    if (group<2) {
        group <- max(round(size/4),1)
        if (verbose) cat("wle.vonmises: dimension of the subsample set to default value: ",group,"\n")
    }

    if (boot<1) {
        stop("Bootstrap replication not in the range")
    }

    if (!(num.sol>=1)) {
        if (verbose) cat("wle.vonmises: number of solution to report set to 1 \n")
        num.sol <- 1
    }

    if (max.iter<1) {
        if (verbose) cat("wle.vonmises: max number of iteration set to 500 \n")
        max.iter <- 500
    }

    if (tol<=0) {
        if (verbose) cat("wle.vonmises: the accuracy must be positive, using default value: 10^(-6) \n")
        tol <- 10^(-6)
    }

    if (equal<=tol) {
        if (verbose) cat("wle.vonmises: the equal parameter must be greater than tol, using default value: tol+10^(-3)\n")
        equal <- tol+10^(-3)
    }

    if (p< -1) {
        if (verbose) cat("wle.vonmises: the p parameter must be greater than or equal to -1, using default value: 2 \n")
        p <- 2
    }

    if (smooth <= 0) {
        if (verbose) stop("wle.vonmises: the smooth parameter must be positive \n")
    }

tot.sol <- 0
not.conv <- 0
iboot <- 0

while (tot.sol < num.sol & iboot < boot) {
   iboot <- iboot + 1
   continue <- TRUE
   start.iter <- 0
   while (continue & start.iter <= max.iter) {
          x.boot <- sample(x, size=group, replace = FALSE)
          temp <- mle.vonmises(x.boot, bias=mle.bias)
          mu <- temp$mu
          kappa <- temp$kappa
          continue <- !is.finite(mu) | is.na(mu) | !is.finite(kappa) | is.na(kappa) | kappa > max.kappa | kappa <= 0
          start.iter <- start.iter + 1 
   }
   
   if (start.iter >= max.iter)
       stop("wle.vonmises: the procedure is not able to find a good starting points, please checks the parameters")
     
   if (verbose)
       cat("starting value mu: ", mu, "  kappa: ", kappa, "\n")
   x.diff <- tol + 1
   iter <- 0
   while (x.diff > tol & iter < max.iter) {
       iter <- iter + 1
       mu.old <- mu
       kappa.old <- kappa

       ff <- density.circular(x, z=x, bw=smooth*kappa, adjust=1)$y

       if (use.smooth) {
           mm <- dvm.convolution(theta=x, mu1=0, mu2=mu, kappa1=smooth, kappa2=kappa)
       } else {
           mm <- dvm(theta=x, mu=mu, kappa=kappa)
       }
       if (any(is.nan(mm)) | any(mm==0)) {
           iter = max.iter
       } else { 
           dd <- ff/mm - 1

           if (p==Inf && raf=="HD") {
               ww <- log(dd+1)
           } else {
               ww <- switch(raf,
                 HD =  p*((dd + 1)^(1/p) - 1) ,
	             NED =  2 - (2 + dd)*exp(-dd) ,
	             SCHI2 =  1-(dd^2/(dd^2 +2)) )       
           }
               
           if (raf=="HD" | raf=="NED") {
                ww <- (ww + 1)/(dd + 1)
           }

           ww[ww > 1] <- 1
           ww[ww < 0] <- 0
           sww <- sum(ww)
           wsinr <- ww%*%sin(x)
           wcosr <- ww%*%cos(x)
           mu <- atan(wsinr, wcosr)
           kappa <- A1inv(ww%*%cos(x - mu)/sww)

           if (bias == TRUE & !is.na(kappa)) {
               if (kappa < 2) {
                   kappa <- max(kappa - 2 * (sww * kappa)^-1, 0)
               } else {
                   kappa <- ((sww - 1)^3 * kappa)/(sww^3 + sww)
               }
           }
           if (!is.na(kappa) && kappa <= 0) {
               if (verbose) cat("wle.vonmises: kappa is set to min.kappa since it is negative \n")             
               kappa <- min.kappa
           }       
           x.diff <- max(abs(mu - mu.old), abs(kappa - kappa.old))
           if (is.na(x.diff)) iter <- max.iter

      }

   }
#### end of while (x.diff > tol & iter < max.iter)

   if (iter < max.iter) {

   if (tot.sol==0) {
      mu.store <- mu
      kappa.store <- kappa
      w.store <- ww
      tot.store <- sum(ww)/size
      f.store <- ff
      m.store <- mm
      d.store <- dd
      tot.sol <- 1
   } else {
      if (min(abs(mu.store - mu)) > equal | min(abs(kappa.store - kappa)) > equal) {
          mu.store <- c(mu.store, mu)
          kappa.store <- c(kappa.store, kappa)
          w.store <- rbind(w.store, ww)
          tot.store <- c(tot.store, sum(ww)/size)
          f.store <- rbind(f.store, ff)
          m.store <- rbind(m.store, mm)
          d.store <- rbind(d.store, dd)
          tot.sol <- tot.sol + 1
      }
   }

   } else not.conv <- not.conv + 1
   
}
##### end of while (tot.sol < num.sol & iboot < boot)

if (tot.sol) {
    result$mu <- c(mu.store)
    result$kappa <- c(kappa.store)   
    result$tot.weights <- tot.store
    result$weights <- w.store
    result$f.density <- f.store
    result$m.density <- m.store
    result$delta <- d.store
    result$tot.sol <- tot.sol
    result$not.conv <- not.conv
} else {
    if (verbose) cat("wle.vonmises: No solutions are fuond, checks the parameters\n")
    result$mu <- NA
    result$kappa <- NA    
    result$tot.weights <- NA
    result$weights <- rep(NA,size)
    result$f.density <- rep(NA,size)
    result$m.density <- rep(NA,size)
    result$delta <- rep(NA,size)
    result$tot.sol <- 0
    result$not.conv <- boot
}

result$call <- match.call()
class(result) <- "wle.vonmises"
return(result)

} else {
  stop("You need package 'circular' for this function")
}

}

#############################################################
#                                                           #
#	print.wle.vonmises function                             #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: December, 23, 2002                                #
#	Version: 0.1                                            #
#                                                           #
#	Copyright (C) 2002 Claudio Agostinelli                  #
#                                                           #
#############################################################

print.wle.vonmises <- function(x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    cat("mu:\n")
    print.default(format(x$mu, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")
    cat("kappa:\n")    
    print.default(format(x$kappa, digits=digits),
		  print.gap = 2, quote = FALSE)
    cat("\n")    
    cat("\nNumber of solutions ",x$tot.sol,"\n")
    cat("\n")
    invisible(x)
}
#############################################################
#                                                           #
#	wle.weights function                                    #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: April, 02, 2002                                   #
#	Version: 0.1-4                                          #
#                                                           #
#	Copyright (C) 2002 Claudio Agostinelli                  #
#                                                           #
#############################################################

wle.weights <- function(x, y=NULL, smooth=0.0031, sigma2, raf=1, location=FALSE, max.iter=1000, tol=10^(-6)) {

    result <- list()

    if (is.null(y)) {
        y <- x
    } else {
        location <- FALSE
    }  

    loc <- 0
    loc.old <- loc + tol + 1
    nx <- length(x)
    ny <- length(y)
    iter <- 0
    conv <- TRUE

    while (abs(loc-loc.old)>tol & conv) {

           iter <- iter + 1
           loc.old <- loc
           if (location) {
               y <- z <- x - loc
           } else {
               z <- x
           }

           w.temp <- .Fortran("wlew",
	              as.double(z), 
	              as.integer(nx),
	              as.double(y), 
	              as.integer(ny), 
	              as.integer(raf),
	              as.double(smooth),
	              as.double(sigma2),
	              totweight=double(1),
	              weights=double(nx),
				  PACKAGE="wle")

           loc <- sum(w.temp$weights*x)/sum(w.temp$weights)

           if (!location) loc <- loc.old
           if (iter > max.iter) conv <- FALSE
    }

    result$weights <- w.temp$weights
    if (location) {
        result$location <- loc
    } else {
        result$location <- NA
    }
    result$conv <- conv

return(result)
}

#############################################################
#                                                           #
#   wle.wrappednormal function                              #
#   Author: Claudio Agostinelli                             #
#   Email: claudio@unive.it                                 #
#   Date: October, 15, 2003                                 #
#   Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#   Version 0.1-2                                           #
#############################################################

wle.wrappednormal <- function(x, mu, rho, sd, K, boot=30, group, num.sol=1, raf="HD", smooth=0.0031, tol=10^(-6), equal=10^(-3), min.sd=1e-3, min.k=10, max.iter=100, use.smooth=TRUE,  p=2, verbose=FALSE) {
  
if (require(circular)) {

    x <- as.circular(x)
    xcircularp <- circularp(x)
    units <- xcircularp$units
    x <- conversion.circular(x, units="radians")
    x <- as.vector(x)
    size <- n <- length(x)
    result <- list()

    sinr <- sum(sin(x))
    cosr <- sum(cos(x))

    est.mu <- FALSE 
    if (missing(mu)) {  
        mu.temp <- atan(sinr, cosr)
        est.mu <- TRUE
    } else mu.temp <- mu
    
    est.rho <- FALSE
    if (missing(rho)) {
        if (missing(sd)) {
            sd.temp <- sqrt(-2*log(sqrt(sinr^2 + cosr^2)/n))
            if (is.na(sd.temp) || sd.temp < min.sd) sd.temp <- min.sd
            est.rho <- TRUE
         } else sd.temp <- sd
    } else { 
         sd.temp <- sqrt(-2*log(rho))
    }
        
    if (missing(K)) {
        range <- max(mu.temp, x) - min(mu.temp, x)
        K <- (range+6*sd.temp)%/%(2*pi)+1
        K <- max(min.k, K)
    }
    
    
    if (raf!="HD" & raf!="NED" & raf!="SCHI2") stop("Please, choose the RAF: HD=Hellinger Disparity, NED=Negative Exponential Disparity, SCHI2=Symmetric Chi-squares Disparity")

    if (missing(group)) {  
        group <- 0
    }

    if (size<2) {
        stop("Number of observation must be at least equal to 2")
    }

    if (group<2) {
        group <- max(round(size/4),1)
        if (verbose) cat("wle.wrappednormal: dimension of the subsample set to default value: ",group,"\n")
    }

    if (boot < 1) {
        stop("Bootstrap replication not in the range")
    }

    if (!(num.sol>=1)) {
        if (verbose) cat("wle.wrappednormal: number of solution to report set to 1 \n")
        num.sol <- 1
    }

    if (max.iter<1) {
        if (verbose) cat("wle.wrappednormal: max number of iteration set to 500 \n")
        max.iter <- 500
    }

    if (tol<=0) {
        if (verbose) cat("wle.wrappednormal: the accuracy must be positive, using default value: 10^(-6) \n")
        tol <- 10^(-6)
    }

    if (equal<=tol) {
        if (verbose) cat("wle.wrappednormal: the equal parameter must be greater than tol, using default value: tol+10^(-3)\n")
        equal <- tol+10^(-3)
    }

    if (p< -1) {
        if (verbose) cat("wle.wrappednormal: the p parameter must be greater than or equal to -1, using default value: 2 \n")
        p <- 2
    }

    if (smooth <= 0) {
        if (verbose) stop("wle.wrappednormal: the smooth parameter must be positive \n")
    }

    tot.sol <- 0
    not.conv <- 0
    iboot <- 0

    while (tot.sol < num.sol & iboot < boot) {
           iboot <- iboot + 1
           continue <- TRUE
           start.iter <- 0
           while (continue & start.iter <= max.iter) {
                  x.boot <- sample(x, size=group, replace = TRUE)
                  temp <- mle.wrappednormal(x=x.boot, mu=mu, rho=rho, sd=sd, K=K, tol=tol)
          mu <- temp$mu
          rho <- temp$rho
          sd <- temp$sd
          continue <- !is.finite(mu) | is.na(mu) | !is.finite(sd) | is.na(sd) | sd <= 0 | !temp$convergence
          start.iter <- start.iter + 1 
    }
   
    if (start.iter >= max.iter)
        stop("wle.wrappednormal: the procedure is not able to find a good starting points, please checks the parameters")
     
    if (verbose)
        cat("starting value mu: ", mu, "  rho: ", rho, " sd: ", sd, "\n")
     x.diff <- tol + 1
     iter <- 0
     while (x.diff > tol & iter < max.iter) {
            iter <- iter + 1 
            mu.old <- mu
            sd.old <- sd
       
            ff <- density.circular(x=x, z=x, bw=sqrt(smooth)*sd, adjust=1, kernel="wrappednormal", K=K)$y
  
            if (use.smooth) {
                mm <- dwrappednormal(x, mu=mu, sd=sqrt((1+smooth))*sd, K=K)
            } else {
                mm <- dwrappednormal(x, mu=mu, sd=sd, K=K)
            }
            if (any(is.nan(mm)) | any(mm==0)) {
                iter <- max.iter
            } else { 
                dd <- ff/mm - 1

                if (p==Inf && raf=="HD") {
                    ww <- log(dd+1)
                } else {
                    ww <- switch(raf,
                     HD =  p*((dd + 1)^(1/p) - 1) ,
	             NED =  2 - (2 + dd)*exp(-dd) ,
	             SCHI2 =  1-(dd^2/(dd^2 +2)) )       
                }
               
                if (raf=="HD" | raf=="NED") {
                    ww <- (ww + 1)/(dd + 1)
                } 

                ww[ww > 1] <- 1
                ww[ww < 0] <- 0
                sommaww <- sum(ww)
                
                iteriter <- 0
                xiterdiff <- 1 + tol
                while (xiterdiff > tol & iteriter <= max.iter) {
                       iteriter <- iteriter + 1
                       mu.olditer <- mu
                       sd.olditer <- sd

                       z <- .Fortran("mlewrpno",
                              as.double(x),
                              as.double(mu),
                              as.double(sd),
                              as.integer(size),
                              as.integer(K),
                              as.integer(est.mu),
                              as.integer(est.rho),
                              w=double(size),
                              wk=double(size),
                              wm=double(size),
                              PACKAGE="circular"
                       )
                       w <- z$w
                       wk <- z$wk
                       wm <- z$wm
           
                       if (est.mu) {
                           mu <- c(ww%*%x)/sommaww
                           if (any(wk!=0)) {
                               temp <- wk[wk!=0]/w[wk!=0]
                               mu <- mu + 2*pi*c(ww[wk!=0]%*%temp)/sum(ww[wk!=0])
                           }
                       }
                       if (est.rho) {
                           if  (any(wm!=0)) {
                                temp <- wm[wm!=0]/w[wm!=0]
                                sd <- sqrt(c(ww[wm!=0]%*%temp)/sum(ww[wm!=0]))
                           } else {
                                sd <- min.sd
                           }
                       }

                       if (verbose) {
                           cat("mu: ", mu, "\n")
                           cat("rho: ", exp(-sd^2/2), "\n")              
                           cat("sd: ", sd, "\n")
                       }
                       xdiff <- max(abs(mu - mu.olditer), abs(sd - sd.olditer))
                   }
     ########## close the inner while          
           
                   x.diff <- max(abs(mu - mu.old), abs(sd - sd.old))
                   if (is.na(x.diff)) iteriter <- iter <- max.iter

               }
               ######## close else for is.na(mm)  
           }
#### end of while (x.diff > tol & iter < max.iter)

   if (iter < max.iter) {

       if (tot.sol==0) {
           mu.store <- mu
           sd.store <- sd
           w.store <- ww
           tot.store <- sum(ww)/size
           f.store <- ff
           m.store <- mm
           d.store <- dd
           tot.sol <- 1
       } else {
           if (min(abs(mu.store - mu)) > equal | min(abs(sd.store - sd)) > equal) {
               mu.store <- c(mu.store, mu)
               sd.store <- c(sd.store, kappa)
               w.store <- rbind(w.store, ww)
               tot.store <- c(tot.store, sum(ww)/size)
               f.store <- rbind(f.store, ff)
               m.store <- rbind(m.store, mm)
               d.store <- rbind(d.store, dd)
               tot.sol <- tot.sol + 1
           }
       }

     } else not.conv <- not.conv + 1
   
  }
##### end of while (tot.sol < num.sol & iboot < boot)
    
  if (tot.sol) {
      result$mu <- c(mu.store)
      result$rho <- c(exp(-sd.store^2/2))
      result$sd <- c(sd.store)
      result$tot.weights <- tot.store
      result$weights <- w.store
      result$f.density <- f.store
      result$m.density <- m.store
      result$delta <- d.store
      result$tot.sol <- tot.sol
      result$not.conv <- not.conv
   } else {
      if (verbose) cat("wle.wrappednormal: No solutions are fuond, checks the parameters\n")
       result$mu <- NA
       result$rho <- NA
       result$sd <- NA
       result$tot.weights <- NA
       result$weights <- rep(NA,size)
       result$f.density <- rep(NA,size)
       result$m.density <- rep(NA,size)
       result$delta <- rep(NA,size)
       result$tot.sol <- 0
       result$not.conv <- boot
  }
     
  result$call <- match.call()
  class(result) <- "wle.wrappednormal"
  return(result)
    
} else {
  stop("You need package 'circular' for this function")
}

}


#############################################################
#                                                           #
#	print.wle.wrappednormal function                             #
#	Author: Claudio Agostinelli                             #
#	E-mail: claudio@unive.it                                #
#	Date: March, 17, 2003                                #
#	Version: 0.1                                            #
#                                                           #
#	Copyright (C) 2003 Claudio Agostinelli                  #
#                                                           #
#############################################################

print.wle.wrappednormal <- function(x, digits = max(3, getOption("digits") - 3), ...) {
    cat("\nCall:\n",deparse(x$call),"\n\n",sep="")
    cat("mu:\n")
    cat(format(x$mu, digits=digits), "\n")
    cat("\n")
    cat("rho: ")    
    cat(format(x$rho, digits=digits), "\n")
    cat("\n")
    cat("sd: ")       
    cat(format(x$sd, digits=digits), "\n")
    cat("\n")   
    cat("\nNumber of solutions ",x$tot.sol,"\n")
    cat("\n")
    invisible(x)
}











.First.lib <- function(lib, pkg) {
  library.dynam("wle", pkg, lib)
}
