R/density.R

In np: Nonparametric Kernel Smoothing Methods for Mixed Data Types

npdensity <- 
    function(bws, eval, dens,
             derr = NA, ll = NA,
             ntrain, trainiseval = FALSE,
             rows.omit = NA,
             train.rows.omit = rows.omit,
             eval.rows.omit = if (trainiseval) rows.omit else NA,
             timing = NA, total.time = NA,
             optim.time = NA, fit.time = NA){

        if (missing(bws) || missing(eval) || missing(dens) || missing(ntrain))
            stop("improper invocation of density constructor")

        if (length(rows.omit) == 0)
            rows.omit <- NA
        if (length(train.rows.omit) == 0)
            train.rows.omit <- NA
        if (length(eval.rows.omit) == 0)
            eval.rows.omit <- NA


        d <- list(
            bw = bws$bw,
            bws = bws,
            xnames = bws$xnames,
            nobs = nrow(eval),
            ndim = bws$ndim,
            nord = bws$nord,
            nuno = bws$nuno,
            ncon = bws$ncon,
            pscaling = bws$pscaling,
            ptype = bws$ptype,
            pckertype = bws$pckertype,
            pukertype = bws$pukertype,
            pokertype = bws$pokertype,
            eval = eval,
            dens = dens,
            derr = derr,
            log_likelihood = ll,
            ntrain = ntrain,
            trainiseval = trainiseval,
            rows.omit = rows.omit,
            nobs.omit = if (identical(rows.omit, NA)) 0 else length(rows.omit),
            train.rows.omit = train.rows.omit,
            ntrain.omit = if (identical(train.rows.omit, NA)) 0 else length(train.rows.omit),
            eval.rows.omit = eval.rows.omit,
            neval.omit = if (identical(eval.rows.omit, NA)) 0 else length(eval.rows.omit),
            timing = timing, total.time = total.time,
            optim.time = optim.time, fit.time = fit.time)


        class(d) <- "npdensity"

        return(d)
    }

print.npdensity <- function(x, digits=NULL, ...){
  cat("\nDensity Data: ", x$ntrain, " training points,",
      if (x$trainiseval) "" else paste(" and ", x$nobs,
                                      " evaluation points,", sep=""),
      " in ",x$ndim," variable(s)\n",sep="")

  printSearchParameterSummary(x$bw, x$xnames, x$bws, vari = "x",
                              fallback.label = paste(x$pscaling, ":", sep = ""),
                              digits = digits)

  cat(genDenEstStr(x))
  
  cat(genBwKerStrs(x$bws))
  
  cat("\n\n")
  if(!missing(...))
    print(...,digits=digits)
  invisible(x)
}

fitted.npdensity <- function(object, ...){
 object$dens 
}
se.npdensity <- function(x){ x$derr }

predict.npdensity <- function(object, se.fit = FALSE, ...) {
  se.fit <- npValidateScalarLogical(se.fit, "se.fit")
  dots <- list(...)
  has.formula.route <- !is.null(object$bws$formula)

  if (!is.null(dots$edat) && !is.null(dots$newdata)) {
    dots$newdata <- NULL
  } else if (!has.formula.route && is.null(dots$edat) && !is.null(dots$newdata)) {
    dots$edat <- dots$newdata
    dots$newdata <- NULL
  }

  tr <- do.call(npudens, c(list(bws = object$bws), dots))
  if(se.fit)
    return(list(fit = fitted(tr), se.fit = se(tr), 
                df = tr$nobs, log.likelihood = tr$log_likelihood))
  else
    return(fitted(tr))
}


summary.npdensity <- function(object, ...) {
  cat("\nDensity Data: ", object$ntrain, " training points,",
      if (object$trainiseval) "" else paste(" and ", object$nobs,
                                      " evaluation points,", sep=""),
      " in ",object$ndim," variable(s)\n",sep="")

  cat(genOmitStr(object))

  printSearchParameterSummary(object$bw, object$xnames, object$bws, vari = "x",
                              fallback.label = paste(object$pscaling, ":", sep = ""))

  cat(genDenEstStr(object))

  cat(genBwKerStrs(object$bws))
  cat(genTimingStr(object))
  cat('\n\n')  

}