spatstat.univar/ 0000755 0001762 0000144 00000000000 14762030413 013420 5 ustar ligges users spatstat.univar/tests/ 0000755 0001762 0000144 00000000000 14632773657 014606 5 ustar ligges users spatstat.univar/tests/all.R 0000644 0001762 0000144 00000013506 14710660075 015470 0 ustar ligges users #' #' Header for all (concatenated) test files #' #' Require spatstat.univar #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.univar) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) # tests/weightedstats.R # $Revision: 1.2 $ $Date: 2023/11/05 01:40:53 $ local({ if(ALWAYS) { # depends on hardware ## whist() ## check agreement between C and interpreted code for whist() set.seed(98123) x <- runif(1000) w <- sample(1:5, 1000, replace=TRUE) b <- seq(0,1,length=101) aC <- whist(x,b,w, method="C") aR <- whist(x,b,w, method="interpreted") if(!all(aC == aR)) stop("Algorithms for whist disagree") } if(FULLTEST) { ## cases of 'unnormdensity()' x <- rnorm(20) d0 <- unnormdensity(x, weights=rep(0, 20)) dneg <- unnormdensity(x, weights=c(-runif(19), 0)) } }) #' #' tests/parzen.R #' #' Tests of the Parzen-Rosenblatt estimator #' (fixed bandwidth, no boundary correction) #' #' $Revision: 1.1 $ $Date: 2023/10/22 02:39:49 $ local({ if(FULLTEST) { #' code in kernels.R kernames <- c("gaussian", "rectangular", "triangular", "epanechnikov", "biweight", "cosine", "optcosine") X <- rnorm(20) U <- runif(20) for(ker in kernames) { dX <- dkernel(X, ker) fX <- pkernel(X, ker) qU <- qkernel(U, ker) m0 <- kernel.moment(0, 0, ker) m1 <- kernel.moment(1, 0, ker) m2 <- kernel.moment(2, 0, ker) m3 <- kernel.moment(3, 0, ker) fa <- kernel.factor(ker) sq <- kernel.squint(ker) } } }) local({ if(ALWAYS) { ## unnormdensity x <- rnorm(20) d0 <- unnormdensity(x, weights=rep(0, 20)) dneg <- unnormdensity(x, weights=c(-runif(19), 0)) } }) # # tests/NAinCov.R # # Testing the response to the presence of NA's in covariates # # $Revision: 1.10 $ $Date: 2024/09/30 23:13:54 $ if(FULLTEST) { local({ #' quantile.ewcdf f <- ewcdf(runif(100), runif(100)) qf <- quantile(f, probs=c(0.1, NA, 0.8)) #' quantile.density f <- density(runif(100)) qf <- quantile(f, probs=c(0.1, NA, 0.8)) }) } #' tests/direct.R #' #' Check output of densityBC() by comparing with #' kernel estimates computed directly in R code. #' #' $Revision: 1.2 $ $Date: 2023/10/22 02:39:35 $ INTERACTIVE <- FALSE #' ...... direct implementation ........................ #' #' Biweight boundary kernel (for estimation at point r) bdry.bwt <- function(x,r,h=1){ u <- x/h k <- (15/(16*h))*(1-u^2)^2*(u^2<1) p <- r/h p[p>1] <- 1 a0 <- (3*p^5 - 10*p^3 + 15*p + 8)/16 a1 <- (5*p^6 - 15*p^4 + 15*p^2 -5)/32 a2 <- (15*p^7 - 42*p^5 + 35*p^3 + 8)/112 bk <- (a2-a1*u)*k*(u
0.1]
cat("Range of relative discrepancies between estimates (boundary kernel):\n")
print(range(rel.discrep))
if(max(abs(rel.discrep)) > 0.01)
stop("Relative discrepancies between C and R code exceed 1 percent")
if(INTERACTIVE) par(opa)
#' tests/kermom.R
#'
#' Check R function kernel.moment() against C function kermom ()
#'
#' $Revision: 1.2 $ $Date: 2024/10/31 10:36:27 $
#'
moo <- 1
sdee <- 0.5
xx <- seq(moo - 4 * sdee, moo + 4 * sdee, length=512)
kernames <- c("gaussian", "rectangular", "triangular",
"epanechnikov", "biweight", "cosine", "optcosine")
eps <- sqrt(.Machine$double.eps)
for(m in 0:2) {
cat("Incomplete moment of order", m, fill=TRUE)
for(ker in kernames) {
Rvalues <- kernel.moment(m, xx, ker, mean=moo, sd=sdee)
Cvalues <- kermom(m, xx, ker, mean=moo, sd=sdee)
discrep <- max(abs(Rvalues-Cvalues))
if(discrep > eps)
stop(paste("kernel.moment and kermom disagree",
"for m =", m, "for kernel", sQuote(ker),
"\n\tDiscrepancy", discrep))
cat("Kernel", sQuote(ker), "\tdiscrepancy", discrep, fill=TRUE)
}
}
spatstat.univar/MD5 0000644 0001762 0000144 00000010277 14762030413 013737 0 ustar ligges users e8c3652f55a83db019fe8a31f29bfff0 *DESCRIPTION
4654f10f66d4e5cbaaa8edc1b7ab5e7c *NAMESPACE
3eff1dcd23f3eb2f045f35ce8d644e48 *NEWS
fca2044707f32b4cea5dcf4dac99d190 *R/First.R
4c02ad69a7cfd1f314d4571831ea3419 *R/access.R
3134f9d86064217840342b7b175bf423 *R/adaptive.R
8e3c0887993042516dd36109ea4b7442 *R/breakpts.R
a11d9192b621d300f00e62c64ee0a931 *R/bw.abram.default.R
fac8f031392b779db0ef140feadb7b67 *R/bw.pow.R
4f3ba491e9b7f1581c49ae79c844936b *R/bw.taylor.R
bdbf8749c27827c2f97b17c2549dd9f7 *R/densityBC.R
af144e51855eaa0886c69230d87fb5bc *R/ewcdf.R
b9d86a3f84aa7b91f8cbb262c1790f2b *R/hotrod.R
3d716e65c49c9e3adc713dbec35f4772 *R/indefinteg.R
43d6425c47025792a3e6183713e406da *R/integral.R
6e9eb85f76ced673abc1aa0d4bfae322 *R/kernels.R
75e0ab745be4574175ce89c736a6ac71 *R/kernelsBC.R
a1f38d938fa2e6bacbd490aa5047a880 *R/kmrs.R
4d8e1d1049bafb10ca8117a29a20f1ab *R/quantiledensity.R
442a508e7ecff8ce3f9d063d5fcc831a *R/rounding.R
85a46e7c7901b18a9916e43599d55807 *R/stieltjes.R
d961cac123a451f4072ca5510f44ae26 *R/transformquantiles.R
51cab9a67d249b47f86e29e19e997a0c *R/uniquemap.R
3bf7a5203c177defc01b450a50e16c2b *R/unnormdensity.R
079229523448ad874688ed31c6109ffb *R/util.R
9364ac0cfd68b3758689bab8ba27c2d1 *R/weightedStats.R
f2d49fc8f50fef7f76bcb3fc7f34efb4 *inst/CITATION
afe624f405adc1b88e2df698ecd8732f *inst/doc/packagesizes.txt
afe624f405adc1b88e2df698ecd8732f *inst/info/packagesizes.txt
1d8d9afeacbb8e67e56abf455ebfe6d6 *man/CDF.Rd
f4e762cf6897ace428262067e7460ef0 *man/bw.abram.Rd
3cff38a4ff88379e553290114674998c *man/bw.abram.default.Rd
e49df85cf50d5a4e7d7f1ef7b1d1d0d4 *man/bw.pow.Rd
d732088eaafb68ee6f050e83b1f05dba *man/bw.taylor.Rd
31c5655269374d65bdabc99bbcaf5187 *man/densityAdaptiveKernel.Rd
87a17181bb1ee98d4f6284e99c380334 *man/densityAdaptiveKernel.default.Rd
1d42ddab648b340a048727233558aa1f *man/densityBC.Rd
4095a77f5095c63ca099f9ad4f565140 *man/dkernel.Rd
e4e6fd59a406e7079fb3cb63a6815491 *man/dkernelBC.Rd
ebff14c1534380f970f2856287bc14a4 *man/ewcdf.Rd
43e64f87d4d42af7908ecff0c52098db *man/firstdigit.Rd
b3c0cb4c7cb3e188c1560aee63fc6491 *man/hotrod.Rd
461213181774879a7640a252503bf799 *man/indefinteg.Rd
e81e836eedc5551c5ce738e3a91e3664 *man/integral.Rd
4ce2d7e35c1d9daedd765f1e2d78fd01 *man/integral.density.Rd
55a3c5b55340b4242fe64a2e244235f9 *man/kaplan.meier.Rd
b57614afc259fd51b751070f1fdc7f77 *man/kernel.factor.Rd
7abc084b7409a62503cfc708d5fed19e *man/kernel.moment.Rd
88771048d25787afbdc8f2c0cc79d7b2 *man/kernel.squint.Rd
1efcd196df498043d360a07bacdda65e *man/km.rs.Rd
017d863ee0efcf516f97b2d84d45ad0c *man/knots.ewcdf.Rd
1ac6f0faf463fc5c6d189b778ea36fc3 *man/macros/defns.Rd
2d085eefe9af82314a7bd5c8e4255e5e *man/macros/newdefns.Rd
db978fdddd2b67ced9a96132524e5d7b *man/mean.ewcdf.Rd
e08ae36e41d428379476c17573706076 *man/quantile.density.Rd
544025e499afd9324c96344dad247727 *man/quantile.ewcdf.Rd
78bd0135c9f0b56b8a16b181c3b6f264 *man/quantilefun.Rd
396ba365547cdcad60faa9d6210ece8c *man/reduced.sample.Rd
19d3634f640b51ec593bedc47a7b1c09 *man/rounding.Rd
619e9ed55c1055b3ecfa1183b2459f8f *man/spatstat.univar-internal.Rd
257b7a646eddf47fb692765c614fb4b0 *man/spatstat.univar-package.Rd
0699d730be5b69939ebe777cae5e8870 *man/stieltjes.Rd
542e716e9844587fb821ded945a62b2c *man/transformquantiles.Rd
34f601fc0d654accc092190f934f15dc *man/uniquemap.default.Rd
9a699e1147d504b8034fbaaf6c2ed953 *man/unnormdensity.Rd
228ee2e515f68954d8d16d86e0bb99cb *man/weighted.median.Rd
3ebc017766e6e659391ffceed16291e5 *man/whist.Rd
6a67503592d550e973129ce76262d3b7 *src/access.c
36b33a63d08370590d80b54258a5d896 *src/adaptive.c
a1d2e166fb6a800ba6d4687a09d7b659 *src/adaptive.h
bee72005025d444878f39dfe04538921 *src/adaptiveloop.h
542e6e474340e0aac3ed97f6a92777b4 *src/chunkloop.h
1b9738e752131555074d88c14ff71337 *src/colonel.c
6fbedda3c74b58916a5ec20e250df805 *src/hotrod.c
e6ca12763d746c83d6a63339046a45f3 *src/init.c
2d19952a1e94edde639cc2a4b37155ef *src/interfacecodes.h
598be15f4239973602b7cc2154228991 *src/kerconstants.h
e9e957f574cf730523f36199b22b4857 *src/kernels.c
6de6d86beb695044cf06d31dedba0a02 *src/kernels.h
3b5793b28a7dc3645ae2d6d1aa675a39 *src/proto.h
d78a4636fbaa6f0262a6553d712137e7 *src/tabnum.c
4366dd120efa21df01119686e59b7551 *src/taylorboot.c
d43888baaecd5e2a8d25bc8bae058fb0 *src/whist.c
5b922aece5ddcd39a4cf74648749e1b2 *tests/all.R
spatstat.univar/R/ 0000755 0001762 0000144 00000000000 14756455360 013640 5 ustar ligges users spatstat.univar/R/weightedStats.R 0000644 0001762 0000144 00000007001 14632773657 016605 0 ustar ligges users #'
#' weightedStats.R
#'
#' weighted versions of hist, var, median, quantile
#'
#' $Revision: 1.11 $ $Date: 2024/05/06 00:50:47 $
#'
#'
#' whist weighted histogram
#'
whist <- function(x, breaks, weights=NULL, method=c("C", "interpreted")) {
N <- length(breaks)
if(length(x) == 0)
h <- numeric(N+1)
else {
# classify data into histogram cells (breaks need not span range of data)
cell <- findInterval(x, breaks, rightmost.closed=TRUE)
# values of 'cell' range from 0 to N.
nb <- N + 1L
if(is.null(weights)) {
## histogram
h <- tabulate(cell+1L, nbins=nb)
} else {
## weighted histogram
method <- match.arg(method)
switch(method,
interpreted = {
cell <- factor(cell, levels=0:N)
h <- unlist(lapply(split(weights, cell), sum, na.rm=TRUE))
},
C = {
h <- .Call(SK_Cwhist,
as.integer(cell),
as.double(weights),
as.integer(nb),
PACKAGE="spatstat.univar")
})
}
}
h <- as.numeric(h)
y <- h[2:N]
attr(y, "low") <- h[1]
attr(y, "high") <- h[N+1]
return(y)
}
#' wrapper for computing weighted variance of a vector
#' Note: this includes a factor 1 - sum(v^2) in the denominator
#' where v = w/sum(w). See help(cov.wt)
weighted.var <- function(x, w, na.rm=TRUE) {
bad <- is.na(w) | is.na(x)
if(any(bad)) {
if(!na.rm) return(NA_real_)
ok <- !bad
x <- x[ok]
w <- w[ok]
}
cov.wt(matrix(x, ncol=1),w)$cov[]
}
#' weighted median
weighted.median <- function(x, w, na.rm=TRUE, type=2, collapse=TRUE) {
unname(weighted.quantile(x, probs=0.5, w=w, na.rm=na.rm, type=type, collapse=collapse))
}
#' weighted quantile
weighted.quantile <- function(x, w, probs=seq(0,1,0.25), na.rm=TRUE, type=4, collapse=TRUE) {
x <- as.numeric(as.vector(x))
w <- as.numeric(as.vector(w))
if(length(x) == 0)
stop("No data given")
stopifnot(length(x) == length(w))
if(is.na(m <- match(type, c(1,2,4))))
stop("Argument 'type' must equal 1, 2 or 4", call.=FALSE)
type <- c(1,2,4)[m]
if(anyNA(x) || anyNA(w)) {
ok <- !(is.na(x) | is.na(w))
x <- x[ok]
w <- w[ok]
}
if(length(x) == 0)
stop("At least one non-NA value is required")
stopifnot(all(w >= 0))
if(all(w == 0)) stop("All weights are zero", call.=FALSE)
#'
oo <- order(x)
x <- x[oo]
w <- w[oo]
Fx <- cumsum(w)/sum(w)
#'
if(collapse && anyDuplicated(x)) {
dup <- rev(duplicated(rev(x)))
x <- x[!dup]
Fx <- Fx[!dup]
}
#'
nx <- length(x)
if(nx > 1) {
result <- switch(as.character(type),
"1" = approx(Fx, x, xout=probs, ties="ordered", rule=2,
method="constant", f=1)$y,
"2" = {
j <- approx(Fx, 1:nx, xout=probs, ties="ordered",
rule=2, method="constant", f=0)$y
j <- as.integer(j)
g <- probs - Fx[j]
jplus1 <- pmin(j+1, nx)
ifelse(g == 0, (x[j]+x[jplus1])/2, x[jplus1])
},
"4" = approx(Fx, x, xout=probs, ties="ordered", rule=2,
method="linear")$y)
} else {
result <- rep.int(x, length(probs))
}
names(result) <- paste0(format(100 * probs, trim = TRUE), "%")
return(result)
}
spatstat.univar/R/ewcdf.R 0000644 0001762 0000144 00000015124 14640456407 015051 0 ustar ligges users #
# ewcdf.R
#
# $Revision: 1.29 $ $Date: 2024/07/01 07:29:45 $
#
# With contributions from Kevin Ummel
#
ewcdf <- function(x, weights=NULL, normalise=TRUE, adjust=1)
{
nx <- length(x)
nw <- length(weights)
weighted <- (nw > 0)
if(weighted) {
check.nvector(weights, things="entries of x", oneok=TRUE, vname="weights")
stopifnot(all(weights >= 0))
if(nw == 1)
weights <- rep(weights, nx)
}
## remove NA's
nbg <- is.na(x)
x <- x[!nbg]
if(weighted) weights <- weights[!nbg]
n <- length(x)
if (n < 1)
stop("'x' must have 1 or more non-missing values")
## sort in increasing order of x value
if(!weighted) {
x <- sort(x)
w <- rep(1, n)
} else {
ox <- fave.order(x)
x <- x[ox]
w <- weights[ox]
}
## find jump locations and match
rl <- rle(x)
vals <- rl$values
if(!weighted) {
wmatch <- rl$lengths
} else {
nv <- length(vals)
wmatch <- .C(SK_tabsumweight,
nx=as.integer(n),
x=as.double(x),
w=as.double(w),
nv=as.integer(nv),
v=as.double(vals),
z=as.double(numeric(nv)),
PACKAGE="spatstat.univar")$z
}
## cumulative weight in each interval
cumwt <- cumsum(wmatch)
totwt <- sum(wmatch)
## rescale ?
if(normalise) {
cumwt <- cumwt/totwt
totwt <- 1
} else if(adjust != 1) {
cumwt <- adjust * cumwt
totwt <- adjust * totwt
}
## make function
rval <- approxfun(vals, cumwt,
method = "constant", yleft = 0, yright = totwt,
f = 0, ties = "ordered")
class(rval) <- c("ewcdf",
if(normalise) "ecdf" else NULL,
"stepfun", class(rval))
assign("w", w, envir=environment(rval))
attr(rval, "call") <- sys.call()
return(rval)
}
# Hacked from stats:::print.ecdf
print.ewcdf <- function (x, digits = getOption("digits") - 2L, ...) {
cat("Weighted empirical CDF \nCall: ")
print(attr(x, "call"), ...)
env <- environment(x)
xx <- get("x", envir=env)
ww <- get("w", envir=env)
n <- length(xx)
i1 <- 1L:min(3L, n)
i2 <- if (n >= 4L) max(4L, n - 1L):n else integer()
numform <- function(x) paste(formatC(x, digits = digits), collapse = ", ")
cat(" x[1:", n, "] = ", numform(xx[i1]), if (n > 3L)
", ", if (n > 5L)
" ..., ", numform(xx[i2]), "\n", sep = "")
cat(" weights[1:", n, "] = ", numform(ww[i1]), if (n > 3L)
", ", if (n > 5L)
" ..., ", numform(ww[i2]), "\n", sep = "")
invisible(x)
}
quantile.ewcdf <- function(x, probs=seq(0,1,0.25), names=TRUE, ...,
normalise=TRUE, type=1) {
trap.extra.arguments(..., .Context="quantile.ewcdf")
if(is.na(m <- match(type, c(1,2,4))))
stop("Argument 'type' must equal 1, 2 or 4", call.=FALSE)
type <- as.character(c(1,2,4)[m])
env <- environment(x)
xx <- get("x", envir=env)
n <- length(xx)
Fxx <- get("y", envir=env)
maxFxx <- max(Fxx)
eps <- 100 * .Machine$double.eps
if(normalise) {
Fxx <- Fxx/maxFxx
maxp <- 1
} else {
maxp <- maxFxx
}
if(any((p.ok <- !is.na(probs)) &
(probs/maxp < -eps | probs/maxp > 1 + eps))) {
allowed <- if(normalise) "[0,1]" else
paste("permitted range", prange(c(0, maxp)))
stop(paste("'probs' outside", allowed), call.=FALSE)
}
if (na.p <- any(!p.ok)) {
o.pr <- probs
probs <- probs[p.ok]
probs <- pmax(0, pmin(maxp, probs))
}
np <- length(probs)
if (n > 0 && np > 0) {
qs <- numeric(np)
switch(type,
"1" = {
## right-continuous inverse
for(k in 1:np) qs[k] <- xx[min(which(Fxx >= probs[k]))]
},
"2" = {
## average of left and right continuous
for(k in 1:np) {
pk <- probs[k]
ik <- min(which(Fxx >= probs[k]))
qs[k] <- if(Fxx[ik] > pk) (xx[ik] + xx[ik-1L])/2 else xx[ik]
}
},
"4" = {
## linear interpolation
qs[] <- approx(Fxx, xx, xout=probs, method="linear",
ties="ordered", rule=2)$y
})
} else {
qs <- rep(NA_real_, np)
}
if (names && np > 0L) {
dig <- max(2L, getOption("digits"))
if(normalise) {
probnames <-
if(np < 100) formatC(100 * probs, format="fg", width=1, digits=dig) else
format(100 * probs, trim = TRUE, digits = dig)
names(qs) <- paste0(probnames, "%")
} else {
names(qs) <-
if(np < 100) formatC(probs, format="fg", width=1, digits=dig) else
format(probs, trim=TRUE, digits=dig)
}
}
if (na.p) {
o.pr[p.ok] <- qs
names(o.pr) <- rep("NA", length(o.pr))
names(o.pr)[p.ok] <- names(qs)
o.pr
} else qs
}
mean.ecdf <- mean.ewcdf <- function(x, trim=0, ...) {
Fun <- x
xx <- get("x", envir=environment(Fun))
Fx <- get("y", envir=environment(Fun))
dF <- diff(c(0, Fx))
if(trim > 0) {
lim <- quantile(Fun, c(trim, 1-trim))
ok <- (xx >= lim[1L]) & (xx <= lim[2L])
if(!any(ok)) stop("No data remain after trimming", call.=FALSE)
xx <- xx[ok]
Fx <- Fx[ok]
}
sum(xx * dF)/sum(dF)
}
knots.ecdf <- knots.ewcdf <- function(Fn, ...) {
eval(expression(x), envir=environment(Fn))
}
quantilefun <- function(x, ...) {
UseMethod("quantilefun")
}
quantilefun.ewcdf <- quantilefun.ecdf <- quantilefun.interpolatedCDF <- function(x, ..., type=1) {
## inverse CDF
trap.extra.arguments(..., .Context="quantilefun")
if(is.na(m <- match(type, c(1,2,4))))
stop("Argument 'type' must equal 1, 2 or 4", call.=FALSE)
type <- c(1,2,4)[m]
env <- environment(x)
qq <- get("x", envir = env)
pp <- get("y", envir = env)
ok <- !duplicated(pp)
qq <- qq[ok]
pp <- pp[ok]
if (length(pp) == 1) {
pp <- c(0, pp)
qq <- rep(qq, 2)
}
#'
n <- length(pp)
result <- switch(as.character(type),
"1" = {
approxfun(pp, qq, method="constant", f=1,
ties="ordered", rule=2)
},
"2" = {
function(p) {
j <- approx(pp, 1:n, xout=p, method="constant", f=0,
ties="ordered", rule=2)$y
j <- as.integer(j)
g <- p - pp[j]
jplus1 <- pmin(j+1, n)
z <- ifelse(g == 0, (qq[j]+qq[jplus1])/2, qq[jplus1])
return(z)
}
},
"4" = approxfun(pp, qq, method="linear",
ties="ordered", rule=2))
return(result)
}
spatstat.univar/R/access.R 0000644 0001762 0000144 00000002474 14710660075 015222 0 ustar ligges users #'
#' access to internal functions, for debugging
#'
#' kermom() should agree with kernel.moment()
#'
#' Copyright (c) 2023 Adrian Baddeley, Tilman Davies and Martin Hazelton
#' GNU Public Licence (>= 2.0)
kermom <- function(m, r, kernel="gaussian", mean = 0,
sd=1/kernel.factor(kernel)) {
kernel <- match.kernel(kernel)
kerncode <- switch(kernel,
gaussian=1,
rectangular=2,
triangular=3,
epanechnikov=4,
biweight=5,
cosine=6,
optcosine=7,
0)
df <- data.frame(r=r, mean=mean, sd=sd)
nr <- nrow(df)
z <- .C(SK_kermom,
nx = as.integer(nr),
x = as.double(df$r),
mean = as.double(df$mean),
sd = as.double(df$sd),
m = as.integer(m),
kerncode = as.integer(kerncode),
y = as.double(numeric(nr)),
errcode = as.integer(integer(1)),
PACKAGE="spatstat.univar")
if(z$errcode != 0)
switch(z$errcode,
stop("Error in C: negative length"),
stop("Error in C: unrecognised kernel"),
stop("Error in C: value of m is not supported"),
stop(paste("Error in C: error code", z$errcode)))
return(z$y)
}
spatstat.univar/R/unnormdensity.R 0000644 0001762 0000144 00000015203 14632773657 016707 0 ustar ligges users #
# unnormdensity.R
#
# $Revision: 1.19 $ $Date: 2023/08/14 06:27:35 $
#
unnormdensity <- local({
unnormdensity <- function(x, ..., weights=NULL, defaults=list()) {
if(any(!nzchar(names(list(...)))))
stop("All arguments must be named (tag=value)")
envir.here <- sys.frame(sys.nframe())
## suppress annoying warnings in density.default
defaults <- resolve.defaults(defaults,
list(warnWbw=FALSE))
if(length(x) <= 1) {
## density.default does not handle this
out <- do.call(fewdatacase,
resolve.defaults(
list(x=x, ..., weights=weights),
defaults))
} else if(is.null(weights)) {
## all weights are 1 (not 1/n)
out <- do.call.matched(density.default,
c(list(x=quote(x), ...), defaults),
envir=envir.here)
out$y <- length(x) * out$y
} else if(length(weights) == 1) {
## all weights are equal
out <- do.call.matched(density.default,
c(list(x=quote(x), ...), defaults),
envir=envir.here)
out$y <- weights[1] * length(x) * out$y
} else if(length(weights) != length(x)) {
stop("'x' and 'weights' have unequal length")
} else {
weightrange <- range(weights)
if(all(weightrange == 0)) {
## result is zero
out <- do.call.matched(density.default,
c(list(x=quote(x), ...), defaults),
envir=envir.here)
out$y <- 0 * out$y
} else if(all(weightrange >= 0)) {
## all masses are nonnegative, some are positive
out <- do.call.matched(density.default,
c(list(x=quote(x),
weights=quote(weights),
subdensity=TRUE,
...),
defaults),
envir=envir.here)
} else if(all(weightrange <= 0)) {
## all masses are nonpositive, some are negative
w <- (- weights)
out <- do.call.matched(density.default,
c(list(x=quote(x),
weights=quote(w),
subdensity=TRUE,
...),
defaults),
envir=envir.here)
out$y <- (- out$y)
} else {
## mixture of positive and negative masses
w <- weights
wabs <- abs(w)
wpos <- pmax.int(0, w)
wneg <- - pmin.int(0, w)
## determine bandwidth value
bw <- list(...)$bw # could be NULL
if(is.numeric(bw)) {
## bandwidth is given, as a numeric value
## adjust by factor 'adjust'
adjust <- list(...)$adjust %orifnull% 1
bw <- bw * adjust
} else {
## compute bandwidth by applying a rule, using absolute masses
dabs <- do.call.matched(density.default,
c(list(x=quote(x),
weights=quote(wabs),
subdensity=TRUE,
...),
defaults),
envir=envir.here)
bw <- dabs$bw
}
## Bandwidth is now determined as a numeric value.
## Compute densities for positive and negative masses separately
outpos <- do.call.matched(density.default,
resolve.defaults(list(x=quote(x),
bw=bw,
adjust=1,
weights=quote(wpos),
subdensity=TRUE,
...),
defaults,
.StripNull=TRUE),
envir=envir.here)
outneg <- do.call.matched(density.default,
resolve.defaults(list(x=quote(x),
bw=bw,
adjust=1,
weights=quote(wneg),
subdensity=TRUE,
...),
defaults,
.StripNull=TRUE),
envir=envir.here)
## combine
out <- outpos
out$y <- outpos$y - outneg$y
}
}
out$call <- match.call()
return(out)
}
fewdatacase <- function(x, ...,
weights=NULL, kernel="gaussian",
bw=NULL,
from=NULL, to=NULL, n=512) {
nx <- length(x)
if(nx == 0) {
needed <- list(from=from, to=to, n=n)
} else if(nx == 1) {
needed <- list(bw=bw, from=from, to=to, n=n)
} else stop("Internal function 'fewdatacase' was invoked incorrectly")
if(any(absent <- sapply(needed, is.null))) {
nabsent <- sum(absent)
stop(paste(ngettext(nabsent, "Argument", "Arguments"),
commasep(sQuote(names(needed)[absent])),
ngettext(nabsent, "is", "are"),
"required in density.default when length(x) <= 1"),
call.=FALSE)
}
xx <- seq(from, to, length.out=n)
if(nx == 0) {
yy <- rep(0, n)
} else {
kernel <- match.kernel(kernel)
if(!is.numeric(bw)) {
## Bandwidth selection rules require >= 2 data values
## Use fallback
h <- (to-from)/3
bw <- h / kernel.factor(kernel)
}
yy <- (weights %orifnull% 1) * dkernel(xx, kernel=kernel, mean=x, sd=bw)
}
structure(list(x=xx, y=yy, bw=bw, n=n, call=match.call(),
data.name='x', has.na=FALSE),
class="density")
}
unnormdensity
})
integral.density <- function(f, domain=NULL, weight=NULL, ...) {
x <- f$x
y <- f$y
if(!is.null(domain)) {
check.range(domain)
retain <- inside.range(x, domain)
x <- x[retain]
y <- y[retain]
}
if(!is.null(weight)) {
stopifnot(is.function(weight))
y <- y * weight(x)
}
dx <- diff(x)
ybar <- (y[-1] + y[-length(y)])/2
sum(dx * ybar)
}
spatstat.univar/R/integral.R 0000644 0001762 0000144 00000000241 14632773657 015572 0 ustar ligges users #'
#' integral.R
#'
#' generic
#'
#' $Revision: 1.1 $ $Date: 2023/10/22 02:03:35 $
integral <- function(f, domain=NULL, ...) {
UseMethod("integral")
}
spatstat.univar/R/kernels.R 0000644 0001762 0000144 00000025033 14632773657 015436 0 ustar ligges users #
# kernels.R
#
# rXXX, dXXX, pXXX and qXXX for kernels
#
# $Revision: 1.24 $ $Date: 2023/10/20 01:27:47 $
#
match.kernel <- function(kernel) {
kernel.map <- c(Gaussian ="gaussian",
gaussian ="gaussian",
Normal ="gaussian",
normal ="gaussian",
rectangular ="rectangular",
triangular ="triangular",
Epanechnikov="epanechnikov",
epanechnikov="epanechnikov",
biweight ="biweight",
cosine ="cosine",
optcosine ="optcosine"
)
kernel <- match.arg(kernel, names(kernel.map))
ker <- kernel.map[kernel]
return(ker)
}
kernel.factor <- function(kernel="gaussian") {
# This function returns the factor c such that
# h = c * sigma
# where sigma is the standard deviation of the kernel, and
# h is the corresponding bandwidth parameter as conventionally defined.
# Conventionally h is defined as a scale factor
# relative to the `standard form' of the kernel, namely the
# form with support [-1,1], except in the Gaussian case where
# the standard form is N(0,1).
# Thus the standard form of the kernel (h=1) has standard deviation 1/c.
# The kernel with standard deviation 1 has support [-c,c]
# except for gaussian case.
kernel <- match.kernel(kernel)
switch(kernel,
gaussian = 1,
rectangular = sqrt(3),
triangular = sqrt(6),
epanechnikov = sqrt(5),
biweight = sqrt(7),
cosine = 1/sqrt(1/3 - 2/pi^2),
optcosine = 1/sqrt(1 - 8/pi^2))
}
rkernel <- function(n, kernel="gaussian", mean=0, sd=1) {
kernel <- match.kernel(kernel)
if(kernel == "gaussian")
return(rnorm(n, mean=mean, sd=sd))
# inverse cdf transformation
u <- runif(n)
qkernel(u, kernel, mean=mean, sd=sd)
}
dkernel <- function(x, kernel="gaussian", mean=0, sd=1) {
kernel <- match.kernel(kernel)
stopifnot(is.numeric(x))
stopifnot(is.numeric(sd) && length(sd) == 1 && sd > 0)
a <- sd * kernel.factor(kernel)
y <- abs(x-mean)/a
dens <-
switch(kernel,
gaussian = { dnorm(y) },
rectangular = { ifelse(y < 1, 1/2, 0) },
triangular = { ifelse(y < 1, (1 - y), 0) },
epanechnikov = { ifelse(y < 1, (3/4) * (1 - y^2), 0) },
biweight = { ifelse(y < 1, (15/16) * (1 - y^2)^2, 0) },
cosine = { ifelse(y < 1, (1 + cos(pi * y))/2, 0) },
optcosine = { ifelse(y < 1, (pi/4) * cos(pi * y/2), 0) }
)
dens/a
}
pkernel <- function(q, kernel="gaussian", mean=0, sd=1, lower.tail=TRUE){
kernel <- match.kernel(kernel)
stopifnot(is.numeric(q))
stopifnot(is.numeric(sd) && length(sd) == 1 && sd > 0)
a <- sd * kernel.factor(kernel)
y <- (q-mean)/a
switch(kernel,
gaussian = {
pnorm(y, lower.tail=lower.tail)
},
rectangular = {
punif(y, min=-1, max=1, lower.tail=lower.tail)
},
triangular = {
p <- ifelse(y < -1, 0, ifelse(y > 1, 1,
ifelse(y < 0, y + y^2/2 + 1/2,
y - y^2/2 + 1/2)))
if(lower.tail) p else (1 - p)
},
epanechnikov = {
p <- ifelse(y < -1, 0, ifelse(y > 1, 1,
(2 + 3 * y - y^3)/4))
if(lower.tail) p else (1 - p)
},
biweight = {
p <- ifelse(y < -1, 0, ifelse(y > 1, 1,
(15 * y - 10 * y^3 + 3 * y^5 + 8)/16))
if(lower.tail) p else (1 - p)
},
cosine = {
p <- ifelse(y < -1, 0, ifelse(y > 1, 1,
(y + sin(pi * y)/pi + 1)/2))
if(lower.tail) p else (1 - p)
},
optcosine = {
p <- ifelse(y < -1, 0, ifelse(y > 1, 1,
(sin(pi * y/2) + 1)/2))
if(lower.tail) p else (1 - p)
})
}
qkernel <- function(p, kernel="gaussian", mean=0, sd=1, lower.tail=TRUE) {
kernel <- match.kernel(kernel)
stopifnot(is.numeric(p))
stopifnot(is.numeric(sd) && length(sd) == 1 && sd > 0)
a <- sd * kernel.factor(kernel)
if(!lower.tail)
p <- 1 - p
y <-
switch(kernel,
gaussian = {
qnorm(p, lower.tail=lower.tail)
},
rectangular = {
qunif(p, min=-1, max=1, lower.tail=lower.tail)
},
triangular = {
ifelse(p < 1/2, sqrt(2 * p) - 1, 1 - sqrt(2 * (1-p)))
},
epanechnikov = {
# solve using `polyroot'
yy <- numeric(n <- length(p))
yy[p == 0] <- -1
yy[p == 1] <- 1
inside <- (p != 0) & (p != 1)
# coefficients of polynomial (2 + 3 y - y^3)/4
z <- c(2, 3, 0, -1)/4
for(i in seq(n)[inside]) {
sol <- polyroot(z - c(p[i], 0, 0, 0))
ok <- abs(Im(sol)) < 1e-6
realpart <- Re(sol)
ok <- ok & (abs(realpart) <= 1)
if(sum(ok) != 1)
stop(paste("Internal error:", sum(ok), "roots of polynomial"))
yy[i] <- realpart[ok]
}
yy
},
biweight = {
# solve using `polyroot'
yy <- numeric(n <- length(p))
yy[p == 0] <- -1
yy[p == 1] <- 1
inside <- (p != 0) & (p != 1)
# coefficients of polynomial (8 + 15 * y - 10 * y^3 + 3 * y^5)/16
z <- c(8, 15, 0, -10, 0, 3)/16
for(i in seq(n)[inside]) {
sol <- polyroot(z - c(p[i], 0, 0, 0, 0, 0))
ok <- abs(Im(sol)) < 1e-6
realpart <- Re(sol)
ok <- ok & (abs(realpart) <= 1)
if(sum(ok) != 1)
stop(paste("Internal error:", sum(ok), "roots of polynomial"))
yy[i] <- realpart[ok]
}
yy
},
cosine = {
# solve using `uniroot'
g <- function(y, pval) { (y + sin(pi * y)/pi + 1)/2 - pval }
yy <- numeric(n <- length(p))
yy[p == 0] <- -1
yy[p == 1] <- 1
inside <- (p != 0) & (p != 1)
for(i in seq(n)[inside])
yy[i] <- uniroot(g, c(-1,1), pval=p[i])$root
yy
},
optcosine = {
(2/pi) * asin(2 * p - 1)
})
return(mean + a * y)
}
#' integral of t^m k(t) dt from -Inf to r
#' where k(t) is the standard kernel with support [-1,1]
#' was: nukernel(r, m, kernel)
kernel.moment <- local({
kernel.moment <- function(m, r, kernel="gaussian",
mean=0, sd=1/kernel.factor(kernel)) {
ker <- match.kernel(kernel)
check.1.integer(m)
needs.rescaling <- !missing(mean) || !missing(sd)
halfwidth <- if(missing(sd)) 1 else (sd * kernel.factor(ker))
#' restrict to support
if(ker != "gaussian") {
r <- pmin(r, mean+halfwidth)
r <- pmax(r, mean-halfwidth)
}
if(!(m %in% c(0,1,2))) {
## use generic integration
neginf <- mean - if(ker == "gaussian") (10 * sd) else halfwidth
result <- numeric(length(r))
for(i in seq_along(r))
result[i] <- integralvalue(kintegrand,
lower=neginf, upper=r[i],
m=m, ker=ker, mean=mean, sd=sd)
return(result)
}
if(needs.rescaling) {
## convert to standard form and use analytic results
y <- (r - mean)/halfwidth
if(m == 0)
return(kernel.moment(0, y, kernel=ker))
else if(m == 1)
return(mean * kernel.moment(0, y, kernel=ker)
+ halfwidth * kernel.moment(1, y, kernel=ker))
else
return(mean^2 * kernel.moment(0, y, kernel=ker)
+ 2 * mean * halfwidth * kernel.moment(1, y, kernel=ker)
+ halfwidth^2 * kernel.moment(2, y, kernel=ker))
}
## kernel is now in standard form with support [-1, 1] unless Gaussian
switch(ker,
gaussian={
if(m == 0) return(pnorm(r)) else
if(m == 1) return(-dnorm(r)) else
return(ifelse(r == -Inf, 0,
ifelse(r == Inf, 1,
pnorm(r) - r * dnorm(r))))
},
rectangular = {
if(m == 0) return((r + 1)/2) else
if(m == 1) return((r^2 - 1)/4) else
return((r^3 + 1)/6)
},
triangular={
m1 <- m+1
m2 <- m+2
const <- ((-1)^m1)/m1 + ((-1)^m2)/m2
answer <- (r^m1)/m1 + ifelse(r < 0, 1, -1) * (r^m2)/m2 - const
return(answer)
},
epanechnikov = {
if(m == 0)
return((2 + 3*r - r^3)/4)
else if(m == 1)
return((-3 + 6*r^2 - 3*r^4)/16)
else
return(( 2 + 5*r^3 - 3* r^5)/20)
},
biweight = {
if(m == 0)
return((3*r^5 - 10*r^3 + 15*r + 8)/16)
else if(m == 1)
return((5*r^6 - 15*r^4 + 15*r^2 -5)/32)
else
return((15*r^7 - 42*r^5 + 35*r^3 + 8)/112)
},
cosine={
pr <- pi * r
if(m == 0)
return((r + sin(pr)/pi + 1)/2)
else if(m == 1)
return((r^2-1)/4 + (pr*sin(pr) + cos(pr) + 1)/(2*pi^2))
else
return((r^3 + 1)/6 +
((pr^2-2) * sin(pr) + 2*pr*cos(pr) - 2*pi)/(2*pi^3))
},
optcosine={
p2r <- (pi/2) * r
if(m == 0)
return((sin(p2r) + 1)/2)
else if(m == 1)
return((p2r * sin(p2r) + cos(p2r) - pi/2)/pi)
else
return((2/pi^2) *
((p2r^2-2)*sin(p2r) + 2*p2r*cos(p2r) + (pi/2)^2-2))
}
)
}
integralvalue <- function(...) integrate(...)$value
kintegrand <- function(x, m, ker, mean, sd) {
(x^m) * dkernel(x=x, kernel=ker, mean=mean, sd=sd)
}
kernel.moment
})
kernel.squint <- function(kernel="gaussian", bw=1) {
kernel <- match.kernel(kernel)
check.1.real(bw)
RK <- switch(kernel,
gaussian = 1/(2 * sqrt(pi)),
rectangular = sqrt(3)/6,
triangular = sqrt(6)/9,
epanechnikov = 3/(5 * sqrt(5)),
biweight = 5 * sqrt(7)/49,
cosine = (3/4) * sqrt(1/3 - 2/pi^2),
optcosine = sqrt(1 - 8/pi^2) * pi^2/16)
return(RK/bw)
}
spatstat.univar/R/First.R 0000644 0001762 0000144 00000000626 14632773657 015063 0 ustar ligges users ## spatstat.univar/R/First.R
.onLoad <- function(...) {
# reset.spatstat.options()
}
.onAttach <- function(libname, pkgname) {
vs <- read.dcf(file=system.file("DESCRIPTION", package="spatstat.univar"),
fields="Version")
vs <- as.character(vs)
# putSpatstatVariable("SpatstatUnivarVersion", vs)
packageStartupMessage(paste("spatstat.univar", vs))
return(invisible(NULL))
}
spatstat.univar/R/bw.pow.R 0000644 0001762 0000144 00000001206 14710326734 015166 0 ustar ligges users #'
#' bw.pow.R
#'
#' Adaptive bandwidths proportional to x^POW
#'
#' Copyright (c) 2021-2023 Tilman Davies, Martin Hazelton and Adrian Baddeley
#' GNU Public Licence (>= 2.0)
#'
bw.pow <- function(X, h0, POW=0.75, trim=5, ...){
check.nvector(X)
if(missing(h0) || is.null(h0)) {
h0 <- bw.nrd0(X)
} else {
check.1.real(h0)
stopifnot(h0 > 0)
}
check.1.real(trim)
stopifnot(trim > 0)
# POW <- 0.75
#' geometric mean of distances for scaling purposes
gamma <- exp(mean(log(X^POW)))
#' compute variable bandwidths to be proportional to distance
bw <- h0 * pmin(X^POW/gamma,trim)
return(bw)
}
spatstat.univar/R/kmrs.R 0000644 0001762 0000144 00000011067 14632773657 014751 0 ustar ligges users #
# kmrs.R
#
# S code for Kaplan-Meier, Reduced Sample and Hanisch
# estimates of a distribution function
# from _histograms_ of censored data.
#
# kaplan.meier()
# reduced.sample()
# km.rs()
#
# $Revision: 3.30 $ $Date: 2023/11/04 04:46:07 $
#
# The functions in this file produce vectors `km' and `rs'
# where km[k] and rs[k] are estimates of F(breaks[k+1]),
# i.e. an estimate of the c.d.f. at the RIGHT endpoint of the interval.
#
"kaplan.meier" <-
function(obs, nco, breaks, upperobs=0) {
# obs: histogram of all observations : min(T_i,C_i)
# nco: histogram of noncensored observations : T_i such that T_i <= C_i
# breaks: breakpoints (vector or 'breakpts' object, see breaks.S)
# upperobs: number of observations beyond rightmost breakpoint
#
breaks <- as.breakpts(breaks)
n <- length(obs)
if(n != length(nco))
stop("lengths of histograms do not match")
check.hist.lengths(nco, breaks)
#
#
# reverse cumulative histogram of observations
d <- revcumsum(obs) + upperobs
#
# product integrand
s <- ifelseXB(d > 0, 1 - nco/d, 1)
#
km <- 1 - cumprod(s)
# km has length n; km[i] is an estimate of F(r) for r=breaks[i+1]
#
widths <- diff(breaks$val)
lambda <- numeric(n)
pos <- (s > 0)
lambda[pos] <- -log(s[pos])/widths[pos]
# lambda has length n; lambda[i] is an estimate of
# the average of \lambda(r) over the interval (breaks[i],breaks[i+1]).
#
return(list(km=km, lambda=lambda))
}
"reduced.sample" <-
function(nco, cen, ncc, show=FALSE, uppercen=0)
# nco: histogram of noncensored observations: T_i such that T_i <= C_i
# cen: histogram of all censoring times: C_i
# ncc: histogram of censoring times for noncensored obs:
# C_i such that T_i <= C_i
#
# Then nco[k] = #{i: T_i <= C_i, T_i \in I_k}
# cen[k] = #{i: C_i \in I_k}
# ncc[k] = #{i: T_i <= C_i, C_i \in I_k}.
#
# The intervals I_k must span an interval [0,R] beginning at 0.
# If this interval did not include all censoring times,
# then `uppercen' must be the number of censoring times
# that were not counted in 'cen'.
{
n <- length(nco)
if(n != length(cen) || n != length(ncc))
stop("histogram lengths do not match")
#
# denominator: reverse cumulative histogram of censoring times
# denom(r) = #{i : C_i >= r}
# We compute
# cc[k] = #{i: C_i > breaks[k]}
# except that > becomes >= for k=0.
#
cc <- revcumsum(cen) + uppercen
#
#
# numerator
# #{i: T_i <= r <= C_i }
# = #{i: T_i <= r, T_i <= C_i} - #{i: C_i < r, T_i <= C_i}
# We compute
# u[k] = #{i: T_i <= C_i, T_i <= breaks[k+1]}
# - #{i: T_i <= C_i, C_i <= breaks[k]}
# = #{i: T_i <= C_i, C_i > breaks[k], T_i <= breaks[k+1]}
# this ensures that numerator and denominator are
# comparable, u[k] <= cc[k] always.
#
u <- cumsum(nco) - c(0,cumsum(ncc)[1:(n-1)])
rs <- u/cc
#
# Hence rs[k] = u[k]/cc[k] is an estimator of F(r)
# for r = breaks[k+1], i.e. for the right hand end of the interval.
#
if(!show)
return(rs)
else
return(list(rs=rs, numerator=u, denominator=cc))
}
"km.rs" <-
function(o, cc, d, breaks) {
# o: censored lifetimes min(T_i,C_i)
# cc: censoring times C_i
# d: censoring indicators 1(T_i <= C_i)
# breaks: histogram breakpoints (vector or 'breakpts' object)
#
breaks <- as.breakpts(breaks)
bval <- breaks$val
# compile histograms (breakpoints may not span data)
obs <- whist( o, breaks=bval)
nco <- whist( o[d], breaks=bval)
cen <- whist( cc, breaks=bval)
ncc <- whist( cc[d], breaks=bval)
# number of observations exceeding largest breakpoint
upperobs <- attr(obs, "high")
uppercen <- attr(cen, "high")
# go
km <- kaplan.meier(obs, nco, breaks, upperobs=upperobs)
rs <- reduced.sample(nco, cen, ncc, uppercen=uppercen)
#
return(list(rs=rs, km=km$km, hazard=km$lambda,
r=breaks$r, breaks=bval))
}
"km.rs.opt" <-
function(o, cc, d, breaks, KM=TRUE, RS=TRUE) {
# o: censored lifetimes min(T_i,C_i)
# cc: censoring times C_i
# d: censoring indicators 1(T_i <= C_i)
# breaks: histogram breakpoints (vector or 'breakpts' object)
#
breaks <- as.breakpts(breaks)
bval <- breaks$val
out <- list(r=breaks$r, breaks=bval)
if(KM || RS)
nco <- whist( o[d], breaks=bval)
if(KM) {
obs <- whist( o, breaks=bval)
upperobs <- attr(obs, "high")
km <- kaplan.meier(obs, nco, breaks, upperobs=upperobs)
out <- append(list(km=km$km, hazard=km$lambda), out)
}
if(RS) {
cen <- whist( cc, breaks=bval)
ncc <- whist( cc[d], breaks=bval)
uppercen <- attr(cen, "high")
rs <- reduced.sample(nco, cen, ncc, uppercen=uppercen)
out <- append(list(rs=rs), out)
}
return(out)
}
spatstat.univar/R/quantiledensity.R 0000644 0001762 0000144 00000005250 14632773657 017214 0 ustar ligges users #'
#' quantiledensity.R
#'
#' quantile method for class 'density'
#'
#' Also a CDF from a 'density'
#'
#' $Revision: 1.4 $ $Date: 2023/09/18 06:34:53 $
quantile.density <- local({
quantile.density <- function(x, probs = seq(0, 1, 0.25), names = TRUE, ...,
warn=TRUE) {
stopifnot(inherits(x, "density"))
#' check whether density estimate was restricted to an interval
if(warn && is.call(cl <- x$call) && any(c("from", "to") %in% names(cl)))
warning(paste("Density was normalised within the computed range",
"of x values", prange(c(cl$from, cl$to))),
call.=FALSE)
#' validate probs
eps <- 100 * .Machine$double.eps
if(any((p.ok <- !is.na(probs)) & (probs < -eps | probs > 1 + eps)))
stop("'probs' outside [0,1]")
if (na.p <- any(!p.ok)) {
o.pr <- probs
probs <- probs[p.ok]
probs <- pmax(0, pmin(1, probs))
}
np <- length(probs)
qs <- rep(NA_real_, np)
if (np > 0) {
#' extract density values
xx <- x$x
yy <- x$y
nn <- length(xx)
#' integrate, normalise
Fx <- cumsum(yy * c(0, diff(xx)))
Fx <- Fx/Fx[nn]
#' quantile
for(j in 1:np) {
ii <- min(which(Fx >= probs[j]))
if(!is.na(ii) && ii >= 1 && ii <= nn)
qs[j] <- xx[ii]
}
if (names && np > 0L) {
names(qs) <- format_perc(probs)
}
}
if (na.p) {
o.pr[p.ok] <- qs
if(names) {
names(o.pr) <- rep("", length(o.pr))
names(o.pr)[p.ok] <- names(qs)
}
return(o.pr)
} else return(qs)
}
format_perc <- function (x, digits = max(2L, getOption("digits")),
probability = TRUE, use.fC = length(x) < 100, ...) {
if (length(x)) {
if (probability) x <- 100 * x
paste0(if (use.fC)
formatC(x, format = "fg", width = 1, digits = digits)
else format(x, trim = TRUE, digits = digits, ...), "%")
}
else character(0)
}
quantile.density
})
CDF <- function(f, ...) {
UseMethod("CDF")
}
CDF.density <- function(f, ..., warn=TRUE) {
stopifnot(inherits(f, "density"))
#' check whether density estimate was restricted to an interval
if(warn && is.call(cl <- f$call) && any(c("from", "to") %in% names(cl)))
warning(paste("Density was normalised within the computed range",
"of x values", prange(c(cl$from, cl$to))),
call.=FALSE)
#' integrate
xx <- f$x
yy <- f$y
nn <- length(xx)
Fx <- cumsum(yy * c(0, diff(xx)))
#' normalise
Fx <- Fx/Fx[nn]
#'
FF <- approxfun(xx, Fx, method="linear", rule=2)
class(FF) <- c("interpolatedCDF", class(FF))
return(FF)
}
spatstat.univar/R/densityBC.R 0000644 0001762 0000144 00000026374 14710331457 015651 0 ustar ligges users #'
#'
#' densityBC.R
#'
#' Kernel smoothing with boundary correction at zero
#'
#' Copyright (c) 2024 Adrian Baddeley, Tilman Davies and Martin Hazelton
#' GNU Public Licence (>= 2.0)
#'
densityBC <- function(x, kernel="epanechnikov", bw=NULL,
...,
h=NULL,
adjust=1,
weights = rep(1, length(x))/length(x),
from=0, to=max(x), n=256,
zerocor=c("none", "weighted", "convolution",
"reflection", "bdrykern", "JonesFoster"),
fast=FALSE, internal=list()) {
xname <- short.deparse(substitute(x))
trap.extra.arguments(..., .Context="In densityBC()")
zerocor <- match.arg(zerocor)
ker <- match.kernel(kernel)
## internal option to suppress construction of $call
thecall <- if(isFALSE(internal$addcall)) NULL else match.call()
DEBUG <- isTRUE(internal$debug)
if(DEBUG) {
splat("\tdensityBC,", zerocor, ", h =", format(h), ", bw =", format(bw))
splat("\t\trange(x) = ", prange(range(x)))
started <- proc.time()
}
## ........... validate arguments ..............................
x <- as.vector(x)
stopifnot(is.numeric(x))
nx <- length(x)
stopifnot(is.numeric(weights))
if(length(weights) == 1) {
weights <- rep.int(weights, length(x))
} else stopifnot(length(weights) == length(x))
if(!missing(adjust)) {
check.1.real(adjust)
stopifnot(adjust > 0)
}
if(is.null(from)) from <- min(0, x)
if(is.null(to)) to <- max(0, x)
stopifnot(is.numeric(from) && length(from) == 1)
stopifnot(is.numeric(to) && length(to) == 1)
stopifnot(from < to)
stopifnot(is.numeric(n) && length(n) == 1)
stopifnot(n >= 2)
nr <- as.integer(n)
## ............... determine bandwidth ...........................
if(!is.null(h) && !is.null(bw))
stop("Only one of the arguments h and bw should be given")
if(is.null(h) && is.null(bw))
bw <- "nrd0"
if(!is.null(h)) {
if(is.character(h)) {
bw <- h
h <- NULL
} else check.bandwidth(h, "the user-supplied bandwidth 'h'")
}
if(!is.null(bw)) {
if(is.function(bw)) {
## bandwidth selection function
bw <- bw(x)
check.bandwidth(bw, "the bandwidth returned by bw(x)")
} else if(is.character(bw)) {
## bandwidth selection rule -- copied from density.default
if (nx < 2)
stop("need at least 2 points to select a bandwidth automatically")
bwdescrip <- paste("the bandwidth returned by rule", sQuote(bw))
bw <- switch(tolower(bw),
nrd0 = bw.nrd0(x),
nrd = bw.nrd(x),
ucv = bw.ucv(x),
bcv = bw.bcv(x),
sj = ,
'sj-ste' = bw.SJ(x, method = "ste"),
'sj-dpi' = bw.SJ(x, method = "dpi"),
stop(paste("unknown bandwidth rule", sQuote(bw)),
call.=FALSE))
check.bandwidth(bw, bwdescrip)
} else check.bandwidth(bw, "the user-supplied bandwidth 'bw'")
}
## if bw given, determine h (or vice versa)
cker <- kernel.factor(ker)
if(!is.null(bw)) {
h <- bw * cker
} else {
bw <- h/cker
}
## finally, adjust to actual values
h <- h * adjust
bw <- bw * adjust
## .............. initialise function table ......................
r <- seq(from, to, length.out=nr)
if(nx == 0) {
f <- rep(0, nr)
result <- list(x=r, y=f, bw=bw,
n=nr, call=thecall, data.name=xname, has.na=FALSE)
class(result) <- c("density", class(result))
return(result)
}
## ........... Jones-Foster estimate --- combination of two methods -----
if(zerocor == "JonesFoster") {
estconv <- densityBC(x, kernel=kernel, bw=bw, weights = weights,
from=from, to=to, n=n,
internal=list(addcall=FALSE),
zerocor="convolution")
estbdry <- densityBC(x, kernel=kernel, bw=bw, weights = weights,
from=from, to=to, n=n,
internal=list(addcall=FALSE),
zerocor="bdrykern")
result <- estconv
ecy <- estconv$y
eby <- estbdry$y
result$y <- ifelse(ecy <= 0, 0, ecy * exp(eby/ecy - 1))
result$call <- thecall
result$data.name <- xname
if(DEBUG) {
elapsed <- proc.time() - started
splat("\tdensityBC returned", paren(zerocor), "time taken",
elapsed[[3]], "sec")
}
return(result)
}
## ......... start processing x ..................................
## divide by halfwidth; henceforth the kernel has unit halfwidth
xscal <- x/h
rscal <- r/h
## ......... rejig the data to implement boundary correction at r = 0 .....
if(zerocor != "none") {
if(any(x < 0))
stop("negative x values are illegal when boundary correction selected")
## threshold is halfwidth of support of kernel
thresh <- if(ker == "gaussian") 3 else 1
if(zerocor=="weighted") {
# identify x[i] whose kernels need renormalising
x.is.small <- (xscal <= thresh)
# divide weights[i] by right tail of kernel
if(any(x.is.small)) {
mass <- pkernel(-xscal[x.is.small], ker, sd=1/cker, lower.tail=FALSE)
weights[x.is.small] <- ifelse(weights[x.is.small] <= 0, 0,
weights[x.is.small] / mass)
}
}
if(zerocor == "reflection") {
## reflect input data about 0
xscal <- c(xscal, -xscal)
weights <- rep.int(weights, 2)
nx <- length(xscal)
}
if(zerocor == "bdrykern" && fast) {
## split data according to whether boundary kernel is operative
## This occurs if abs(r-x) < thresh and abs(r-0) < thresh
## so can only be excluded when x > 2 * thresh
x.is.large <- (xscal > 2 * thresh)
xlarge <- xscal[x.is.large]
wlarge <- weights[x.is.large]
x.is.small <- ! x.is.large
xsmall <- xscal[x.is.small]
wsmall <- weights[x.is.small]
}
}
## ............. compute density estimate ...................................
ffast <- fslow <- 0
if(fast) {
## use FFT for some or all of the calculation
if(zerocor != "bdrykern") {
d <- unnormdensity(xscal, weights=weights,
from=rscal[1], to=rscal[nr], n=nr,
kernel=kernel, bw=1/cker)
} else {
d <- unnormdensity(xlarge, weights=wlarge,
from=rscal[1], to=rscal[nr], n=nr,
kernel=kernel, bw=1/cker)
}
ffast <- d$y
}
if(!fast || zerocor == "bdrykern") {
## use the bespoke C code
kerncode <- switch(ker,
gaussian=1,
rectangular=2,
triangular=3,
epanechnikov=4,
biweight=5,
cosine=6,
optcosine=7,
0)
if(zerocor != "bdrykern") {
## standard fixed bandwidth kernel estimate with appropriately rigged data
res <- .C(SK_fcolonel,
kerncode=as.integer(kerncode),
nx = as.integer(nx),
x = as.double(xscal),
w = as.double(weights),
nr = as.integer(nr),
r = as.double(rscal),
f = as.double(numeric(nr)),
errcode = as.integer(0),
PACKAGE="spatstat.univar")
fslow <- res$f
if(DEBUG) {
## Try older, slightly slower implementation
res2 <- .C(SK_colonel,
kerncode=as.integer(kerncode),
nx = as.integer(nx),
x = as.double(xscal),
w = as.double(weights),
nr = as.integer(nr),
r = as.double(rscal),
f = as.double(numeric(nr)),
errcode = as.integer(0),
PACKAGE="spatstat.univar")
fslow2 <- res2$f
splat("\tCalling C functions 'colonel' and 'fcolonel';")
splat("\t\tdiscrepancy range", prange(range(fslow - fslow2)))
}
} else {
## boundary kernel
nu0 <- kernel.moment(0, rscal, ker)
nu1 <- kernel.moment(1, rscal, ker)
nu2 <- kernel.moment(2, rscal, ker)
## safety check
if(length(nu0) != nr || length(nu1) != nr || length(nu2) != nr)
stop("internal error: kernel.moment did not yield result of correct length")
##
if(fast) {
## most data already processed. Only need to handle data close to 0.
xx <- xsmall
ww <- wsmall
nn <- length(xsmall)
} else {
## handle all data
xx <- xscal
ww <- weights
nn <- nx
}
## go
res <- .C(SK_fbcolonel,
kerncode=as.integer(kerncode),
nx = as.integer(nn),
x = as.double(xx),
w = as.double(ww),
nr = as.integer(nr),
r = as.double(rscal),
nu0 = as.double(nu0),
nu1 = as.double(nu1),
nu2 = as.double(nu2),
a = as.double(numeric(nr)),
b = as.double(numeric(nr)),
f = as.double(numeric(nr)),
errcode = as.integer(0),
PACKAGE="spatstat.univar")
fslow <- res$f
if(DEBUG) {
## Try older, slightly slower implementation
res2 <- .C(SK_bcolonel,
kerncode=as.integer(kerncode),
nx = as.integer(nn),
x = as.double(xx),
w = as.double(ww),
nr = as.integer(nr),
r = as.double(rscal),
nu0 = as.double(nu0),
nu1 = as.double(nu1),
nu2 = as.double(nu2),
a = as.double(numeric(nr)),
b = as.double(numeric(nr)),
f = as.double(numeric(nr)),
errcode = as.integer(0),
PACKAGE="spatstat.univar")
fslow2 <- res2$f
splat("\tCalling C functions 'bcolonel' and 'fbcolonel';")
splat("\t\tdiscrepancy range", prange(range(fslow - fslow2)))
}
}
## check for errors
if(res$errcode != 0) {
## error codes are defined in src/interfacecodes.h
whinge <- switch(res$errcode,
"illegal length of vector",
"unrecognised kernel",
"unknown error code")
stop(paste("Internal error in C function call:", whinge))
}
}
## combine contributions
f <- ffast + fslow
## ...... post-process -------------------------------
## deal with effect of rescaling
f <- f/h
## correct density estimates
if(zerocor == "convolution") {
r.is.small <- (rscal <= thresh)
if(any(r.is.small)) {
mass <- pkernel(-rscal[r.is.small], ker, sd=1/cker, lower.tail=FALSE)
f[r.is.small] <- ifelse(f[r.is.small] <= 0, 0,
f[r.is.small] / mass)
}
}
## wrap up
result <- list(x=r, y=f, bw=bw, n=nr,
call=thecall, data.name=xname, has.na=FALSE)
class(result) <- c("density", class(result))
if(DEBUG) {
elapsed <- proc.time() - started
splat("\tdensityBC returned", paren(zerocor), "time taken",
elapsed[[3]], "sec")
}
return(result)
}
spatstat.univar/R/uniquemap.R 0000644 0001762 0000144 00000006475 14636753555 016007 0 ustar ligges users #'
#' uniquemap.R
#'
#' Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2019
#' Licence: GNU Public Licence >= 2
#'
#' $Revision: 1.20 $ $Date: 2024/06/26 08:50:53 $
uniquemap <- function(x) { UseMethod("uniquemap") }
uniquemap.default <- function(x) {
result <- seqn <- seq_along(x)
if(length(x) <= 1) return(result)
if(is.atomic(x) && (is.factor(x) || (is.vector(x) && is.numeric(x)))) {
if(is.factor(x)) x <- as.integer(x)
o <- order(x, seqn)
isfirst <- c(TRUE, (diff(x[o]) != 0))
omap <- cumsum(isfirst)
result <- seqn
result[o] <- o[isfirst][omap]
return(result)
}
dup <- duplicated(x)
ux <- x[!dup]
mapdup <- match(x[dup], ux)
result[dup] <- which(!dup)[mapdup]
return(result)
}
uniquemap.matrix <- function(x) {
n <- nrow(x)
result <- seqn <- seq_len(n)
if(n <= 1)
return(result)
#' faster algorithms for special cases
nc <- ncol(x)
if(nc == 1L) return(uniquemap(x[,1]))
if(is.numeric(x)) {
if(nc == 2L) {
oo <- order(x[,1], x[,2], seqn)
xx <- x[oo, , drop=FALSE]
isfirst <- c(TRUE, (diff(xx[,1]) != 0) | (diff(xx[,2]) != 0))
} else {
## y <- asplit(x, 2) would require R 3.6.0
y <- split(as.vector(x), factor(as.vector(col(x)), levels=1:nc))
oo <- do.call(order, append(unname(y), list(seqn)))
xx <- x[oo, , drop=FALSE]
isfirst <- c(TRUE, matrowany(apply(xx, 2, diff) != 0))
}
uniqueids <- seqn[oo][isfirst]
lastunique <- cumsum(isfirst)
result[oo] <- uniqueids[lastunique]
return(result)
}
#' non-numeric matrix e.g. character
if(!anyDuplicated(x))
return(result)
dup <- duplicated(x)
uni <- which(!dup)
for(j in which(dup)) {
for(i in uni[uni < j]) {
if(IdenticalRowPair(i, j, x)) {
result[j] <- i
break
}
}
}
return(result)
}
uniquemap.data.frame <- function(x) {
n <- nrow(x)
result <- seqn <- seq_len(n)
if(n <= 1)
return(result)
#' faster algorithms for special cases
nc <- ncol(x)
if(nc == 1L) return(uniquemap(x[,1]))
if(all(sapply(x, is.numeric))) {
if(nc == 2L) {
oo <- order(x[,1], x[,2], seqn)
xx <- x[oo, , drop=FALSE]
isfirst <- c(TRUE, (diff(xx[,1]) != 0) | (diff(xx[,2]) != 0))
} else {
oo <- do.call(order, append(unname(as.list(x)), list(seqn)))
xx <- x[oo, , drop=FALSE]
isfirst <- c(TRUE, matrowany(apply(xx, 2, diff) != 0))
}
uniqueids <- seqn[oo][isfirst]
lastunique <- cumsum(isfirst)
result[oo] <- uniqueids[lastunique]
return(result)
}
#' general case
if(!anyDuplicated(x))
return(result)
dup <- duplicated(x)
uni <- which(!dup)
for(j in which(dup)) {
for(i in uni[uni < j]) {
if(IdenticalRowPair(i, j, x)) {
result[j] <- i
break
}
}
}
return(result)
}
## utility to check whether two rows are identical
IdenticalRowPair <- function(i,j, a, b=a) {
#' i and j are row indices (single integers)
ai <- a[i,]
bj <- b[j,]
row.names(ai) <- row.names(bj) <- NULL
identical(ai, bj)
}
## vectorised
IdenticalRows <- function(i, j, a, b=a) {
#' i and j are row index vectors of equal length
#' result[k] = identical( a[i[k],] , b[j[k],] )
Mo <- if(missing(b)) list(a=a) else list(a=a, b=b)
mapply(IdenticalRowPair, i=i, j=j, MoreArgs=Mo,
SIMPLIFY=TRUE, USE.NAMES=FALSE)
}
spatstat.univar/R/stieltjes.R 0000644 0001762 0000144 00000001452 14632773657 016000 0 ustar ligges users #' stieltjes
#'
#' Stieltjes integration
#'
#' Copyright (c) 2000-2023 Adrian Baddeley, Rolf Turner and Ege Rubak
#' GNU Public Licence (>= 2.0)
#'
#' $Revision: 1.2 $ $Date: 2023/11/05 02:02:53 $
stieltjes <- function(f, M, ...) {
## stieltjes integral of f(x) dM(x)
stopifnot(is.function(f))
StieltjesCalc(M, f, ...)
}
StieltjesCalc <- function(M, f, ...) {
UseMethod("StieltjesCalc")
}
StieltjesCalc.stepfun <- function(M, f, ...) {
stopifnot(inherits(M, "stepfun"))
envM <- environment(M)
#' jump locations
x <- get("x", envir=envM)
#' values of integrand
fx <- f(x, ...)
#' jump amounts
xx <- c(-Inf, (x[-1L] + x[-length(x)])/2, Inf)
dM <- diff(M(xx))
#' integrate f(x) dM(x)
f.dM <- fx * dM
result <- sum(f.dM[is.finite(f.dM)])
return(list(result))
}
spatstat.univar/R/adaptive.R 0000644 0001762 0000144 00000023251 14756455574 015572 0 ustar ligges users #'
#' adaptive.R
#'
#' Adaptive kernel smoothing
#'
#'
#' Copyright (c) 2024 Adrian Baddeley, Tilman Davies and Martin Hazelton
#' GNU Public Licence >= 2.0
#'
densityAdaptiveKernel <- function(X, ...) {
UseMethod("densityAdaptiveKernel")
}
densityAdaptiveKernel.default <-
function(X, bw, ..., weights=NULL,
zerocor=c("none", "weighted", "convolution",
"reflection", "bdrykern", "JonesFoster"),
at=c("grid", "data"),
ngroups=Inf, fast=TRUE) {
check.nvector(X)
at <- match.arg(at)
zerocor <- match.arg(zerocor)
if(at == "grid")
Xname <- short.deparse(substitute(X))
nX <- length(X)
if(nX == 0)
switch(at,
data = return(numeric(nX)),
grid = return(unnormdensity(X, ..., weights=0)))
switch(zerocor,
none = {
from.default <- min(X)
},
{
if(min(X) < 0)
stop(paste("For boundary correction on the positive axis,",
"X must contain only nonnegative values"),
call.=FALSE)
from.default <- 0
})
if(!missing(ngroups)) {
if(is.null(ngroups)) {
ngroups <- max(1L, floor(sqrt(nX)))
} else {
check.1.real(ngroups)
if(is.finite(ngroups)) check.1.integer(ngroups)
if(ngroups > nX) ngroups <- Inf
}
}
if(at == "data" && ngroups == Inf) {
warning("This case is not yet implemented; setting ngroups=nX")
ngroups <- nX
}
if(weighted <- !is.null(weights)) {
check.nvector(weights, nX, oneok=TRUE, vname="weights")
if(length(weights) == 1) weights <- rep(weights, nX)
} else weights <- rep(1/nX,nX)
## determine bandwidth for each data point
if(missing(bw) || is.null(bw)) {
## default is Abramson rule
bw <- bw.abram.default(X, at="data", ...)
} else if(is.character(bw) && length(bw) == 1) {
switch(bw,
adist = , # legacy
bw.adist = , # legacy
pow = ,
bw.pow = {
bw <- bw.pow(X,...)
},
abram = ,
bw.abram = {
bw <- bw.abram.default(X, at="data", ...)
},
stop(paste("Unrecognised bandwidth rule", sQuote(bw)), call.=FALSE))
} else if(is.numeric(bw)) {
check.nvector(bw, nX, oneok=TRUE, vname="bw")
if(length(bw) == 1) bw <- rep(bw, nX)
} else if(is.function(bw)) {
## adaptive bandwidth, function applied to data X
bw <- bw(X)
if(!is.numeric(bw))
stop("The function bw() did not return a numeric vector", call.=FALSE)
if(anyNA(bw))
stop("Some computed bandwidths were NA", call.=FALSE)
} else stop(paste("Argument 'bw' should be a numeric vector of bandwidths,",
"a function to compute bandwidths,",
"or a character string specifying the bandwidth rule"),
call.=FALSE)
if(zerocor == "JonesFoster") {
#' Jones-Foster estimate involves two corrected estimates
resC <- densityAdaptiveKernel.default(X, bw, ..., weights=weights,
zerocor="convolution", at=at,
ngroups=ngroups, fast=fast)
resB <- densityAdaptiveKernel.default(X, bw, ..., weights=weights,
zerocor="bdrykern", at=at,
ngroups=ngroups, fast=fast)
switch(at,
data = {
result <- resC * exp(resB/resC - 1)
},
grid = {
result <- resC
result$y <- resC$y * exp(resB$y/resC$y - 1)
result$call <- match.call()
})
return(result)
}
if(ngroups == Inf && at == "grid") {
## use brute force C code
stuff <- resolve.defaults(list(...),
list(from=from.default, to=max(X), n=512,
kernel="gaussian"))
kernel <- with(stuff, match.kernel(kernel))
r <- with(stuff, seq(from, to, length.out=n))
nr <- length(r)
kerncode <- switch(kernel,
gaussian=1,
rectangular=2,
triangular=3,
epanechnikov=4,
biweight=5,
cosine=6,
optcosine=7,
0)
## go
switch(zerocor,
none = {
res <- .C(SK_adaptiveKDE,
kerncode=as.integer(kerncode),
nx = as.integer(nX),
x = as.double(X),
sd = as.double(bw),
w = as.double(weights),
nr = as.integer(nr),
r = as.double(r),
f = as.double(numeric(nr)),
errcode = as.integer(0),
PACKAGE="spatstat.univar")
},
weighted = {
res <- .C(SK_adaptKDEweight,
kerncode=as.integer(kerncode),
nx = as.integer(nX),
x = as.double(X),
sd = as.double(bw),
w = as.double(weights),
nr = as.integer(nr),
r = as.double(r),
f = as.double(numeric(nr)),
errcode = as.integer(0),
PACKAGE="spatstat.univar")
},
reflection = {
res <- .C(SK_adaptKDEreflect,
kerncode=as.integer(kerncode),
nx = as.integer(nX),
x = as.double(X),
sd = as.double(bw),
w = as.double(weights),
nr = as.integer(nr),
r = as.double(r),
f = as.double(numeric(nr)),
errcode = as.integer(0),
PACKAGE="spatstat.univar")
},
convolution = {
res <- .C(SK_adaptKDEconvol,
kerncode=as.integer(kerncode),
nx = as.integer(nX),
x = as.double(X),
sd = as.double(bw),
w = as.double(weights),
nr = as.integer(nr),
r = as.double(r),
f = as.double(numeric(nr)),
errcode = as.integer(0),
PACKAGE="spatstat.univar")
},
bdrykern = {
res <- .C(SK_adaptKDEbdry,
kerncode=as.integer(kerncode),
nx = as.integer(nX),
x = as.double(X),
sd = as.double(bw),
w = as.double(weights),
nr = as.integer(nr),
r = as.double(r),
f = as.double(numeric(nr)),
errcode = as.integer(0),
PACKAGE="spatstat.univar")
},
stop("Internal error: zerocor not recognised")
)
if(res$errcode != 0)
stop(paste("Internal error code", res$errcode))
result <- structure(list(x=res$r,
y=res$f,
bw=exp(mean(log(bw))),
bwvalues=bw,
n=length(X),
call=match.call(),
data.name=Xname,
has.na=FALSE),
class=c("adaptivedensity", "density"))
} else {
#' divide bandwidths into groups and use FFT
if(ngroups == nX) {
## every data point is a separate group
groupid <- 1:nX
qmid <- bw
} else {
## usual case
p <- seq(0,1,length=ngroups+1)
qbands <- quantile(bw, p)
groupid <- findInterval(bw,qbands,all.inside=TRUE)
#' map to middle of group
pmid <- (p[-1] + p[-length(p)])/2
qmid <- quantile(bw, pmid)
}
group <- factor(groupid, levels=1:ngroups)
Y <- split(X, group)
W <- split(weights, group)
densityargs <- resolve.defaults(list(...),
list(from=from.default, to=max(X), n=512,
zerocor=zerocor, fast=fast))
Z <- mapply(densityBC,
x=Y,
bw=as.list(qmid),
weights=W,
MoreArgs=densityargs,
SIMPLIFY=FALSE)
switch(at,
data = {
ftot <- numeric(nX)
for(i in seq_along(Z)) {
densi <- Z[[i]]
## interpolate
fi <- approx(densi$x, densi$y, X)$y
## accumulate
ftot <- ftot + fi
}
result <- ftot
},
grid = {
fvalues <- sapply(Z, getElement, name="y")
ftot <- if(length(Z) == 1) as.numeric(fvalues) else
.rowSums(fvalues, nrow(fvalues), ncol(fvalues))
xvalues <- Z[[1]]$x
result <- structure(list(x=xvalues, y=ftot,
bw=exp(mean(log(bw))),
bwvalues=bw,
n=length(X),
call=match.call(),
data.name=Xname,
has.na=FALSE),
class=c("adaptivedensity", "density"))
})
}
return(result)
}
plot.adaptivedensity <- function(x, ..., xlab) {
if(missing(xlab))
xlab <- paste("N =", x$n, " Bandwidths ",
prange(formatC(range(x$bwvalues))))
class(x) <- "density"
plot(x, ..., xlab=xlab)
}
spatstat.univar/R/bw.abram.default.R 0000644 0001762 0000144 00000004775 14632773657 017121 0 ustar ligges users #'
#' bw.abram.default.R
#'
#' Abramson bandwidths for numeric data
#'
#' Copyright (c) 2020-2023 Adrian Baddeley, Tilman Davies and Martin Hazelton
#' GNU Public Licence (>= 2.0)
bw.abram <- function(X, h0, ...) {
UseMethod("bw.abram")
}
bw.abram.default <- function(X, h0,
...,
at=c("data", "grid"),
pilot=NULL, hp=h0, trim=5,
smoother=density.default){
check.nvector(X)
at <- match.arg(at)
if(missing(h0) || is.null(h0)) {
h0 <- bw.nrd0(X)
} else {
check.1.real(h0)
stopifnot(h0 > 0)
}
check.1.real(trim)
stopifnot(trim > 0)
if(is.numeric(pilot) && at == "grid")
stop("'pilot' must be a function or density estimate, when at='grid'")
if(is.null(pilot)) {
## compute pilot density by smoothing X
if(!missing(smoother)) {
if(is.character(smoother)) {
smoother <- get(smoother, mode="function")
} else stopifnot(is.function(smoother))
}
pilot <- smoother(X, hp, ...)
xx <- pilot$x
px <- pilot$y
} else if(is.numeric(pilot)) {
check.nvector(pilot, length(X))
} else if(inherits(pilot, "density")) {
xx <- pilot$x
px <- pilot$y
} else if(is.function(pilot)) {
stuff <- resolve.defaults(list(...),
list(from=min(X), to=max(X), n=512))
xx <- with(stuff, seq(from, to, length.out=n))
px <- pilot(xx)
} else {
stop("'pilot' should be a numeric vector, a function, or a density object")
}
#' evaluate pilot at data points
if(is.numeric(pilot)) {
pilot.X <- pilot
} else if(is.function(pilot)) {
pilot.X <- pilot(X)
} else if(inherits(pilot, "density")) {
pilot.X <- approx(xx, px, X, rule=2)$y
} else {
## unreachable, but..
stop("Format of 'pilot' is not recognised")
}
if(!all(is.finite(pilot.X)))
stop("Evaluation of pilot density at X yielded NA, NaN or infinite values")
#' clip bad values
if(min(pilot.X) <= 0)
pilot.X[pilot.X<=0] <- min(pilot.X[pilot.X>0])
#' geometric mean re-scaler (Silverman, 1986; ch 5).
gamma <- exp(mean(log(pilot.X)))^(-0.5)
#' evaluate Abramson bandwidths
switch(at,
data = {
bw <- h0 * pmin((pilot.X^(-0.5))/gamma,trim)
},
grid = {
if(min(px) <= 0)
px[px<=0] <- min(px[px>0])
bb <- h0 * pmin((px^(-0.5))/gamma, trim)
bw <- approxfun(xx, bb, rule=2)
})
return(bw)
}
spatstat.univar/R/bw.taylor.R 0000644 0001762 0000144 00000002704 14674426607 015710 0 ustar ligges users #'
#' bw.taylor.R
#'
#' Bandwidth selection for univariate data
#'
#' Copyright (c) 2024 Tilman M Davies and Adrian Baddeley
#' GNU Public Licence (>= 2.0)
#'
#' $Revision: 1.4 $ $Date: 2024/09/24 03:09:56 $
#'
bw.taylor <- local({
bw.taylor <- function(x, ..., srange=NULL, useC=TRUE) {
x <- as.numeric(as.vector(x))
n <- length(x)
if(n < 2) return(NA)
dr <- diff(range(x))
if(dr == 0) return(NA)
if(is.null(srange)){
srange <- dr * c(1/n, 2/sqrt(n))
} else {
check.range(srange)
srange <- pmax(srange, sqrt(.Machine$double.eps))
}
if(useC) {
z <- optimise(unibootC,interval=srange,x=x,n=n)
} else {
z <- optimise(uniboot,interval=srange,x=x,n=n)
}
result <- z$minimum
return(result)
}
uniboot <- function(h,x,n,ij=FALSE){
ijd <- outer(x,x,"-")^2
if(!ij) diag(ijd) <- NA
s1 <- sum(exp(-ijd/(8*h^2)),na.rm=TRUE)
s2 <- sum(exp(-ijd/(6*h^2)),na.rm=TRUE)
s3 <- sum(exp(-ijd/(4*h^2)),na.rm=TRUE)
return((1/(2*n^2*h*sqrt(2*pi)))*(s1-4/sqrt(3)*s2+sqrt(2)*s3+n*sqrt(2)))
}
unibootC <- function(h, x, n, ij=FALSE) {
diagok <- if(ij) 1L else 0L
z <- .C(SK_taylorboot,
x = as.double(x),
n = as.integer(length(x)),
h = as.double(h),
diagok = as.integer(diagok),
value = as.double(numeric(1)),
PACKAGE="spatstat.univar")
value <- z$value
return(value)
}
bw.taylor
})
spatstat.univar/R/hotrod.R 0000644 0001762 0000144 00000003071 14632773657 015270 0 ustar ligges users #'
#' hotrod.R
#'
#' Heat kernel for a one-dimensional rod
#'
#' Copyright (c) Greg McSwiggan and Adrian Baddeley 2017-2020
#'
#' $Revision: 1.6 $ $Date: 2022/05/22 00:01:01 $
hotrod <- function(len, xsource, xquery, sigma,
ends=c("insulated", "absorbing"),
nmax=20) {
ends <- match.arg(ends)
len <- as.numeric(len)
xsource <- as.numeric(xsource)
xquery <- as.numeric(xquery)
sigma <- as.numeric(sigma)
nmax <- as.integer(nmax)
df <- data.frame(len=len, xsource=xsource, xquery=xquery,
sigma=sigma, nmax=nmax)
n <- nrow(df)
switch(ends,
insulated = {
z <- with(df,
.C(SK_hotrodInsul,
n = as.integer(n),
a = as.double(len),
x = as.double(xsource),
y = as.double(xquery),
s = as.double(sigma),
m = as.integer(nmax),
z = as.double(numeric(n)),
PACKAGE="spatstat.univar")$z)
},
absorbing = {
z <- with(df,
.C(SK_hotrodAbsorb,
n = as.integer(n),
a = as.double(len),
x = as.double(xsource),
y = as.double(xquery),
s = as.double(sigma),
m = as.integer(nmax),
z = as.double(numeric(n)),
PACKAGE="spatstat.univar")$z)
})
return(z)
}
spatstat.univar/R/rounding.R 0000644 0001762 0000144 00000002266 14632773734 015617 0 ustar ligges users #' detect rounding of data
#'
#' $Revision: 1.4 $ $Date: 2024/06/14 05:20:33 $
#'
rounding <- function(x) {
UseMethod("rounding")
}
rounding.default <- function(x) {
# works for numeric, complex, matrix etc
if(all(x == 0))
return(0)
if(isTRUE(all.equal(x, round(x)))) {
# integers: go up
k <- 0
smallk <- -log10(.Machine$double.xmax)
repeat {
if(k < smallk || !all(x == round(x, k-1)))
return(k)
k <- k-1
}
} else {
# not integers: go down
k <- 1
bigk <- -log10(.Machine$double.eps)
repeat {
if(k > bigk || all(x == round(x, k)))
return(k)
k <- k+1
}
}
}
## least significant digit in decimal representation
lastdigit <- function(x) {
x <- abs(as.numeric(x))
z <- (x * 10^sapply(x, rounding.default)) %% 10
return(z)
}
## most significant digit in decimal representation
firstdigit <- function(x) {
x <- abs(as.numeric(x))
z <- trunc(x/10^(floor(log10(ifelse(x == 0, 1, x)))))
return(z)
}
## number of digits in decimal representation
ndigits <- function(x) {
x <- abs(as.numeric(x))
z <- pmax(1, ceiling(log10(ifelse(x == 0, 1, x * 10^sapply(x, rounding.default)))))
return(z)
}
spatstat.univar/R/kernelsBC.R 0000644 0001762 0000144 00000003343 14710326734 015626 0 ustar ligges users #'
#' kernelsBC.R
#'
#' Boundary-corrected kernels on the positive half-line
#'
#' Copyright (c) 2008-2023 Adrian Baddeley, Tilman Davies and Martin Hazelton
#' GNU Public Licence (>= 2.0)
dkernelBC <- function(x, mean, sd=1, kernel="gaussian",
zerocor=c("none", "weighted", "convolution",
"reflection", "bdrykern")) {
kernel <- match.kernel(kernel)
zerocor <- match.arg(zerocor)
stopifnot(is.numeric(x))
stopifnot(is.numeric(mean))
stopifnot(is.numeric(sd) && length(sd) == 1 && sd > 0)
#' compute uncorrected density
fx <- dkernel(x, mean=mean, sd=sd, kernel=kernel)
#' now adjust it
switch(zerocor,
none = {},
weighted = {
## divide by mass of original kernel on positive half line
fx <- ifelse(fx <= 0, 0,
fx/(1 - pkernel(0, mean=mean, sd=sd, kernel=kernel)))
},
convolution = {
## divide by mass of kernel at query point
fx <- ifelse(fx <= 0, 0,
fx/(1 - pkernel(0, x, sd=sd, kernel=kernel)))
},
reflection = {
## add density of reflected kernel
fx <- fx + dkernel(x, mean= -mean, sd=sd, kernel=kernel)
},
bdrykern = {
h <- sd * kernel.factor(kernel)
p <- x/h
u <- (x-mean)/h
nu0x <- kernel.moment(0, p, kernel=kernel) # default is template
nu1x <- kernel.moment(1, p, kernel=kernel)
nu2x <- kernel.moment(2, p, kernel=kernel)
denomx <- nu0x * nu2x - nu1x^2
ax <- nu2x/denomx
bx <- nu1x/denomx
fx <- ifelse(fx <= 0, 0,
fx * (ax - bx * u))
})
return(fx)
}
spatstat.univar/R/breakpts.R 0000644 0001762 0000144 00000011552 14632773657 015607 0 ustar ligges users #'
#' breakpts.R
#'
#' A simple class definition for the specification
#' of histogram breakpoints for nonnegative numbers (such as distances)
#' in the special form we need them.
#'
#'
#' $Revision: 1.31 $ $Date: 2023/11/05 01:02:04 $
#'
#' The breakpoints must
#' (a) span the range of the data
#' (b) be given in increasing order
#' (c) satisfy breaks[2] = 0.
#'
#' The function make.even.breaks() will create suitable breakpoints.
#'
#' Condition (c) means that the first histogram cell has
#' *right* endpoint equal to 0.
#'
#' Since the numerical data are nonnegative, the effect of (c) is
#' that the first histogram cell counts the number of values which are
#' exactly equal to 0. Hence F(0), the probability P{X = 0},
#' is estimated without a discretisation bias.
#'
#' We assume the histograms have followed the default counting rule
#' in hist.default(), which is such that the k-th entry of the histogram
#' counts the number of data values in
#' I_k = ( breaks[k],breaks[k+1] ] for k > 1
#' I_1 = [ breaks[1],breaks[2] ]
#'
#' The implementations of estimators of distance distributions
#' in the spatstat package return vectors of length = length(breaks)-1
#' with value[k] = estimate of F(breaks[k+1]),
#' i.e. value[k] is an estimate of the c.d.f. at the RIGHT endpoint
#' of the kth histogram cell.
#'
#' An object of class 'breakpts' contains:
#'
#' $val the actual breakpoints
#' $max the maximum value (= last breakpoint)
#' $ncells total number of histogram cells
#' $r right endpoints, r = val[-1]
#' $even logical = TRUE if cells known to be evenly spaced
#' $npos number of histogram cells on the positive halfline
#' = length(val) - 2,
#' or NULL if cells not evenly spaced
#' $step histogram cell width
#' or NULL if cells not evenly spaced
#'
#' --------------------------------------------------------------------
#'
breakpts <- function(val, maxi, even=FALSE, npos=NULL, step=NULL) {
out <- list(val=as.numeric(val),
max=as.numeric(maxi),
ncells=length(val)-1L, r = val[-1L],
even=isTRUE(even),
npos=npos, step=step)
class(out) <- "breakpts"
out
}
make.even.breaks <- function(bmax, npos, bstep) {
bmax <- as.numeric(bmax)
if(bmax <= 0)
stop("bmax must be positive")
if(missing(bstep) && missing(npos))
stop(paste("Must specify either", sQuote("bstep"),
"or", sQuote("npos")))
if(!missing(npos)) {
npos <- as.integer(npos)
bstep <- bmax/npos
val <- seq(from=0, to=bmax, length.out=npos+1L)
val <- c(-bstep,val)
right <- bmax
} else {
bstep <- as.numeric(bstep)
npos <- ceiling(bmax/bstep)
right <- bstep * npos
val <- seq(from=0, to=right, length.out=npos+1L)
val <- c(-bstep,val)
}
breakpts(val, right, TRUE, npos, bstep)
}
as.breakpts <- function(...) {
XL <- list(...)
if(length(XL) == 1L) {
#' There is a single argument
X <- XL[[1L]]
if(inherits(X, "breakpts")) {
## X already in correct form
return(X)
}
if(is.vector(X) && length(X) > 2) {
## it's a vector
X <- as.numeric(X)
if(X[2L] != 0)
stop("breakpoints do not satisfy breaks[2] = 0")
#'The following test for equal spacing is used in hist.default
steps <- diff(X)
if(diff(range(steps)) < 1e-07 * mean(steps)) {
#'equally spaced
return(breakpts(X, max(X), TRUE, length(X)-2, steps[1L]))
} else {
#'unknown spacing
return(breakpts(X, max(X), FALSE))
}
}
} else {
#' There are multiple arguments.
#' Exactly two arguments
if(length(XL) == 2)
return(make.even.breaks(XL[[1L]], XL[[2L]]))
#' Two arguments named 'max' and 'npos'
if(!is.null(XL$max) && !is.null(XL$npos))
return(make.even.breaks(XL$max, XL$npos))
#' otherwise
stop("Don't know how to convert these data to breakpoints")
}
#' never reached
}
check.hist.lengths <- function(hist, breaks) {
#' internal check for consistency between histogram result and breakpoints
stopifnot(inherits(breaks, "breakpts"))
nh <- length(hist)
nb <- breaks$ncells
if(nh != nb)
stop(paste("Length of histogram =", nh,
"not equal to number of histogram cells =", nb))
}
breakpts.from.r <- function(r) {
if(!is.numeric(r) && !is.vector(r))
stop("r must be a numeric vector")
r <- as.numeric(r)
if(length(r) < 2)
stop(paste("r has length", length(r), "- must be at least 2"))
if(r[1L] != 0)
stop("First r value must be 0")
if(any(diff(r) <= 0))
stop("successive values of r must be increasing")
dr <- r[2L] - r[1L]
b <- c(-dr, r)
return(as.breakpts(b))
}
spatstat.univar/R/indefinteg.R 0000644 0001762 0000144 00000004125 14632773657 016106 0 ustar ligges users #'
#' indefinteg.R
#'
#' Indefinite integral
#'
#' $Revision: 1.8 $ $Date: 2022/02/12 02:56:33 $
indefinteg <- function (f, x, ...,
method=c("trapezoid", "quadrature"),
lower=min(x), nfine=8192) {
method <- match.arg(method)
if(length(x) == 0) return(numeric(0))
adjust <- !missing(lower)
if(method == "trapezoid" && (any(is.infinite(x)) ||
(adjust && is.infinite(lower)) ||
(diff(ra <- range(x)) < sqrt(.Machine$double.eps)))) {
method <- "quadrature"
}
switch(method,
trapezoid = {
## indefinite integral using trapezoidal rule
## Determine range for numerical calculation
if(adjust) {
check.1.real(lower)
raplus <- ra + c(-1,1) * diff(ra)/2
included <- inside.range(lower, raplus)
if(included) ra <- range(ra, lower)
}
## Make a fine sequence of x values
xfine <- seq(ra[1L], ra[2L], length.out=nfine)
delta <- diff(ra)/(nfine - 1)
## Evaluate integrand on finer sequence
yfine <- f(xfine, ...)
## Apply trapezoidal rule
zfine <- c(0, cumsum(delta * (yfine[-1L] + yfine[-nfine]))/2)
## Evaluate at 'x'
Intf <- approxfun(xfine, zfine, rule=2)
z <- Intf(x)
## Adjust for different lower limit
if(adjust) {
## calculate indefinite integral from 'lower' to min(xfine)
x0 <- ra[1L]
deltaI <- if(included) {
Intf(x0) - Intf(lower)
} else {
integrate(f, lower=lower, upper=x0, ...)$value
}
## adjust
z <- z + deltaI
}
},
quadrature = {
## indefinite integral using 'integrate' at each value
n <- length(x)
z <- numeric(n)
for(i in 1:n)
z[i] <- integrate(f, lower=lower, upper=x[i], ...)$value
})
return(z)
}
spatstat.univar/R/util.R 0000644 0001762 0000144 00000001102 14710326734 014722 0 ustar ligges users #' utility functions
#'
#' Copyright (c) 2024 Adrian Baddeley, Tilman Davies and Martin Hazelton
check.bandwidth <- function(bw,
descrip=paste("bandwidth", sQuote("bw")),
fatal=TRUE) {
if(!fatal)
return(is.numeric(bw) && length(bw) == 1 && bw > 0)
if(!is.numeric(bw))
stop(paste(descrip, "was not numeric"), call.=FALSE)
if(length(bw) != 1)
stop(paste(descrip, "was not a single number"), call.=FALSE)
if(bw <= 0)
stop(paste(descrip, "was not a positive number"), call.=FALSE)
return(TRUE)
}
spatstat.univar/R/transformquantiles.R 0000644 0001762 0000144 00000000654 14632773657 017736 0 ustar ligges users ## transformquantiles.R
## probability integral transformation
## aka histogram equalisation
## aka transformation to uniformity
## $Revision: 1.1 $ $Date: 2023/11/04 04:39:11 $
transformquantiles <- function(X, uniform=FALSE, reverse=FALSE, ...) {
if(!uniform && !reverse) return(X)
o <- order(X[])
V <- X
n <- length(o)
if(uniform) V[][o] <- (seq_len(n) - 0.5)/n
if(reverse) V[][o] <- V[][rev(o)]
return(V)
}
spatstat.univar/NEWS 0000644 0001762 0000144 00000006217 14761741000 014125 0 ustar ligges users CHANGES IN spatstat.univar VERSION 3.1-2
OVERVIEW
o Improvements to documentation.
o Internal improvements.
CHANGES IN spatstat.univar VERSION 3.1-1
OVERVIEW
o Internal changes to satisfy package checker.
CHANGES IN spatstat.univar VERSION 3.1-0
OVERVIEW
o Boundary-corrected kernel density estimation on the positive half-line.
o Bandwidth selection by non-random bootstrap.
o Minor improvements to documentation.
NEW FUNCTIONS
o bw.taylor
Bandwidth selection for kernel density estimation
using Taylor's non-random bootstrap
o densityBC
An extension of density.default that includes boundary corrections
for truncation of the density to the positive half line.
o densityAdaptiveKernel.default
Variable-bandwidth kernel density estimation,
with optional boundary correction.
o dkernelBC
Evaluate the boundary corrected kernel
CHANGES IN spatstat.univar VERSION 3.0-1
OVERVIEW
o quantiles using linear approximation.
o extract the knots of a weighted CDF
NEW FUNCTIONS
o knots.ewcdf
Method for generic 'knots' for extracting the jump points of a weighted
cumulative distribution function (object of class 'ewcdf').
SIGNIFICANT USER-VISIBLE CHANGES
o quantile.ecdf, quantile.ewcdf
Now supports type=4 (linear interpolation).
o quantilefun.ecdf, quantilefun.ewcdf
Now supports type=4 (linear interpolation).
CHANGES IN spatstat.univar VERSION 3.0-0
OVERVIEW
o Abramson adaptive bandwidths.
o Adaptive kernel smoothing.
o Digits in the decimal representation of a number.
o Unique representatives in a vector or data frame.
o Bug fix in weighted.quantile.
o Internal improvements.
NEW FUNCTIONS
o bw.abram
Generic function for computing Abramson adaptive bandwidths.
o bw.abram.default
Default method for computing Abramson adaptive bandwidths for numerical data.
o densityAdaptiveKernel
Generic function moved from spatstat.explore to spatstat.univar.
o rounding, rounding.default
Functions moved from spatstat.geom to spatstat.univar.
o firstdigit, lastdigit, ndigits
Digits in the decimal representation of a number.
o uniquemap
Generic function moved from spatstat.geom to spatstat.univar.
o uniquemap.default
Method for mapping duplicate entries to unique entries in a vector.
Moved from spatstat.geom to spatstat.univar.
o uniquemap.data.frame, uniquemap.matrix
Method for mapping duplicate rows to unique rows in a data frame.
Moved from spatstat.geom to spatstat.univar.
BUG FIXES
o weighted.quantile
Implementation was incorrect for type=2.
Fixed.
CHANGES IN spatstat.univar VERSION 2.0-3
OVERVIEW
o Minor corrections to package information.
CHANGES IN spatstat.univar VERSION 2.0-2
OVERVIEW
o Minor corrections to package information.
CHANGES IN spatstat.univar VERSION 2.0-1
OVERVIEW
o Minor corrections to package information.
CHANGES IN spatstat.univar VERSION 2.0-0
OVERVIEW
o First release of package.
spatstat.univar/src/ 0000755 0001762 0000144 00000000000 14710326734 014216 5 ustar ligges users spatstat.univar/src/kernels.h 0000644 0001762 0000144 00000004571 14710326734 016041 0 ustar ligges users /* declarations for kernels.c */
double dTEMgaussian(double);
double dTEMrectangular(double);
double dTEMtriangular(double);
double dTEMepanechnikov(double);
double dTEMbiweight(double);
double dTEMcosine(double);
double dTEMoptcosine(double);
double dgaussian(double, double, double);
double drectangular(double, double, double);
double dtriangular(double, double, double);
double depanechnikov(double, double, double);
double dbiweight(double, double, double);
double dcosine(double, double, double);
double doptcosine(double, double, double);
double pTEMgaussian(double);
double pTEMrectangular(double);
double pTEMtriangular(double);
double pTEMepanechnikov(double);
double pTEMbiweight(double);
double pTEMcosine(double);
double pTEMoptcosine(double);
double pgaussian(double, double, double);
double prectangular(double, double, double);
double ptriangular(double, double, double);
double pepanechnikov(double, double, double);
double pbiweight(double, double, double);
double pcosine(double, double, double);
double poptcosine(double, double, double);
double m1TEMgaussian(double);
double m2TEMgaussian(double);
double m1TEMrectangular(double);
double m2TEMrectangular(double);
double m1TEMtriangular(double);
double m2TEMtriangular(double);
double m1TEMepanechnikov(double);
double m2TEMepanechnikov(double);
double m1TEMbiweight(double);
double m2TEMbiweight(double);
double m1TEMcosine(double);
double m2TEMcosine(double);
double m1TEMoptcosine(double);
double m2TEMoptcosine(double);
double m1gaussian(double, double, double);
double m1rectangular(double, double, double);
double m1triangular(double, double, double);
double m1epanechnikov(double, double, double);
double m1biweight(double, double, double);
double m1cosine(double, double, double);
double m1optcosine(double, double, double);
double m2gaussian(double, double, double);
double m2rectangular(double, double, double);
double m2triangular(double, double, double);
double m2epanechnikov(double, double, double);
double m2biweight(double, double, double);
double m2cosine(double, double, double);
double m2optcosine(double, double, double);
double bgaussian(double, double, double);
double brectangular(double, double, double);
double btriangular(double, double, double);
double bepanechnikov(double, double, double);
double bbiweight(double, double, double);
double bcosine(double, double, double);
double boptcosine(double, double, double);
spatstat.univar/src/adaptiveloop.h 0000644 0001762 0000144 00000002631 14710326734 017060 0 ustar ligges users /*
adaptiveloop.h
Code for the actual computation of adaptive kernel estimates
This file is #included multiple times in 'adaptive.h',
once for each kernel.
Uses macros ZEROCOR and KERNELNAME
Copyright (c) 2008-2024 Adrian Baddeley, Tilman Davies and Martin Hazelton
GNU Public Licence (>= 2.0)
*/
#define PREFIX(A, KNAME) A ## KNAME
#define CDF(KNAME) PREFIX(p, KNAME)
#define DENSITY(KNAME) PREFIX(d, KNAME)
#define BDRYDENSITY(KNAME) PREFIX(b, KNAME)
/* sum contributions from each data point x[i] */
for(i = 0; i < Nx; i++) {
xi = x[i];
wi = w[i];
si = sd[i];
#if (ZEROCOR == WEIGHTED)
/*
divide by mass of kernel on positive half-line
so that total mass is conserved
*/
kmass = 1.0 - CDF(KERNELNAME) (0.0, xi, si);
wi /= kmass;
#endif
/* visit each query point r[j] */
for(j = 0; j < Nr; j++) {
rj = r[j];
#if (ZEROCOR == BDRYKERNEL)
kvalue = BDRYDENSITY(KERNELNAME) (rj, xi, si);
#else
kvalue = DENSITY(KERNELNAME) (rj, xi, si);
#endif
#if (ZEROCOR == REFLECTION)
/* add contribution from reflected data point -xi */
kvalue += DENSITY(KERNELNAME) (rj, -xi, si);
#elif (ZEROCOR == CONVOLUTION)
/* renormalise to give unbiased estimator for uniform density */
kvalue /= 1.0 - CDF(KERNELNAME) (0.0, rj, si);
#endif
f[j] += kvalue * wi;
}
}
#undef CDF
#undef DENSITY
#undef BDRYDENSITY
#undef PREFIX
spatstat.univar/src/access.c 0000644 0001762 0000144 00000005552 14710326734 015632 0 ustar ligges users /*
access.c
R interface functions
just to check the validity of internal code
*/
#include "interfacecodes.h"
#include "kernels.h"
void kermom(int *nx,
double *x,
double *mean,
double *sd,
int *m,
int *kerncode,
double *y,
int *errcode) {
int i, n;
n = *nx;
*errcode = OK;
if(*m == 0) {
/* cumulative distribution function */
if(*kerncode == GAUSSIAN) {
for(i = 0; i < n; i++) y[i] = pgaussian(x[i], mean[i], sd[i]);
} else if(*kerncode == RECTANGULAR){
for(i = 0; i < n; i++) y[i] = prectangular(x[i], mean[i], sd[i]);
} else if(*kerncode == TRIANGULAR) {
for(i = 0; i < n; i++) y[i] = ptriangular(x[i], mean[i], sd[i]);
} else if(*kerncode == EPANECHNIKOV) {
for(i = 0; i < n; i++) y[i] = pepanechnikov(x[i], mean[i], sd[i]);
} else if(*kerncode == BIWEIGHT) {
for(i = 0; i < n; i++) y[i] = pbiweight(x[i], mean[i], sd[i]);
} else if(*kerncode == COSINE) {
for(i = 0; i < n; i++) y[i] = pcosine(x[i], mean[i], sd[i]);
} else if(*kerncode == OPTCOSINE) {
for(i = 0; i < n; i++) y[i] = poptcosine(x[i], mean[i], sd[i]);
}
} else if(*m == 1) {
/* partial first moment */
if(*kerncode == GAUSSIAN) {
for(i = 0; i < n; i++) y[i] = m1gaussian(x[i], mean[i], sd[i]);
} else if(*kerncode == RECTANGULAR){
for(i = 0; i < n; i++) y[i] = m1rectangular(x[i], mean[i], sd[i]);
} else if(*kerncode == TRIANGULAR) {
for(i = 0; i < n; i++) y[i] = m1triangular(x[i], mean[i], sd[i]);
} else if(*kerncode == EPANECHNIKOV) {
for(i = 0; i < n; i++) y[i] = m1epanechnikov(x[i], mean[i], sd[i]);
} else if(*kerncode == BIWEIGHT) {
for(i = 0; i < n; i++) y[i] = m1biweight(x[i], mean[i], sd[i]);
} else if(*kerncode == COSINE) {
for(i = 0; i < n; i++) y[i] = m1cosine(x[i], mean[i], sd[i]);
} else if(*kerncode == OPTCOSINE) {
for(i = 0; i < n; i++) y[i] = m1optcosine(x[i], mean[i], sd[i]);
}
} else if(*m == 2) {
/* partial second moment */
if(*kerncode == GAUSSIAN) {
for(i = 0; i < n; i++) y[i] = m2gaussian(x[i], mean[i], sd[i]);
} else if(*kerncode == RECTANGULAR){
for(i = 0; i < n; i++) y[i] = m2rectangular(x[i], mean[i], sd[i]);
} else if(*kerncode == TRIANGULAR) {
for(i = 0; i < n; i++) y[i] = m2triangular(x[i], mean[i], sd[i]);
} else if(*kerncode == EPANECHNIKOV) {
for(i = 0; i < n; i++) y[i] = m2epanechnikov(x[i], mean[i], sd[i]);
} else if(*kerncode == BIWEIGHT) {
for(i = 0; i < n; i++) y[i] = m2biweight(x[i], mean[i], sd[i]);
} else if(*kerncode == COSINE) {
for(i = 0; i < n; i++) y[i] = m2cosine(x[i], mean[i], sd[i]);
} else if(*kerncode == OPTCOSINE) {
for(i = 0; i < n; i++) y[i] = m2optcosine(x[i], mean[i], sd[i]);
}
} else {
*errcode = NOT_SUPPORTED;
return;
}
}
spatstat.univar/src/chunkloop.h 0000755 0001762 0000144 00000001615 14632773657 016414 0 ustar ligges users /*
chunkloop.h
Divide a loop into chunks
Convenient for divide-and-recombine,
and reducing calls to R_CheckUserInterrupt, etc.
$Revision: 1.3 $ $Date: 2018/12/18 02:43:11 $
Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018
Licence: GNU Public Licence >= 2
*/
#define OUTERCHUNKLOOP(IVAR, LOOPLENGTH, ICHUNK, CHUNKSIZE) \
IVAR = 0; \
ICHUNK = 0; \
while(IVAR < LOOPLENGTH)
#define INNERCHUNKLOOP(IVAR, LOOPLENGTH, ICHUNK, CHUNKSIZE) \
ICHUNK += CHUNKSIZE; \
if(ICHUNK > LOOPLENGTH) ICHUNK = LOOPLENGTH; \
for(; IVAR < ICHUNK; IVAR++)
#define XOUTERCHUNKLOOP(IVAR, ISTART, IEND, ICHUNK, CHUNKSIZE) \
IVAR = ISTART; \
ICHUNK = 0; \
while(IVAR <= IEND)
#define XINNERCHUNKLOOP(IVAR, ISTART, IEND, ICHUNK, CHUNKSIZE) \
ICHUNK += CHUNKSIZE; \
if(ICHUNK > IEND) ICHUNK = IEND; \
for(; IVAR <= IEND; IVAR++)
#define CHUNKLOOP_H
spatstat.univar/src/kernels.c 0000644 0001762 0000144 00000026432 14712311773 016033 0 ustar ligges users /*
kernels.c
C support for the basic kernels recognised by default.density
'gaussian'
'rectangular'
'triangular'
'epanechnikov'
'biweight'
'cosine'
'optcosine'
Includes pdf, cdf, partial moments and boundary-corrected kernels.
d: probability density
p: cumulative distribution function
m1: partial first moment
m2: partial second moment
b: linear boundary kernel at 0
Prototypes for all these functions are declared in 'kernels.h'
Constants are declared in 'kerconstants.h'
Terminology:
template kernel: kernel with mean 0, halfwidth 1
standard kernel: kernel with mean 0, standard deviation 1
See 'kerconstants.h' for further information.
The programmer encodes the functions d, p, m1, m2 for the TEMPLATE kernel only
and the general case is derived by standard transformations.
Copyright (c) 2008-2024 Adrian Baddeley, Tilman Davies and Martin Hazelton
GNU Public Licence (>= 2.0)
*/
#include