Nothing
npregbw <-
function(...){
args = list(...)
if (is(args[[1]],"formula"))
UseMethod("npregbw",args[[1]])
else if (!is.null(args$formula))
UseMethod("npregbw",args$formula)
else
UseMethod("npregbw",args[[which(names(args)=="bws")[1]]])
}
npregbw.formula <-
function(formula, data, subset, na.action, call, ...){
orig.class <- if (missing(data))
sapply(eval(attr(terms(formula), "variables"), environment(formula)),class)
else sapply(eval(attr(terms(formula), "variables"), data, environment(formula)),class)
mf <- match.call(expand.dots = FALSE)
m <- match(c("formula", "data", "subset", "na.action"),
names(mf), nomatch = 0)
mf <- mf[c(1,m)]
if(all(orig.class == "ts")){
args <- (as.list(attr(terms(formula), "variables"))[-1])
formula <- terms(formula)
attr(formula, "predvars") <- as.call(c(quote(as.data.frame),as.call(c(quote(ts.intersect), args))))
mf[["formula"]] <- formula
}else if(any(orig.class == "ts")){
arguments <- (as.list(attr(terms(formula), "variables"))[-1])
arguments.normal <- arguments[which(orig.class != "ts")]
arguments.timeseries <- arguments[which(orig.class == "ts")]
ix <- sort(c(which(orig.class == "ts"),which(orig.class != "ts")),index.return = TRUE)$ix
formula <- terms(formula)
attr(formula, "predvars") <- bquote(.(as.call(c(quote(cbind),as.call(c(quote(as.data.frame),as.call(c(quote(ts.intersect), arguments.timeseries)))),arguments.normal,check.rows = TRUE)))[,.(ix)])
mf[["formula"]] <- formula
}
mf[[1]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
ydat <- model.response(mf)
xdat <- mf[, attr(attr(mf, "terms"),"term.labels"), drop = FALSE]
tbw <- npregbw(xdat = xdat, ydat = ydat, ...)
## clean up (possible) inconsistencies due to recursion ...
tbw$call <- match.call(expand.dots = FALSE)
environment(tbw$call) <- parent.frame()
tbw$formula <- formula
tbw$rows.omit <- as.vector(attr(mf,"na.action"))
tbw$nobs.omit <- length(tbw$rows.omit)
tbw$terms <- attr(mf,"terms")
tbw <-
updateBwNameMetadata(nameList =
list(ynames =
attr(mf, "names")[attr(tbw$terms, "response")]),
bws = tbw)
tbw
}
npregbw.NULL <-
function(xdat = stop("invoked without data 'xdat'"),
ydat = stop("invoked without data 'ydat'"),
bws, ...){
xdat <- toFrame(xdat)
bws = double(dim(xdat)[2])
tbw <- npregbw.default(xdat = xdat, ydat = ydat, bws = bws, ...)
## clean up (possible) inconsistencies due to recursion ...
mc <- match.call(expand.dots = FALSE)
environment(mc) <- parent.frame()
tbw$call <- mc
tbw <- updateBwNameMetadata(nameList =
list(ynames = deparse(substitute(ydat))),
bws = tbw)
tbw
}
npregbw.rbandwidth <-
function(xdat = stop("invoked without data 'xdat'"),
ydat = stop("invoked without data 'ydat'"),
bws, bandwidth.compute = TRUE,
nmulti, remin = TRUE, itmax = 10000,
ftol = 1.490116e-07, tol = 1.490116e-04, small = 1.490116e-05,
lbc.dir = 0.5, dfc.dir = 3, cfac.dir = 2.5*(3.0-sqrt(5)),initc.dir = 1.0,
lbd.dir = 0.1, hbd.dir = 1, dfac.dir = 0.25*(3.0-sqrt(5)), initd.dir = 1.0,
lbc.init = 0.1, hbc.init = 2.0, cfac.init = 0.5,
lbd.init = 0.1, hbd.init = 0.9, dfac.init = 0.375,
scale.init.categorical.sample = FALSE,...){
xdat <- toFrame(xdat)
if (missing(nmulti)){
nmulti <- min(5,dim(xdat)[2])
}
if(!(is.vector(ydat) | is.factor(ydat)))
stop("'ydat' must be a vector")
if (length(bws$bw) != dim(xdat)[2])
stop("length of bandwidth vector does not match number of columns of 'xdat'")
ccon = unlist(lapply(xdat[,bws$icon, drop = FALSE],class))
if ((any(bws$icon) && !all((ccon == class(integer(0))) | (ccon == class(numeric(0))))) ||
(any(bws$iord) && !all(unlist(lapply(xdat[,bws$iord, drop = FALSE],class)) ==
class(ordered(0)))) ||
(any(bws$iuno) && !all(unlist(lapply(xdat[,bws$iuno, drop = FALSE],class)) ==
class(factor(0)))))
stop("supplied bandwidths do not match 'xdat' in type")
if (dim(xdat)[1] != length(ydat))
stop("number of regression data and response data do not match")
## catch and destroy NA's
goodrows = 1:dim(xdat)[1]
rows.omit = attr(na.omit(data.frame(xdat,ydat)), "na.action")
goodrows[rows.omit] = 0
if (all(goodrows==0))
stop("Data has no rows without NAs")
xdat = xdat[goodrows,,drop = FALSE]
ydat = ydat[goodrows]
nrow = dim(xdat)[1]
ncol = dim(xdat)[2]
## at this stage, data to be sent to the c routines must be converted to
## numeric type.
if (is.factor(ydat))
ydat <- dlev(ydat)[as.integer(ydat)]
else
ydat <- as.double(ydat)
xdat = toMatrix(xdat)
runo = xdat[, bws$iuno, drop = FALSE]
rcon = xdat[, bws$icon, drop = FALSE]
rord = xdat[, bws$iord, drop = FALSE]
tbw <- bws
mysd <- EssDee(rcon)
nconfac <- nrow^(-1.0/(2.0*bws$ckerorder+bws$ncon))
ncatfac <- nrow^(-2.0/(2.0*bws$ckerorder+bws$ncon))
if (bandwidth.compute){
myopti = list(num_obs_train = dim(xdat)[1],
iMultistart = ifelse(nmulti==0,IMULTI_FALSE,IMULTI_TRUE),
iNum_Multistart = nmulti,
int_use_starting_values = ifelse(all(bws$bw==0),USE_START_NO, USE_START_YES),
int_LARGE_SF = ifelse(bws$scaling, SF_NORMAL, SF_ARB),
BANDWIDTH_reg_extern = switch(bws$type,
fixed = BW_FIXED,
generalized_nn = BW_GEN_NN,
adaptive_nn = BW_ADAP_NN),
itmax=itmax, int_RESTART_FROM_MIN=ifelse(remin,RE_MIN_TRUE,RE_MIN_FALSE),
int_MINIMIZE_IO=ifelse(options('np.messages'), IO_MIN_FALSE, IO_MIN_TRUE),
bwmethod = switch(bws$method,
cv.aic = BWM_CVAIC,
cv.ls = BWM_CVLS),
kerneval = switch(bws$ckertype,
gaussian = CKER_GAUSS + bws$ckerorder/2 - 1,
epanechnikov = CKER_EPAN + bws$ckerorder/2 - 1,
uniform = CKER_UNI,
"truncated gaussian" = CKER_TGAUSS),
ukerneval = switch(bws$ukertype,
aitchisonaitken = UKER_AIT,
liracine = UKER_LR),
okerneval = switch(bws$okertype,
wangvanryzin = OKER_WANG,
liracine = OKER_LR),
nuno = bws$nuno,
nord = bws$nord,
ncon = bws$ncon,
regtype = switch(bws$regtype,
lc = REGTYPE_LC,
ll = REGTYPE_LL),
int_do_tree = ifelse(options('np.tree'), DO_TREE_YES, DO_TREE_NO),
scale.init.categorical.sample = scale.init.categorical.sample,
dfc.dir = dfc.dir)
myoptd = list(ftol=ftol, tol=tol, small=small,
lbc.dir = lbc.dir, cfac.dir = cfac.dir, initc.dir = initc.dir,
lbd.dir = lbd.dir, hbd.dir = hbd.dir, dfac.dir = dfac.dir, initd.dir = initd.dir,
lbc.init = lbc.init, hbc.init = hbc.init, cfac.init = cfac.init,
lbd.init = lbd.init, hbd.init = hbd.init, dfac.init = dfac.init,
nconfac = nconfac, ncatfac = ncatfac)
total.time <-
system.time(myout <-
.C("np_regression_bw",
as.double(runo), as.double(rord), as.double(rcon), as.double(ydat),
as.double(mysd),
as.integer(myopti), as.double(myoptd),
bw = c(bws$bw[bws$icon],bws$bw[bws$iuno],bws$bw[bws$iord]),
fval = double(2),fval.history = double(max(1,nmulti)),
timing = double(1),
PACKAGE="np" )[c("bw","fval","fval.history","timing")])[1]
rorder = numeric(ncol)
rorder[c((1:ncol)[bws$icon], (1:ncol)[bws$iuno], (1:ncol)[bws$iord])]=1:ncol
tbw$bw <- myout$bw[rorder]
tbw$fval <- myout$fval[1]
tbw$ifval <- myout$fval[2]
tbw$fval.history <- myout$fval.history
tbw$timing <- myout$timing
tbw$total.time <- total.time
}
tbw$sfactor <- tbw$bandwidth <- tbw$bw
if (tbw$nuno > 0){
if(tbw$scaling){
tbw$bandwidth[tbw$xdati$iuno] <- tbw$bandwidth[tbw$xdati$iuno]*ncatfac
} else {
tbw$sfactor[tbw$xdati$iuno] <- tbw$sfactor[tbw$xdati$iuno]/ncatfac
}
}
if (tbw$nord > 0){
if(tbw$scaling){
tbw$bandwidth[tbw$xdati$iord] <- tbw$bandwidth[tbw$xdati$iord]*ncatfac
} else {
tbw$sfactor[tbw$xdati$iord] <- tbw$sfactor[tbw$xdati$iord]/ncatfac
}
}
if (tbw$ncon > 0){
dfactor <- mysd*nconfac
if (tbw$scaling) {
tbw$bandwidth[tbw$xdati$icon] <- tbw$bandwidth[tbw$xdati$icon]*dfactor
} else {
tbw$sfactor[tbw$xdati$icon] <- tbw$sfactor[tbw$xdati$icon]/dfactor
}
}
tbw <- rbandwidth(bw = tbw$bw,
regtype = tbw$regtype,
bwmethod = tbw$method,
bwscaling = tbw$scaling,
bwtype = tbw$type,
ckertype = tbw$ckertype,
ckerorder = tbw$ckerorder,
ukertype = tbw$ukertype,
okertype = tbw$okertype,
fval = tbw$fval,
ifval = tbw$ifval,
fval.history = tbw$fval.history,
nobs = tbw$nobs,
xdati = tbw$xdati,
ydati = tbw$ydati,
xnames = tbw$xnames,
ynames = tbw$ynames,
sfactor = tbw$sfactor,
bandwidth = tbw$bandwidth,
rows.omit = rows.omit,
nconfac = nconfac,
ncatfac = ncatfac,
sdev = mysd,
bandwidth.compute = bandwidth.compute,
timing = tbw$timing,
total.time = tbw$total.time)
tbw
}
npregbw.default <-
function(xdat = stop("invoked without data 'xdat'"),
ydat = stop("invoked without data 'ydat'"),
bws,
bandwidth.compute = TRUE, nmulti,
remin, itmax, ftol, tol, small,
lbc.dir, dfc.dir, cfac.dir, initc.dir,
lbd.dir, hbd.dir, dfac.dir, initd.dir,
lbc.init, hbc.init, cfac.init,
lbd.init, hbd.init, dfac.init,
scale.init.categorical.sample,
## dummy arguments for later passing into rbandwidth()
regtype, bwmethod, bwscaling, bwtype,
ckertype, ckerorder, ukertype, okertype,
...){
xdat <- toFrame(xdat)
if(!(is.vector(ydat) | is.factor(ydat)))
stop("'ydat' must be a vector")
## first grab dummy args for bandwidth() and perform 'bootstrap'
## bandwidth() call
mc.names <- names(match.call(expand.dots = FALSE))
margs <- c("regtype", "bwmethod", "bwscaling", "bwtype",
"ckertype", "ckerorder", "ukertype", "okertype")
m <- match(margs, mc.names, nomatch = 0)
any.m <- any(m != 0)
tbw <- eval(parse(text=paste("rbandwidth(bws",
ifelse(any.m, ",",""),
paste(mc.names[m], ifelse(any.m,"=",""), mc.names[m], collapse=", "),
", nobs = dim(xdat)[1],",
"xdati = untangle(xdat),",
"ydati = untangle(data.frame(ydat)),",
"xnames = names(xdat),",
"ynames = deparse(substitute(ydat)),",
"bandwidth.compute = bandwidth.compute)")))
mc.names <- names(match.call(expand.dots = FALSE))
margs <- c("bandwidth.compute", "nmulti", "remin", "itmax", "ftol", "tol",
"small",
"lbc.dir", "dfc.dir", "cfac.dir","initc.dir",
"lbd.dir", "hbd.dir", "dfac.dir", "initd.dir",
"lbc.init", "hbc.init", "cfac.init",
"lbd.init", "hbd.init", "dfac.init",
"scale.init.categorical.sample")
m <- match(margs, mc.names, nomatch = 0)
any.m <- any(m != 0)
tbw <- eval(parse(text=paste("npregbw.rbandwidth(xdat=xdat, ydat=ydat, bws=tbw",
ifelse(any.m, ",",""),
paste(mc.names[m], ifelse(any.m,"=",""), mc.names[m], collapse=", "),
")")))
mc <- match.call(expand.dots = FALSE)
environment(mc) <- parent.frame()
tbw$call <- mc
return(tbw)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.