R/x_math1.r In probhat: Multivariate Generalized Kernel Smoothing and Related Statistical Methods

```#probhat: Multivariate Generalized Kernel Smoothing and Related Statistical Methods
#Copyright (C), Abby Spurdle, 2019 to 2021

#This program is distributed without any warranty.

#This program is free software.
#You can modify it and/or redistribute it, under the terms of:
#The GNU General Public License, version 2, or (at your option) any later version.

#You should have received a copy of this license, with R.
#Also, this license should be available at:

.n.unique = function (x) length (unique (x) )
.any.duplicates = function (x) .n.unique (x) != length (x)

.midpoints = function (x)
{	n = length (x)
n1 = n + 1
(x [1:n] + x [2:n1]) / 2
}

.cumsum2 = function (x, rev=FALSE)
{	if (rev)
{	y = rev (cumsum (rev (x) ) )
y [1] = 1
}
else
{	y = cumsum (x)
y [length (y)] = 1
}
y
}

.val.tail = function (str, m=1)
{	str = .val.params (m, str)
str = tolower (str)
if (all (str == "lower" | str == "upper") )
str
else
stop ("tail needs to be lower or upper")
}

auto.dbw = function (x, ..., bw.method="ph.default", smoothness=1)
{	bw = auto.cbw (x, ..., bw.method=bw.method, smoothness=smoothness)
bw = as.integer (round (bw) )
if (bw %% 2 == 0)
bw = bw + 1
bw
}

auto.cbw = function (x, ..., bw.method="ph.default", smoothness=1)
{	bw.method = tolower (bw.method)
if (! is.matrix (x) )
x = cbind (x)
if (bw.method == "ph.default")
{	m = ncol (x)
P = 0.66^(1 / m)
a = (1 - P) / 2
b = 1 - a
bw = numeric (m)
for (j in seq_len (m) )
bw [j] = diff (quantile (x [,j], c (a, b) ) )
}
else if (bw.method == "scott") bw = apply (x, 2, bw.nrd)
else if (bw.method == "silverman") bw = apply (x, 2, bw.nrd0)
else
stop ("bw.method needs to be ph.default, Scott or Silverman")
smoothness * bw
}

.midpoints = function (x)
{	n = length (x)
(x [-n] + x [-1]) / 2
}

.as.integer.matrix = function (x)
{	y = as.integer (x)
dim (y) = dim (x)
y
}

.as.numeric.matrix = function (x)
{	y = as.numeric (x)
dim (y) = dim (x)
y
}

.varname = function (x)
{	if (is.matrix (x) && ncol (x) == 1)
colnames (x)
else
"x"
}

.varnames = function (x, prefix="x", is.cond=FALSE)
{	if (is.matrix (x) )
.varnames.ext (ncol (x), colnames (x), prefix, is.cond)
else
"x"
}

.varnames.ext = function (m, variable.names, prefix="x", is.cond=FALSE)
{	defn = paste0 (prefix, 1:m)
if (is.null (variable.names) )
{	variable.names = defn
if (is.cond)
warning ("applying default variable names, to all variables")
}
else
{	if (m != .n.unique (variable.names) )
stop ("needs unique variable names")
I = (is.na (variable.names) | variable.names == "")
if (any (I) )
{	variable.names [I] = defn [I]
if (is.cond)
warning ("applying default variable names, to some variables")
}
}
variable.names
}

.blabs = function (x)
{	if (is.matrix (x) )
rownames (x)
else
names (x)
}

.val.k = function (k)
{	if (is (k, "Kernel") )
k
else
stop ("needs Kernel object")
}

.val.params = function (m, param)
{	nparam = length (param)
if (nparam == 1)
rep (param, m)
else if (nparam == m)
param
else
stop ("parameter needs to have length 1 or m")
}

.val.x.uv = function (x, one.or.more=FALSE)
{	attributes (x) = NULL
if (is.vector (x) )
{	x = as.numeric (x)
if (one.or.more && length (x) == 0)
stop ("x needs one or more values")
if (any (! is.finite (x) ) )
stop ("all x values need to be finite")
x
}
else
stop ("needs vector (or matrix)")
}

.val.x.mv = function (x)
{	if (! is.matrix (x) )
stop ("multivariate models need matrix")
x = .as.numeric.matrix (x)
if (nrow (x) < 1)
stop ("x needs one or more rows")
if (any (! is.finite (x) ) )
stop ("all x values need to be finite")
x
}

.val.x.uv.or.mv = function (x)
{	if (is.matrix (x) )
.val.x.mv (x)
else
cbind (.val.x.uv (x) )
}

.val.hvec = function (n, h)
{	h = as.numeric (h)
nh = length (h)
if (nh == 1)
h = rep (h, n)
else if (n != length (h) )
stop ("length (h) != number of bins/observations")
if (any (! is.finite (h) ) )
stop ("all h values need to be finite")
if (any (h < 0) )
stop ("all h value need to be >= 0")
h
}

.val.w = function (is.weighted, n, w, scale=TRUE)
{	if (is.weighted)
{	w = as.numeric (w)
if (n != length (w) )
stop ("length (w) != number of observations")
if (any (! is.finite (w) ) )
stop ("all w values need to be finite")
if (any (w <= 0) )
stop ("all w value need to be >= 0")
if (scale)
w = w / sum (w)
w
}
else
NA
}

.deflab = function (f, lab)
{	if (missing (lab) )
{	vname = names (f)
if (is.dpdc (f) || is.cpdc (f) )
paste (vname, "| ...")
else
vname
}
else
lab
}

.iterate.uv = function (f, ..., u)
{	n = length (u)
y = numeric (n)
for (i in seq_len (n) )
y [i] = f (..., u [i])
y
}

.iterate.mv = function (f, ..., u)
{	n = nrow (u)
y = numeric (n)
for (i in seq_len (n) )
y [i] = f (..., u [i,])
y
}

.iterate.mv.2 = function (f, ..., y)
{	n = nrow (y)
x = numeric (n)
for (i in seq_len (n) )
x [i,] = f (..., y [i,])
x
}

.test.y.ok = function (y)
{	if (any (y < 0 | y > 1) )
stop ("probabilities need to be between 0 and 1")
}

.scale.freq = function (y, freq, N, n)
{	if (freq)
{	if (missing (n) )
n = N
n * y
}
else
y
}
```

Try the probhat package in your browser

Any scripts or data that you put into this service are public.

probhat documentation built on May 12, 2021, 5:08 p.m.