spatstat.univar/0000755000176200001440000000000014762030413013420 5ustar liggesusersspatstat.univar/tests/0000755000176200001440000000000014632773657014606 5ustar liggesusersspatstat.univar/tests/all.R0000644000176200001440000001350614710660075015470 0ustar liggesusers#' #' 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/MD50000644000176200001440000001027714762030413013737 0ustar liggesuserse8c3652f55a83db019fe8a31f29bfff0 *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/0000755000176200001440000000000014756455360013640 5ustar liggesusersspatstat.univar/R/weightedStats.R0000644000176200001440000000700114632773657016605 0ustar liggesusers#' #' 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.R0000644000176200001440000001512414640456407015051 0ustar liggesusers# # 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.R0000644000176200001440000000247414710660075015222 0ustar liggesusers#' #' 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.R0000644000176200001440000001520314632773657016707 0ustar liggesusers# # 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.R0000644000176200001440000000024114632773657015572 0ustar liggesusers#' #' integral.R #' #' generic #' #' $Revision: 1.1 $ $Date: 2023/10/22 02:03:35 $ integral <- function(f, domain=NULL, ...) { UseMethod("integral") } spatstat.univar/R/kernels.R0000644000176200001440000002503314632773657015436 0ustar liggesusers# # 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.R0000644000176200001440000000062614632773657015063 0ustar liggesusers## 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.R0000644000176200001440000000120614710326734015166 0ustar liggesusers#' #' 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.R0000644000176200001440000001106714632773657014751 0ustar liggesusers# # 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.R0000644000176200001440000000525014632773657017214 0ustar liggesusers#' #' 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.R0000644000176200001440000002637414710331457015651 0ustar liggesusers#' #' #' 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.R0000644000176200001440000000647514636753555016007 0ustar liggesusers#' #' 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.R0000644000176200001440000000145214632773657016000 0ustar liggesusers#' 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.R0000644000176200001440000002325114756455574015572 0ustar liggesusers#' #' 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.R0000644000176200001440000000477514632773657017121 0ustar liggesusers#' #' 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.R0000644000176200001440000000270414674426607015710 0ustar liggesusers#' #' 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.R0000644000176200001440000000307114632773657015270 0ustar liggesusers#' #' 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.R0000644000176200001440000000226614632773734015617 0ustar liggesusers#' 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.R0000644000176200001440000000334314710326734015626 0ustar liggesusers#' #' 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.R0000644000176200001440000001155214632773657015607 0ustar liggesusers#' #' 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.R0000644000176200001440000000412514632773657016106 0ustar liggesusers#' #' 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.R0000644000176200001440000000110214710326734014722 0ustar liggesusers#' 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.R0000644000176200001440000000065414632773657017736 0ustar liggesusers## 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/NEWS0000644000176200001440000000621714761741000014125 0ustar liggesusers 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/0000755000176200001440000000000014710326734014216 5ustar liggesusersspatstat.univar/src/kernels.h0000644000176200001440000000457114710326734016041 0ustar liggesusers/* 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.h0000644000176200001440000000263114710326734017060 0ustar liggesusers/* 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.c0000644000176200001440000000555214710326734015632 0ustar liggesusers/* 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.h0000755000176200001440000000161514632773657016414 0ustar liggesusers/* 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.c0000644000176200001440000002643214712311773016033 0ustar liggesusers/* 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 double sqrt(double), exp(double), cos(double), sin(double); #include "kerconstants.h" /* >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> T E M P L A T E K E R N E L S <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Prefix 'TEM' indicates the template kernel (mean = 0, halfwidth = 1) The functions d, p, m1, m2 for the template kernel are encoded by hand. */ /* ------------ GAUSSIAN --------------------------------- */ /* Gaussian density */ double dTEMgaussian(double x) { double fx; fx = M_1_SQRT_2PI * exp(- x * x/2); return(fx); } /* Gaussian cdf */ double pTEMgaussian(double x) { double Fx; Fx = pnorm(x, 0.0, 1.0, (int) 1, (int) 0); return(Fx); } /* Gaussian partial first moment */ double m1TEMgaussian(double x) { double z; z = -dnorm(x, 0.0, 1.0, (int) 0); return(z); } /* Gaussian partial second moment */ double m2TEMgaussian(double x) { double z; z = pnorm(x, 0.0, 1.0, (int) 1, (int) 0) - x * dnorm(x, 0.0, 1.0, (int) 0); return(z); } /* ------------ RECTANGULAR --------------------------------- */ /* Rectangular density */ double dTEMrectangular(double x) { double fx; fx = (x < -1.0) ? 0.0 : (x > 1.0) ? 0.0 : 0.5; return(fx); } /* Rectangular, cdf */ double pTEMrectangular(double x) { double Fx; Fx = (x < -1.0) ? 0.0 : (x > 1.0) ? 1.0 : ((x + 1.0)/2); return(Fx); } /* Rectangular, partial first moment */ double m1TEMrectangular(double x) { double z; z = (x < -1.0) ? 0.0 : (x > 1.0) ? 0.0 : ((x * x - 1.0)/4); return(z); } /* Rectangular, partial second moment */ double m2TEMrectangular(double x) { double z; z = (x < -1.0) ? 0.0 : (x > 1.0) ? TEMPLATE_VARIANCE(rectangular) : ((x * x * x + 1.0)/6); return(z); } /* ------------ TRIANGULAR --------------------------------- */ /* Triangular density */ double dTEMtriangular(double x) { double fx; if(x < 0.0) x = -x; fx = 1.0 - x; if(fx < 0.0) return(0.0); return(fx); } /* Triangular, cdf */ double pTEMtriangular(double x) { double Fx; Fx = (x < -1.0) ? 0.0 : (x > 1.0) ? 1.0 : (x < 0.0) ? (0.5 + x + x*x/2) : (0.5 + x - x*x/2); return(Fx); } /* Triangular, partial first moment */ double m1TEMtriangular(double x) { double z; z = (x < -1.0) ? 0.0 : (x > 1.0) ? 0.0 : (x < 0.0) ? (x*x/2 + x*x*x/3 - 1.0/6) : (x*x/2 - x*x*x/3 - 1.0/6); return(z); } /* Triangular, partial second moment */ double m2TEMtriangular(double x) { double z; z = (x < -1.0) ? 0.0 : (x > 1.0) ? TEMPLATE_VARIANCE(triangular) : (x < 0.0) ? (x*x*x/3 + x*x*x*x/4 + 1.0/12) : (x*x*x/3 - x*x*x*x/4 + 1.0/12); return(z); } /* ------------ EPANECHNIKOV --------------------------------- */ /* Epanechnikov density */ double dTEMepanechnikov(double x) { double z, fx; z = 1.0 - x * x; if(z < 0.0) return(0.0); fx = (3.0/4) * z; return(fx); } /* Epanechnikov, cdf */ double pTEMepanechnikov(double x) { double Fx; Fx = (x < -1.0) ? 0.0 : (x > 1.0) ? 1.0 : ((2.0 + 3 * x - x*x*x)/4); return(Fx); } /* Epanechnikov, partial first moment */ double m1TEMepanechnikov(double x) { double z; z = (x < -1.0) ? 0.0 : (x > 1.0) ? 0.0 : ((-3.0 + 6 * x*x - 3*x*x*x*x)/16); return(z); } /* Epanechnikov, partial second moment */ double m2TEMepanechnikov(double x) { double z; z = (x < -1.0) ? 0.0 : (x > 1.0) ? TEMPLATE_VARIANCE(epanechnikov) : ((2.0 + 5 * x*x*x - 3*x*x*x*x*x)/20); return(z); } /* ------------ BIWEIGHT --------------------------------- */ /* Biweight density */ double dTEMbiweight(double x) { double z, fx; z = 1.0 - x * x; if(z < 0.0) return(0.0); fx = (15.0/16) * z * z; return(fx); } /* biweight, cdf */ double pTEMbiweight(double x) { double Fx; Fx = (x < -1.0) ? 0.0 : (x > 1.0) ? 1.0 : ((15 * x - 10 * x*x*x + 3 * x*x*x*x*x + 8.0)/16); return(Fx); } /* biweight, partial first moment */ double m1TEMbiweight(double x) { double z; z = (x < -1.0) ? 0.0 : (x > 1.0) ? 0.0 : ((5 * R_pow(x, 6) - 15 * R_pow(x, 4) + 15 * x*x - 5.0)/32); return(z); } /* biweight, partial second moment */ double m2TEMbiweight(double x) { double z; z = (x < -1.0) ? 0.0 : (x > 1.0) ? TEMPLATE_VARIANCE(biweight) : ((15 * R_pow(x, 7) - 42 * R_pow(x, 5) + 35 * R_pow(x, 3) + 8.0)/112); return(z); } /* ------------ COSINE --------------------------------- */ /* cosine density */ double dTEMcosine(double x) { double fx; if(x < -1.0 || x > 1.0) return(0.0); fx = (1.0 + cos(M_PI * x))/2; return(fx); } /* cosine, cdf */ double pTEMcosine(double x) { double Fx; Fx = (x < -1.0) ? 0.0 : (x > 1.0) ? 1.0 : ((x + sin(M_PI * x)/M_PI + 1.0)/2); return(Fx); } /* cosine, partial first moment */ double m1TEMcosine(double x) { double z, pix; pix = M_PI * x; z = (x < -1.0) ? 0.0 : (x > 1.0) ? 0.0 : ((x*x-1.0)/4 + (pix*sin(pix) + cos(pix) + 1.0)/(2*M_PI*M_PI) ); return(z); } /* cosine, partial second moment */ double m2TEMcosine(double x) { double z, pix; pix = M_PI * x; z = (x < -1.0) ? 0.0 : (x > 1.0) ? TEMPLATE_VARIANCE(cosine): ((x * x * x + 1.0)/6 + ( (pix * pix - 2.0) * sin(pix) + 2 * pix * cos(pix) - 2 * M_PI )/(2 * M_PI * M_PI * M_PI) ); return(z); } /* ------------ OPTIMAL COSINE --------------------------------- */ /* optcosine density */ double dTEMoptcosine(double x) { double fx; if(x < -1.0 || x > 1.0) return(0.0); fx = M_PI_4 * cos(M_PI * x/2); return(fx); } /* optcosine, cdf */ double pTEMoptcosine(double x) { double Fx; Fx = (x < -1.0) ? 0.0 : (x > 1.0) ? 1.0 : ((sin(M_PI * x/2) + 1.0)/2); return(Fx); } /* optcosine, partial first moment */ double m1TEMoptcosine(double x) { double z, pi2x; pi2x = M_PI_2 * x; z = (x < -1.0) ? 0.0 : (x > 1.0) ? 0.0: ((pi2x * sin(pi2x) + cos(pi2x) - M_PI_2)/M_PI); return(z); } /* optcosine, partial second moment */ double m2TEMoptcosine(double x) { double z, pi2x; pi2x = M_PI_2 * x; z = (x < -1.0) ? 0.0 : (x > 1.0) ? TEMPLATE_VARIANCE(optcosine): ((2.0/(M_PI * M_PI)) * ( (pi2x * pi2x - 2.0) * sin(pi2x) + 2 * pi2x * cos(pi2x) + M_PI_2 * M_PI_2 - 2.0 ) ); return(z); } /* >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> D E R I V E D F U N C T I O N S <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< */ #define TEMPLATE_PDF(KERNEL) dTEM ## KERNEL #define TEMPLATE_CDF(KERNEL) pTEM ## KERNEL #define TEMPLATE_FIRST(KERNEL) m1TEM ## KERNEL #define TEMPLATE_SECOND(KERNEL) m2TEM ## KERNEL #define GENERAL_PDF(KERNEL) d ## KERNEL #define GENERAL_CDF(KERNEL) p ## KERNEL #define GENERAL_FIRST(KERNEL) m1 ## KERNEL #define GENERAL_SECOND(KERNEL) m2 ## KERNEL #define GENERAL_BDRYKERN(KERNEL) b ## KERNEL /* Define probability densities, for general mean and standard deviation */ /* Gaussian density is a special case */ double dgaussian(double x, double mean, double sd) { double fx; fx = dnorm(x, mean, sd, (int) 0); return(fx); } /* define drectangular, dtriangular etc */ #define DEFINE_GENERAL_PDF(KERNEL) \ double GENERAL_PDF(KERNEL)(double x, double mean, double sd) { \ double h, y, fx; \ h = sd * HALFWIDTH_ON_SIGMA(KERNEL); \ y = (x - mean)/h; \ fx = TEMPLATE_PDF(KERNEL)(y)/h; \ return(fx); \ } DEFINE_GENERAL_PDF(rectangular) DEFINE_GENERAL_PDF(triangular) DEFINE_GENERAL_PDF(epanechnikov) DEFINE_GENERAL_PDF(biweight) DEFINE_GENERAL_PDF(cosine) DEFINE_GENERAL_PDF(optcosine) /* Cumulative distribution functions */ /* Gaussian CDF is special case */ double pgaussian(double x, double mean, double sd) { double Fx; Fx = pnorm(x, mean, sd, (int) 1, (int) 0); return(Fx); } /* define prectangular, ptriangular etc */ #define DEFINE_GENERAL_CDF(KERNEL) \ double GENERAL_CDF(KERNEL)(double x, double mean, double sd) { \ double h, y, Fx; \ h = sd * HALFWIDTH_ON_SIGMA(KERNEL) ; \ y = (x - mean)/h; \ Fx = TEMPLATE_CDF(KERNEL)(y); \ return(Fx); \ } DEFINE_GENERAL_CDF(rectangular) DEFINE_GENERAL_CDF(triangular) DEFINE_GENERAL_CDF(epanechnikov) DEFINE_GENERAL_CDF(biweight) DEFINE_GENERAL_CDF(cosine) DEFINE_GENERAL_CDF(optcosine) /* ----------- PARTIAL MOMENTS -------------------- */ /* The partial moment of order m is the function a_m(x) = \int_{-\infty}^x t^m f(t) dt where f is the probability density. */ /* Partial first moments for general case */ #define DEFINE_GENERAL_FIRST(KERNEL) \ double GENERAL_FIRST(KERNEL)(double x, double mean, double sd) { \ double h, y, z; \ h = sd * HALFWIDTH_ON_SIGMA(KERNEL); \ y = (x - mean)/h; \ z = mean * TEMPLATE_CDF(KERNEL)(y) + h * TEMPLATE_FIRST(KERNEL)(y); \ return(z); \ } DEFINE_GENERAL_FIRST(gaussian) DEFINE_GENERAL_FIRST(rectangular) DEFINE_GENERAL_FIRST(triangular) DEFINE_GENERAL_FIRST(epanechnikov) DEFINE_GENERAL_FIRST(biweight) DEFINE_GENERAL_FIRST(cosine) DEFINE_GENERAL_FIRST(optcosine) /* Partial second moments for general case */ #define DEFINE_GENERAL_SECOND(KERNEL) \ double GENERAL_SECOND(KERNEL)(double x, double mean, double sd) { \ double h, y, z; \ h = sd * HALFWIDTH_ON_SIGMA(KERNEL); \ y = (x - mean)/h; \ z = mean * mean * TEMPLATE_CDF(KERNEL)(y) + \ 2 * mean * h * TEMPLATE_FIRST(KERNEL)(y) + \ h * h * TEMPLATE_SECOND(KERNEL)(y); \ return(z); \ } DEFINE_GENERAL_SECOND(gaussian) DEFINE_GENERAL_SECOND(rectangular) DEFINE_GENERAL_SECOND(triangular) DEFINE_GENERAL_SECOND(epanechnikov) DEFINE_GENERAL_SECOND(biweight) DEFINE_GENERAL_SECOND(cosine) DEFINE_GENERAL_SECOND(optcosine) /* ------- LINEAR BOUNDARY KERNELS ---------------- */ /* query point = x, data point = mean */ #define DEFINE_GENERAL_BDRYKERN(KERNEL) \ double GENERAL_BDRYKERN(KERNEL)(double x, double mean, double sd) { \ double h, p, u, a0, a1, a2, fy; \ fy = GENERAL_PDF(KERNEL)(x, mean, sd); \ if(fy == 0.0) return(0.0); \ h = HALFWIDTH_ON_SIGMA(KERNEL) * sd; \ p = x/h; \ u = (x-mean)/h; \ a0 = TEMPLATE_CDF(KERNEL)(p); \ a1 = TEMPLATE_FIRST(KERNEL)(p); \ a2 = TEMPLATE_SECOND(KERNEL)(p); \ fy *= (a2 - a1 * u)/(a0 * a2 - a1 * a1); \ return(fy); \ } DEFINE_GENERAL_BDRYKERN(gaussian) DEFINE_GENERAL_BDRYKERN(rectangular) DEFINE_GENERAL_BDRYKERN(triangular) DEFINE_GENERAL_BDRYKERN(epanechnikov) DEFINE_GENERAL_BDRYKERN(biweight) DEFINE_GENERAL_BDRYKERN(cosine) DEFINE_GENERAL_BDRYKERN(optcosine) spatstat.univar/src/adaptive.c0000644000176200001440000000144614710326734016164 0ustar liggesusers/* adaptive.c Adaptive kernel density estimation, brute force, arbitrary weights, boundary correction Copyright (c) 2008-2024 Adrian Baddeley, Tilman Davies and Martin Hazelton GNU Public Licence (>= 2.0) */ #include "kernels.h" #include "interfacecodes.h" #define FNAME adaptiveKDE #define ZEROCOR NONE #include "adaptive.h" #undef FNAME #undef ZEROCOR #define FNAME adaptKDEweight #define ZEROCOR WEIGHTED #include "adaptive.h" #undef FNAME #undef ZEROCOR #define FNAME adaptKDEreflect #define ZEROCOR REFLECTION #include "adaptive.h" #undef FNAME #undef ZEROCOR #define FNAME adaptKDEconvol #define ZEROCOR CONVOLUTION #include "adaptive.h" #undef FNAME #undef ZEROCOR #define FNAME adaptKDEbdry #define ZEROCOR BDRYKERNEL #include "adaptive.h" #undef FNAME #undef ZEROCOR spatstat.univar/src/proto.h0000644000176200001440000000311214756455575015547 0ustar liggesusers#include #include /* Prototype declarations for all native routines in spatstat.univar package Automatically generated - do not edit! */ /* Functions invoked by .C */ void kermom(int *, double *, double *, double *, int *, int *, double *, int *); void adaptiveKDE(int *, int *, double *, double *, double *, int *, double *, double *, int *); void adaptKDEweight(int *, int *, double *, double *, double *, int *, double *, double *, int *); void adaptKDEreflect(int *, int *, double *, double *, double *, int *, double *, double *, int *); void adaptKDEconvol(int *, int *, double *, double *, double *, int *, double *, double *, int *); void adaptKDEbdry(int *, int *, double *, double *, double *, int *, double *, double *, int *); void taylorboot(double *, int *, double *, int *, double *); void fcolonel(int *, int *, double *, double *, int *, double *, double *, int *); void colonel(int *, int *, double *, double *, int *, double *, double *, int *); void fbcolonel(int *, int *, double *, double *, int *, double *, double *, double *, double *, double *, double *, double *, int *); void bcolonel(int *, int *, double *, double *, int *, double *, double *, double *, double *, double *, double *, double *, int *); void tabsumweight(int *, double *, double *, int *, double *, double *); void hotrodInsul(int *, double *, double *, double *, double *, int *, double *); void hotrodAbsorb(int *, double *, double *, double *, double *, int *, double *); /* Functions invoked by .Call */ SEXP Cwhist(SEXP, SEXP, SEXP); spatstat.univar/src/interfacecodes.h0000644000176200001440000000132214710326734017343 0ustar liggesusers/* interfacecodes.h Numerical codes for the interface between R and C Copyright (c) 2008-2024 Adrian Baddeley, Tilman Davies and Martin Hazelton GNU Public Licence (>= 2.0) */ /* kernel codes */ #define GAUSSIAN 1 #define RECTANGULAR 2 #define TRIANGULAR 3 #define EPANECHNIKOV 4 #define BIWEIGHT 5 #define COSINE 6 #define OPTCOSINE 7 /* error codes */ #define OK 0 #define ERR_NEGATIVE_LENGTH 1 #define ERR_UNKNOWN_KERNEL 2 #define NOT_SUPPORTED 3 /* codes for zero boundary correction (density on positive half-line) */ #define NONE 0 #define WEIGHTED 1 #define CONVOLUTION 2 #define REFLECTION 3 #define BDRYKERNEL 4 spatstat.univar/src/init.c0000644000176200001440000000271014756455575015345 0ustar liggesusers /* Native symbol registration table for spatstat.univar package Automatically generated - do not edit this file! */ #include "proto.h" #include #include #include // for NULL #include /* See proto.h for declarations for the native routines registered below. */ static const R_CMethodDef CEntries[] = { {"adaptiveKDE", (DL_FUNC) &adaptiveKDE, 9}, {"adaptKDEbdry", (DL_FUNC) &adaptKDEbdry, 9}, {"adaptKDEconvol", (DL_FUNC) &adaptKDEconvol, 9}, {"adaptKDEreflect", (DL_FUNC) &adaptKDEreflect, 9}, {"adaptKDEweight", (DL_FUNC) &adaptKDEweight, 9}, {"bcolonel", (DL_FUNC) &bcolonel, 13}, {"colonel", (DL_FUNC) &colonel, 8}, {"fbcolonel", (DL_FUNC) &fbcolonel, 13}, {"fcolonel", (DL_FUNC) &fcolonel, 8}, {"hotrodAbsorb", (DL_FUNC) &hotrodAbsorb, 7}, {"hotrodInsul", (DL_FUNC) &hotrodInsul, 7}, {"kermom", (DL_FUNC) &kermom, 8}, {"tabsumweight", (DL_FUNC) &tabsumweight, 6}, {"taylorboot", (DL_FUNC) &taylorboot, 5}, {NULL, NULL, 0} }; static const R_CallMethodDef CallEntries[] = { {"Cwhist", (DL_FUNC) &Cwhist, 3}, {NULL, NULL, 0} }; void R_init_spatstat_univar(DllInfo *dll) { R_registerRoutines(dll, CEntries, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); R_forceSymbols(dll, TRUE); } spatstat.univar/src/tabnum.c0000755000176200001440000000250714632773657015674 0ustar liggesusers/* tabnum.c table(x) or tapply(x, w, sum) where x is numeric and we are given the sorted unique values $Revision: 1.5 $ $Date: 2022/10/22 02:32:10 $ */ #include #include #include "chunkloop.h" void tabnum( int *nx, double *x, /* values (sorted) */ int *nv, double *v, /* unique values (sorted) */ double *z /* output */ ) { int i, j, Nx, Nv, maxchunk; double xi; Nx = *nx; Nv = *nv; j = 0; OUTERCHUNKLOOP(i, Nx, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, Nx, maxchunk, 16384) { xi = x[i]; /* Find the smallest v[j] greater than or equal to x[i] */ for( ; j < Nv && xi > v[j]; j++) ; /* increment */ if(j < Nv) z[j] += 1.0; } } } void tabsumweight( int *nx, double *x, /* values */ double *w, /* weights */ int *nv, double *v, /* unique values (sorted) */ double *z /* output */ ) { int i, j, Nx, Nv, maxchunk; double xi; Nx = *nx; Nv = *nv; j = 0; OUTERCHUNKLOOP(i, Nx, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, Nx, maxchunk, 16384) { xi = x[i]; /* Find the smallest v[j] greater than or equal to x[i] */ for(; j < Nv && xi > v[j]; j++) ; /* add weight */ if(j < Nv) z[j] += w[i]; } } } spatstat.univar/src/whist.c0000755000176200001440000000207714632773657015546 0ustar liggesusers/* whist.c Weighted histogram Designed for very fine bins Cwhist(indices, weights, nbins) indices point to bins (range: 0 to nbins-1) $Revision: 1.6 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #include #include #include SEXP Cwhist(SEXP indices, SEXP weights, SEXP nbins) { int i, j, N, M; int *x; double *w, *y; SEXP result; /* =================== Protect R objects from garbage collector ======= */ PROTECT(indices = AS_INTEGER(indices)); PROTECT(weights = AS_NUMERIC(weights)); PROTECT(nbins = AS_INTEGER(nbins)); N = LENGTH(indices); M = *(INTEGER_POINTER(nbins)); x = INTEGER_POINTER(indices); w = NUMERIC_POINTER(weights); PROTECT(result = NEW_NUMERIC(M)); y = NUMERIC_POINTER(result); for(j = 0; j < M; j++) y[j] = 0.0; for(i = 0; i < N; i++) { j = x[i]; if(j != NA_INTEGER && R_FINITE(w[i]) && j >= 0 && j < M) y[j] += w[i]; } UNPROTECT(4); return(result); } spatstat.univar/src/colonel.c0000644000176200001440000005233714712311773016026 0ustar liggesusers/* colonel.c Kernel density estimation, fixed bandwidth, with weights and (optional) linear boundary correction Brute force algorithm: colonel() kernel estimate, uncorrected bcolonel() kernel estimate, linear boundary correction at zero Faster algorithm for equally-spaced 'r' values: fcolonel() kernel estimate, uncorrected fbcolonel() kernel estimate, linear boundary correction at zero Data assumed to be rescaled so that kernel has halfwidth = 1 This code does not call the self-contained kernel functions defined in 'kernels.c'. Instead the kernels are coded in-line. This implementation is slightly faster for large datasets, as it avoids repeated function calls and it makes some efficiencies. However, it requires pre-scaling of the data. Copyright (c) 2008-2024 Adrian Baddeley, Tilman Davies and Martin Hazelton GNU Public Licence (>= 2.0) */ #include #include "kerconstants.h" #include "interfacecodes.h" #define PI M_PI #define TWO_PI M_2PI #define HALF_PI M_PI_2 #define QUARTER_PI M_PI_4 #define RECIPROCAL_SQRT_TWO_PI M_1_SQRT_2PI double sqrt(double), exp(double), cos(double); #define ABS(X) (((X) < 0) ? (-(X)) : (X)) #define INSIDE(X) (((X) >= -1) && ((X) <= 1)) #define GAUSSTHRESH ((double) 8.0) void colonel( int *kerncode, /* integer code for kernel */ int *nx, /* number of data values */ double *x, /* vector of data values */ double *w, /* vector of weights for data */ int *nr, /* number of r values */ double *r, /* vector of r values (argument of density) */ double *f, /* vector of values of density estimate f(r) */ int *errcode) /* integer code for errors */ { int i, j, Nx, Nr, bb; double xi, wi, uij, temp, kvalue, root2pi; /* extract arguments and validate */ Nx = *nx; Nr = *nr; *errcode = OK; if(Nx < 0 || Nr <= 0) { *errcode = ERR_NEGATIVE_LENGTH; return; } /* initialise f(r) */ for(j = 0; j < Nr; j++) f[j] = 0.0; if(Nx == 0) return; /* go */ if(*kerncode == GAUSSIAN) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < Nr; j++) { uij = xi - r[j]; kvalue = exp(- uij * uij/2); f[j] += kvalue * wi; } } /* divide by constant factor */ for(j = 0; j < Nr; j++) f[j] *= RECIPROCAL_SQRT_TWO_PI; return; } else if(*kerncode == RECTANGULAR) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < Nr; j++) { uij = xi - r[j]; if(ABS(uij) < 1.0) f[j] += wi; } } /* divide by constant factor */ for(j = 0; j < Nr; j++) f[j] /= 2.0; return; } else if(*kerncode == TRIANGULAR) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < Nr; j++) { uij = xi - r[j]; kvalue = 1.0 - ABS(uij); if(kvalue > 0) f[j] += kvalue * wi; } } /* no constant factor */ return; } else if(*kerncode == EPANECHNIKOV) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < Nr; j++) { uij = xi - r[j]; kvalue = (1.0 - uij * uij); if(kvalue > 0) f[j] += kvalue * wi; } } /* multiply by constant factor */ for(j = 0; j < Nr; j++) f[j] *= 3.0/4.0; return; } else if(*kerncode == BIWEIGHT) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < Nr; j++) { uij = xi - r[j]; temp = (1 - uij * uij); if(temp > 0) { kvalue = temp * temp; f[j] += kvalue * wi; } } } /* multiply by constant factor */ for(j = 0; j < Nr; j++) f[j] *= 15.0/16.0; return; } else if(*kerncode == COSINE) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < Nr; j++) { uij = xi - r[j]; uij = ABS(uij); if(uij < 1.0) { kvalue = 1.0 + cos(PI * uij); f[j] += kvalue * wi; } } } /* divide by constant factor */ for(j = 0; j < Nr; j++) f[j] /= 2.0; return; } else if(*kerncode == OPTCOSINE) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < Nr; j++) { uij = xi - r[j]; uij = ABS(uij); if(uij < 1.0) { kvalue = cos(uij * HALF_PI); f[j] += kvalue * wi; } } } /* multiply by constant factor */ for(j = 0; j < Nr; j++) f[j] *= QUARTER_PI; return; } else { /* unrecognised kernel */ *errcode = ERR_UNKNOWN_KERNEL; return; } } /* ...................................................................... fcolonel() Faster version of colonel() for equally-spaced 'r' values ...................................................................... */ void fcolonel( int *kerncode, /* integer code for kernel */ int *nx, /* number of data values */ double *x, /* vector of data values */ double *w, /* vector of weights for data */ int *nr, /* number of r values */ double *r, /* vector of r values (argument of density) */ double *f, /* vector of values of density estimate f(r) */ int *errcode) /* integer code for errors */ { int i, j, k, Nx, Nr, bb; double dr, xi, wi, vij, temp, kvalue, root2pi; /* extract arguments and validate */ Nx = *nx; Nr = *nr; *errcode = OK; if(Nx < 0 || Nr <= 0) { *errcode = ERR_NEGATIVE_LENGTH; return; } /* spacing between 'r' values */ dr = r[Nr-1]/((double) Nr); /* initialise f(r) */ for(j = 0; j < Nr; j++) f[j] = 0.0; if(Nx == 0) return; /* go */ if(*kerncode == GAUSSIAN) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; k = floor((xi - GAUSSTHRESH)/dr); /* r[k] is 8 std. dev. below x[i] */ if(k < 0) k = 0; if(k < Nr) { for(j = k; j < Nr; j++) { vij = r[j] - xi; if(vij > GAUSSTHRESH) break; /* r[j] is 8 std. dev. above x[i] */ kvalue = exp(- vij * vij/2); f[j] += kvalue * wi; } } } /* divide by constant factor */ for(j = 0; j < Nr; j++) f[j] *= RECIPROCAL_SQRT_TWO_PI; return; } else if(*kerncode == RECTANGULAR) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; k = floor((xi - (double) 1.0)/dr); /* r[k] is 1 halfwidth below x[i] */ if(k < 0) k = 0; if(k < Nr) { for(j = k; j < Nr; j++) { vij = r[j] - xi; if(vij > 1.0) break; /* r[j] is 1 halfwidth above x[i] */ if(vij > -1.0) f[j] += wi; } } } /* divide by constant factor */ for(j = 0; j < Nr; j++) f[j] /= 2.0; return; } else if(*kerncode == TRIANGULAR) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; k = floor((xi - (double) 1.0)/dr); /* r[k] is 1 halfwidth below x[i] */ if(k < 0) k = 0; if(k < Nr) { for(j = k; j < Nr; j++) { vij = r[j] - xi; if(vij > 1.0) break; /* r[j] is 1 halfwidth above x[i] */ kvalue = 1.0 - ABS(vij); if(kvalue > 0) f[j] += kvalue * wi; } } } /* no constant factor */ return; } else if(*kerncode == EPANECHNIKOV) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; k = floor((xi - (double) 1.0)/dr); /* r[k] is 1 halfwidth below x[i] */ if(k < 0) k = 0; if(k < Nr) { for(j = k; j < Nr; j++) { vij = r[j] - xi; if(vij > 1.0) break; /* r[j] is 1 halfwidth above x[i] */ kvalue = (1.0 - vij * vij); if(kvalue > 0) f[j] += kvalue * wi; } } } /* multiply by constant factor */ for(j = 0; j < Nr; j++) f[j] *= 3.0/4.0; return; } else if(*kerncode == BIWEIGHT) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; k = floor((xi - (double) 1.0)/dr); /* r[k] is 1 halfwidth below x[i] */ if(k < 0) k = 0; if(k < Nr) { for(j = k; j < Nr; j++) { vij = r[j] - xi; if(vij > 1.0) break; /* r[j] is 1 halfwidth above x[i] */ temp = (1 - vij * vij); if(temp > 0.0) { kvalue = temp * temp; f[j] += kvalue * wi; } } } } /* multiply by constant factor */ for(j = 0; j < Nr; j++) f[j] *= 15.0/16.0; return; } else if(*kerncode == COSINE) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; k = floor((xi - (double) 1.0)/dr); /* r[k] is 1 halfwidth below x[i] */ if(k < 0) k = 0; if(k < Nr) { for(j = k; j < Nr; j++) { vij = r[j] - xi; if(vij > 1.0) break; /* r[j] is 1 halfwidth above x[i] */ if(vij > -1.0) { kvalue = 1.0 + cos(PI * vij); f[j] += kvalue * wi; } } } } /* divide by constant factor */ for(j = 0; j < Nr; j++) f[j] /= 2.0; return; } else if(*kerncode == OPTCOSINE) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; k = floor((xi - (double) 1.0)/dr); /* r[k] is 1 halfwidth below x[i] */ if(k < 0) k = 0; if(k < Nr) { for(j = k; j < Nr; j++) { vij = r[j] - xi; if(vij > 1.0) break; /* r[j] is 1 halfwidth above x[i] */ vij = ABS(vij); if(vij < 1.0) { kvalue = cos(vij * HALF_PI); f[j] += kvalue * wi; } } } } /* multiply by constant factor */ for(j = 0; j < Nr; j++) f[j] *= QUARTER_PI; return; } else { /* unrecognised kernel */ *errcode = ERR_UNKNOWN_KERNEL; return; } } /* ...................................................................... bcolonel() kernel density estimate with linear boundary correction at zero ...................................................................... */ void bcolonel( int *kerncode, /* integer code for kernel */ int *nx, /* number of data values */ double *x, /* vector of data values */ double *w, /* vector of weights for data */ int *nr, /* number of r values */ double *r, /* vector of r values (argument of density) */ double *nu0, /* values of integral of kernel from -Inf to r */ double *nu1, /* values of integral of s k(s) from -Inf to r */ double *nu2, /* values of integral of s^2 k(s) from -Inf to r */ double *a, /* scratch space */ double *b, /* scratch space */ double *f, /* output values of density estimate f(r) */ int *errcode) /* output integer code for errors */ { int i, j, Nx, Nr, bb, jbdry; double xi, wi, uij; double kvalue, denomj, temp, thresh, root2pi; /* extract arguments and validate */ Nx = *nx; Nr = *nr; *errcode = OK; if(Nx < 0 || Nr <= 0) { *errcode = ERR_NEGATIVE_LENGTH; return; } /* initialise f(r) */ for(j = 0; j < Nr; j++) f[j] = 0.0; if(Nx == 0) return; /* compute coefficients a(r) and b(r) for boundary kernel */ for(j = 0; j < Nr; j++) { denomj = nu0[j] * nu2[j] - nu1[j] * nu1[j]; a[j] = nu2[j]/denomj; b[j] = nu1[j]/denomj; } /* determine jbdry (index of smallest r value outside support of kernel) */ thresh = (*kerncode == GAUSSIAN) ? 3.0 : 1.0; for(jbdry = 0; jbdry < Nr; jbdry++) if(r[jbdry] > thresh) break; /* go */ if(*kerncode == GAUSSIAN) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; kvalue = exp(- uij * uij/2); kvalue *= a[j] - b[j] * uij; f[j] += kvalue * wi; } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; kvalue = exp(- uij * uij/2); f[j] += kvalue * wi; } } /* divide by constant factor */ for(j = 0; j < Nr; j++) f[j] *= RECIPROCAL_SQRT_TWO_PI; return; } else if(*kerncode == RECTANGULAR) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = a[j] - b[j] * uij; f[j] += kvalue * wi; } } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(INSIDE(uij)) f[j] += wi; } } /* divide by constant factor */ for(j = 0; j < Nr; j++) f[j] /= 2.0; return; } else if(*kerncode == TRIANGULAR) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = 1.0 - ABS(uij); kvalue *= a[j] - b[j] * uij; f[j] += kvalue * wi; } } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = 1.0 - ABS(uij); f[j] += kvalue * wi; } } } /* no constant factor */ return; } else if(*kerncode == EPANECHNIKOV) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = (1 - uij * uij); if(kvalue > 0) { kvalue *= a[j] - b[j] * uij; f[j] += kvalue * wi; } } } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = (1 - uij * uij); if(kvalue > 0) f[j] += kvalue * wi; } } } /* multiply by constant factor */ for(j = 0; j < Nr; j++) f[j] *= 3.0/4.0; return; } else if(*kerncode == BIWEIGHT) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; if(INSIDE(uij)) { temp = (1 - uij * uij); kvalue = temp * temp; kvalue *= a[j] - b[j] * uij; f[j] += kvalue * wi; } } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(INSIDE(uij)) { temp = (1 - uij * uij); kvalue = temp * temp; f[j] += kvalue * wi; } } } /* multiply by constant factor */ for(j = 0; j < Nr; j++) f[j] *= 15.0/16.0; return; } else if(*kerncode == COSINE) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = 1.0 + cos(PI * uij); kvalue *= a[j] - b[j] * uij; f[j] += kvalue * wi; } } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = 1.0 + cos(PI * uij); f[j] += kvalue * wi; } } } /* divide by constant factor */ for(j = 0; j < Nr; j++) f[j] /= 2.0; return; } else if(*kerncode == OPTCOSINE) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = cos(uij * HALF_PI); kvalue *= a[j] - b[j] * uij; f[j] += kvalue * wi; } } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = cos(uij * HALF_PI); f[j] += kvalue * wi; } } } /* multiply by constant factor */ for(j = 0; j < Nr; j++) f[j] *= QUARTER_PI; return; } else { /* unrecognised kernel */ *errcode = ERR_UNKNOWN_KERNEL; return; } } /* ...................................................................... fbcolonel() Faster version of bcolonel() ...................................................................... */ void fbcolonel( int *kerncode, /* integer code for kernel */ int *nx, /* number of data values */ double *x, /* vector of data values */ double *w, /* vector of weights for data */ int *nr, /* number of r values */ double *r, /* vector of r values (argument of density) */ double *nu0, /* values of integral of kernel from -Inf to r */ double *nu1, /* values of integral of s k(s) from -Inf to r */ double *nu2, /* values of integral of s^2 k(s) from -Inf to r */ double *a, /* scratch space */ double *b, /* scratch space */ double *f, /* output values of density estimate f(r) */ int *errcode) /* output integer code for errors */ { int i, j, Nx, Nr, bb, jbdry, jupperi; double xi, wi, uij; double kvalue, denomj, temp, thresh, root2pi; /* extract arguments and validate */ Nx = *nx; Nr = *nr; *errcode = OK; if(Nx < 0 || Nr <= 0) { *errcode = ERR_NEGATIVE_LENGTH; return; } /* initialise f(r) */ for(j = 0; j < Nr; j++) f[j] = 0.0; if(Nx == 0) return; /* compute coefficients a(r) and b(r) for boundary kernel */ for(j = 0; j < Nr; j++) { denomj = nu0[j] * nu2[j] - nu1[j] * nu1[j]; a[j] = nu2[j]/denomj; b[j] = nu1[j]/denomj; } /* index of smallest r value outside support of kernel centred at zero */ thresh = (*kerncode == GAUSSIAN) ? GAUSSTHRESH : 1.0; for(jbdry = 0; jbdry < Nr; jbdry++) if(r[jbdry] > thresh) break; /* go */ if(*kerncode == GAUSSIAN) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; kvalue = exp(- uij * uij/2); kvalue *= a[j] - b[j] * uij; f[j] += kvalue * wi; } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(uij > GAUSSTHRESH) break; /* r[j] exceeds 8 sd above x[i] */ kvalue = exp(- uij * uij/2); f[j] += kvalue * wi; } } /* divide by constant factor */ for(j = 0; j < Nr; j++) f[j] *= RECIPROCAL_SQRT_TWO_PI; return; } else if(*kerncode == RECTANGULAR) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = a[j] - b[j] * uij; f[j] += kvalue * wi; } } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(uij > 1.0) break; /* r[j] exceeds 1 halfwidth above x[i] */ if(uij > -1.0) f[j] += wi; } } /* divide by constant factor */ for(j = 0; j < Nr; j++) f[j] /= 2.0; return; } else if(*kerncode == TRIANGULAR) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = 1.0 - ABS(uij); kvalue *= a[j] - b[j] * uij; f[j] += kvalue * wi; } } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(uij > 1.0) break; /* r[j] exceeds 1 halfwidth above x[i] */ if(uij > -1.0) { kvalue = 1.0 - ABS(uij); f[j] += kvalue * wi; } } } /* no constant factor */ return; } else if(*kerncode == EPANECHNIKOV) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = (1 - uij * uij); if(kvalue > 0) { kvalue *= a[j] - b[j] * uij; f[j] += kvalue * wi; } } } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(uij > 1.0) break; /* r[j] exceeds 1 halfwidth above x[i] */ if(uij > -1.0) { kvalue = (1 - uij * uij); if(kvalue > 0) f[j] += kvalue * wi; } } } /* multiply by constant factor */ for(j = 0; j < Nr; j++) f[j] *= 3.0/4.0; return; } else if(*kerncode == BIWEIGHT) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; if(INSIDE(uij)) { temp = (1 - uij * uij); kvalue = temp * temp; kvalue *= a[j] - b[j] * uij; f[j] += kvalue * wi; } } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(uij > 1.0) break; /* r[j] exceeds 1 halfwidth above x[i] */ if(uij > -1.0) { temp = (1 - uij * uij); if(temp > 0.0) { kvalue = temp * temp; f[j] += kvalue * wi; } } } } /* multiply by constant factor */ for(j = 0; j < Nr; j++) f[j] *= 15.0/16.0; return; } else if(*kerncode == COSINE) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = 1.0 + cos(PI * uij); kvalue *= a[j] - b[j] * uij; f[j] += kvalue * wi; } } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(uij > 1.0) break; /* r[j] exceeds 1 halfwidth above x[i] */ if(uij > -1.0) { kvalue = 1.0 + cos(PI * uij); f[j] += kvalue * wi; } } } /* divide by constant factor */ for(j = 0; j < Nr; j++) f[j] /= 2.0; return; } else if(*kerncode == OPTCOSINE) { /* sum contributions */ for(i = 0; i < Nx; i++) { xi = x[i]; wi = w[i]; for(j = 0; j < jbdry; j++) { uij = r[j] - xi; if(INSIDE(uij)) { kvalue = cos(uij * HALF_PI); kvalue *= a[j] - b[j] * uij; f[j] += kvalue * wi; } } for(j = jbdry; j < Nr; j++) { uij = r[j] - xi; if(uij > 1.0) break; /* r[j] exceeds 1 halfwidth above x[i] */ if(uij > -1.0) { kvalue = cos(uij * HALF_PI); f[j] += kvalue * wi; } } } /* multiply by constant factor */ for(j = 0; j < Nr; j++) f[j] *= QUARTER_PI; return; } else { /* unrecognised kernel */ *errcode = ERR_UNKNOWN_KERNEL; return; } } spatstat.univar/src/kerconstants.h0000644000176200001440000000326114710326734017107 0ustar liggesusers/* kerconstants.h Constants for smoothing kernels Terminology: template kernel: kernel with mean 0, halfwidth 1 standard kernel: kernel with mean 0, standard deviation 1 KFAC_XXX: ratio of halfwidth to standard deviation TVAR_XXX: variance of template kernel For densities with compact support (namely all except the Gaussian) the halfwidth 'h' is half the width of the support. The halfwidth is proportional to the standard deviation, h = c. sigma where 'c' is the constant 'KFAC' defined below. For the Gaussian density, h=sigma and c=1 by convention. The constants 'TVAR' give the variance of the template kernel. The variance of the kernel with halfwidth h is TVAR * h^2 The variance of the standard kernel is TVAR * KFACTOR^2. The variance of the kernel with standard deviation sigma is TVAR * sigma^2 * KFACTOR^2 Copyright (c) 2008-2024 Adrian Baddeley, Tilman Davies and Martin Hazelton GNU Public Licence (>= 2.0) */ #define KFAC_gaussian 1.0 #define KFAC_rectangular sqrt(3.0) #define KFAC_triangular sqrt(6.0) #define KFAC_epanechnikov sqrt(5.0) #define KFAC_biweight sqrt(7.0) #define KFAC_cosine (1.0/sqrt(1.0/3 - 2.0/(M_PI * M_PI))) #define KFAC_optcosine (1.0/sqrt(1.0 - 8.0/(M_PI * M_PI))) #define TVAR_gaussian 1.0 #define TVAR_rectangular (1.0/3) #define TVAR_triangular (1.0/6) #define TVAR_epanechnikov (1.0/5) #define TVAR_biweight (1.0/7) #define TVAR_cosine (1.0/3 - 2.0/(M_PI * M_PI)) #define TVAR_optcosine (1.0 - 8.0/(M_PI * M_PI)) #define HALFWIDTH_ON_SIGMA(KERNELNAME) KFAC_ ## KERNELNAME #define TEMPLATE_VARIANCE(KERNELNAME) TVAR_ ## KERNELNAME spatstat.univar/src/hotrod.c0000755000176200001440000000405114632773657015701 0ustar liggesusers/* hotrod.c Heat kernel on a one-dimensional rod with either insulated ends or absorbing ends Copyright (c) Greg McSwiggan and Adrian Baddeley 2017-2020 $Revision: 1.2 $ $Date: 2022/10/21 10:43:01 $ */ #include #include void hotrodInsul( int *n, /* number of calculations (length of each vector) */ double *a, /* rod length */ double *x, /* source position */ double *y, /* query position */ double *s, /* bandwidth */ int *m, /* number of terms in sum */ double *z /* result */ ) { register int i, k, N, M; register double Z, A, twoA, Bk, X, Y, sigma; N = *n; M = *m; for(i = 0; i < N; i++) { sigma = s[i]; A = a[i]; if(A <= 0.0 || sigma <= 0.0) { /* trap bad data */ z[i] = 0.0; } else if(sigma > 20.0 * A) { /* uniform density */ z[i] = 1/A; } else { /* do calculation */ X = x[i]; Y = y[i]; Z = 0.0; twoA = 2.0 * A; for(k = -M; k <= M; k++) { Bk = k * twoA; Z += dnorm( Bk + Y, X, sigma, (int) 0); Z += dnorm( Bk - Y, X, sigma, (int) 0); } z[i] = Z; } } } void hotrodAbsorb( int *n, /* number of calculations (length of each vector) */ double *a, /* rod length */ double *x, /* source position */ double *y, /* query position */ double *s, /* bandwidth */ int *m, /* number of terms in sum */ double *z /* result */ ) { register int i, k, N, M; register double Z, A, X, Y, sigma, pionL, piXonL, piYonL, fac; N = *n; M = *m; for(i = 0; i < N; i++) { sigma = s[i]; A = a[i]; if(A <= 0.0 || sigma <= 0.0 || sigma > 20.0 * A) { z[i] = 0.0; } else { /* do calculation */ pionL = M_PI/A; fac = pionL * pionL * sigma * sigma/2.0; X = x[i]; Y = y[i]; piXonL = pionL * X; piYonL = pionL * Y; Z = 0.0; for(k = 1; k <= M; k++) { Z += exp(-fac * k * k) * sin(k * piXonL) * sin(k * piYonL); } Z *= 2.0/A; z[i] = Z; } } } spatstat.univar/src/adaptive.h0000644000176200001440000000470314710326734016170 0ustar liggesusers/* adaptive.h Adaptive kernel density estimation, brute force, arbitrary weights, optional boundary correction for positive data This file is #included multiple times in adaptive.c using different values of the macro 'ZEROCOR' values of ZEROCOR: NONE no correction WEIGHTED weighting boundary correction CONVOLUTION convolution boundary correction REFLECTION reflection boundary correction BDRYKERNEL boundary kernel Copyright (c) 2008-2024 Adrian Baddeley, Tilman Davies and Martin Hazelton GNU Public Licence (>= 2.0) */ void FNAME( int *kerncode, /* integer code for kernel */ int *nx, /* number of data values */ double *x, /* vector of data values */ double *sd, /* vector of kernel bandwidths for data */ double *w, /* vector of weights for data */ int *nr, /* number of r values */ double *r, /* vector of r values (argument of density) */ double *f, /* resulting values of density estimate f(r) */ int *errcode) /* integer code for errors */ { int i, j, Nx, Nr; double xi, si, wi, rj, kvalue; #if (ZEROCOR == WEIGHTED) double kmass; #endif /* extract arguments and validate */ Nx = *nx; Nr = *nr; *errcode = OK; if(Nx < 0 || Nr <= 0) { *errcode = ERR_NEGATIVE_LENGTH; return; } /* initialise f(r) */ for(j = 0; j < Nr; j++) f[j] = 0.0; if(Nx == 0) return; /* go */ if(*kerncode == GAUSSIAN) { #undef KERNELNAME #define KERNELNAME gaussian #include "adaptiveloop.h" return; } else if(*kerncode == RECTANGULAR) { #undef KERNELNAME #define KERNELNAME rectangular #include "adaptiveloop.h" return; } else if(*kerncode == TRIANGULAR) { #undef KERNELNAME #define KERNELNAME triangular #include "adaptiveloop.h" return; } else if(*kerncode == EPANECHNIKOV) { #undef KERNELNAME #define KERNELNAME epanechnikov #include "adaptiveloop.h" return; } else if(*kerncode == BIWEIGHT) { #undef KERNELNAME #define KERNELNAME biweight #include "adaptiveloop.h" return; } else if(*kerncode == COSINE) { #undef KERNELNAME #define KERNELNAME cosine #include "adaptiveloop.h" return; } else if(*kerncode == OPTCOSINE) { #undef KERNELNAME #define KERNELNAME optcosine #include "adaptiveloop.h" return; } else { /* unrecognised kernel */ *errcode = ERR_UNKNOWN_KERNEL; return; } } #undef KERNELNAME spatstat.univar/src/taylorboot.c0000644000176200001440000000276714712311773016573 0ustar liggesusers/* taylorboot.c Charles Taylor's method for bandwidth selection in univariate KDE (Non-random bootstrap method) Taylor, C.C. (1989) Choice of the Smoothing Parameter in Kernel Density Estimation \emph{Biometrika} \bold{76} 4, 705--712. Implementation author: Adrian Baddeley Copyright (c) 2024 Adrian Baddeley and Tilman M Davies GNU Public Licence GPL (>= 2.0) $Revision: 1.2 $ $Date: 2024/11/05 03:40:00 $ */ #include #include double exp(double); void taylorboot( double *x, /* data */ int *n, /* length of x */ double *h, /* Gaussian bandwidth (=sd) */ int *diagok, /* 1 if include diagonal, 0 if exclude */ double *value ) { int i, j, N; double xih, H, dijh, dijh2, sum8, sum6, sum4, result; double *xh; N = *n; H = *h; xh = (double *) R_alloc(N, sizeof(double)); for(i = 0; i < N; i++) xh[i] = x[i]/H; sum8 = sum6 = sum4 = 0.0; /* upper triangle i > j */ for(i=1; i < N; i++) { xih = xh[i]; for(j=0; j < i; j++) { dijh = xih - xh[j]; dijh2 = dijh * dijh; sum8 += exp(-dijh2/8.0); sum6 += exp(-dijh2/6.0); sum4 += exp(-dijh2/4.0); } } /* lower triangle i < j */ sum8 *= 2.0; sum6 *= 2.0; sum4 *= 2.0; if(*diagok == 1) { /* add diagonal terms, which are exp(-0) = 1 */ sum8 += N; sum6 += N; sum4 += N; } result = sum8 - (4.0/M_SQRT_3) * sum6 + M_SQRT2 * (sum4 + N); result *= M_1_SQRT_2PI/(2.0 * N * N * H); *value = result; } spatstat.univar/NAMESPACE0000644000176200001440000000635114757566113014663 0ustar liggesusers## spatstat.univar NAMESPACE file ## ................ Import packages .................. import(stats) import(spatstat.utils) ## ................ Load dynamic library .............. ## (native routines are registered in init.c) ## (entry points are symbols with prefix "SG_") useDynLib(spatstat.univar, .registration=TRUE, .fixes="SK_") ## ////////// DO NOT EDIT THE FOLLOWING /////////////// ## //////// it is generated automatically ///////////// # .................................................. # Automatically-generated list of documented objects # .................................................. export("as.breakpts") export("breakpts") export("breakpts.from.r") export("bw.abram") export("bw.abram.default") export("bw.pow") export("bw.taylor") export("CDF") export("CDF.density") export("check.bandwidth") export("check.hist.lengths") export("densityAdaptiveKernel") export("densityAdaptiveKernel.default") export("densityBC") export("dkernel") export("dkernelBC") export("ewcdf") export("firstdigit") export("hotrod") export("IdenticalRowPair") export("IdenticalRows") export("indefinteg") export("integral") export("integral.density") export("kaplan.meier") export("kermom") export("kernel.factor") export("kernel.moment") export("kernel.squint") export("km.rs") export("km.rs.opt") export("knots.ecdf") export("knots.ewcdf") export("lastdigit") export("make.even.breaks") export("match.kernel") export("mean.ecdf") export("mean.ewcdf") export("ndigits") export("pkernel") export("plot.adaptivedensity") export("print.ewcdf") export("qkernel") export("quantile.density") export("quantile.ewcdf") export("quantilefun") export("quantilefun.ecdf") export("quantilefun.ewcdf") export("quantilefun.interpolatedCDF") export("reduced.sample") export("rkernel") export("rounding") export("rounding.default") export("stieltjes") export("StieltjesCalc") export("StieltjesCalc.stepfun") export("transformquantiles") export("uniquemap") export("uniquemap.data.frame") export("uniquemap.default") export("uniquemap.matrix") export("unnormdensity") export("weighted.median") export("weighted.quantile") export("weighted.var") export("whist") # ....... Special cases ........... # ....... End of special cases ... # ......................................... # Automatically generated list of S3 methods # ......................................... S3method("bw.abram", "default") S3method("CDF", "density") S3method("densityAdaptiveKernel", "default") S3method("integral", "density") S3method("knots", "ecdf") S3method("knots", "ewcdf") S3method("mean", "ecdf") S3method("mean", "ewcdf") S3method("plot", "adaptivedensity") S3method("print", "ewcdf") S3method("quantile", "density") S3method("quantile", "ewcdf") S3method("quantilefun", "ecdf") S3method("quantilefun", "ewcdf") S3method("quantilefun", "interpolatedCDF") S3method("rounding", "default") S3method("StieltjesCalc", "stepfun") S3method("uniquemap", "data.frame") S3method("uniquemap", "default") S3method("uniquemap", "matrix") # ......................................... # Assignment methods # ......................................... # ......................................... # End of methods # ......................................... spatstat.univar/inst/0000755000176200001440000000000014634220343014376 5ustar liggesusersspatstat.univar/inst/CITATION0000755000176200001440000000357114632773657015567 0ustar liggesusersc( bibentry(bibtype = "Book", title = "Spatial Point Patterns: Methodology and Applications with {R}", author = c(person("Adrian", "Baddeley"), person("Ege", "Rubak"), person("Rolf", "Turner")), year = "2015", publisher = "Chapman and Hall/CRC Press", address = "London", isbn = 9781482210200, url = "https://www.routledge.com/Spatial-Point-Patterns-Methodology-and-Applications-with-R/Baddeley-Rubak-Turner/p/book/9781482210200/", header = "To cite spatstat in publications, please use:" ), bibentry(bibtype = "Article", title = "Hybrids of Gibbs Point Process Models and Their Implementation", author = c(person("Adrian", "Baddeley"), person("Rolf", "Turner"), person("Jorge", "Mateu"), person("Andrew", "Bevan")), journal = "Journal of Statistical Software", year = "2013", volume = "55", number = "11", pages = "1--43", doi = "10.18637/jss.v055.i11", header = "If you use hybrid models, please also cite:" ), bibentry(bibtype = "Article", title = "{spatstat}: An {R} Package for Analyzing Spatial Point Patterns", author = c(person("Adrian", "Baddeley"), person("Rolf", "Turner")), journal = "Journal of Statistical Software", year = "2005", volume = "12", number = "6", pages = "1--42", doi = "10.18637/jss.v012.i06", header = "In survey articles, please also cite the original paper on spatstat:" ) ) spatstat.univar/inst/info/0000755000176200001440000000000014634220345015333 5ustar liggesusersspatstat.univar/inst/info/packagesizes.txt0000755000176200001440000000051014761753164020557 0ustar liggesusersdate version nhelpfiles nobjects ndatasets Rlines srclines "2024-04-10" "2.0-0" 24 43 0 1416 321 "2024-04-14" "2.0-1" 24 43 0 1416 321 "2024-06-28" "3.0-0" 30 58 0 1711 321 "2024-09-05" "3.0-1" 30 60 0 1742 321 "2024-11-05" "3.1-0" 36 68 0 2571 2233 "2024-11-05" "3.1-1" 36 68 0 2571 2235 "2025-03-05" "3.1-2" 36 68 0 2577 2235 spatstat.univar/inst/doc/0000755000176200001440000000000014632773657015166 5ustar liggesusersspatstat.univar/inst/doc/packagesizes.txt0000755000176200001440000000051014761753164020371 0ustar liggesusersdate version nhelpfiles nobjects ndatasets Rlines srclines "2024-04-10" "2.0-0" 24 43 0 1416 321 "2024-04-14" "2.0-1" 24 43 0 1416 321 "2024-06-28" "3.0-0" 30 58 0 1711 321 "2024-09-05" "3.0-1" 30 60 0 1742 321 "2024-11-05" "3.1-0" 36 68 0 2571 2233 "2024-11-05" "3.1-1" 36 68 0 2571 2235 "2025-03-05" "3.1-2" 36 68 0 2577 2235 spatstat.univar/man/0000755000176200001440000000000014757276200014205 5ustar liggesusersspatstat.univar/man/quantile.density.Rd0000644000176200001440000000446714632773657020021 0ustar liggesusers\name{quantile.density} \alias{quantile.density} \title{ Quantiles of a Density Estimate } \description{ Given a kernel estimate of a probability density, compute quantiles. } \usage{ \method{quantile}{density}(x, probs = seq(0, 1, 0.25), names = TRUE, \dots, warn = TRUE) } \arguments{ \item{x}{ Object of class \code{"density"} computed by a method for \code{\link[stats]{density}} } \item{probs}{ Numeric vector of probabilities for which the quantiles are required. } \item{names}{ Logical value indicating whether to attach names (based on \code{probs}) to the result. } \item{\dots}{ Ignored. } \item{warn}{ Logical value indicating whether to issue a warning if the density estimate \code{x} had to be renormalised because it was computed in a restricted interval. } } \details{ This function calculates quantiles of the probability distribution whose probability density has been estimated and stored in the object \code{x}. The object \code{x} must belong to the class \code{"density"}, and would typically have been obtained from a call to the function \code{\link[stats]{density}}. The probability density is first normalised so that the total probability is equal to 1. A warning is issued if the density estimate was restricted to an interval (i.e. if \code{x} was created by a call to \code{\link[stats]{density}} which included either of the arguments \code{from} and \code{to}). Next, the density estimate is numerically integrated to obtain an estimate of the cumulative distribution function \eqn{F(x)}. Then for each desired probability \eqn{p}, the algorithm finds the corresponding quantile \eqn{q}. The quantile \eqn{q} corresponding to probability \eqn{p} satisfies \eqn{F(q) = p} up to the resolution of the grid of values contained in \code{x}. The quantile is computed from the right, that is, \eqn{q} is the smallest available value of \eqn{x} such that \eqn{F(x) \ge p}{F(x) >= p}. } \value{ A numeric vector containing the quantiles. } \author{ \spatstatAuthors. } \seealso{ \code{\link[stats]{quantile}}, \code{\link{quantile.ewcdf}}, % \code{\link{quantile.im}}, \code{\link{CDF}}. } \examples{ dd <- density(runif(10)) quantile(dd) } \keyword{methods} \keyword{univar} \keyword{nonparametric} spatstat.univar/man/rounding.Rd0000644000176200001440000000376314632773657016344 0ustar liggesusers\name{rounding} \alias{rounding} \alias{rounding.default} \title{ Detect Numerical Rounding } \description{ Given a numeric vector, determine whether the values have been rounded to a certain number of decimal places. } \usage{ rounding(x) \method{rounding}{default}(x) } \arguments{ \item{x}{ A numeric vector, or an object containing numeric spatial coordinates. } } \details{ The function \code{rounding} is generic. Its purpose is to determine whether numerical values have been rounded to a certain number of decimal places. The \pkg{spatstat} family of packages provides methods for \code{rounding} for various spatial objects. For a numeric vector \code{x}, the default method \code{rounding.default} determines whether the values in \code{x} have been rounded to a certain number of decimal places. \itemize{ \item If the entries of \code{x} are not all integers, then \code{rounding(x)} returns the smallest number of digits \code{d} after the decimal point such that \code{\link[base]{round}(x, digits=d)} is identical to \code{x}. For example if \code{rounding(x) = 2} then the entries of \code{x} are rounded to 2 decimal places, and are multiples of 0.01. \item If all the entries of \code{x} are integers, then \code{rounding(x)} returns \code{-d}, where \code{d} is the smallest number of digits \emph{before} the decimal point such that \code{\link[base]{round}(x, digits=-d)} is identical to \code{x}. For example if \code{rounding(x) = -3} then the entries of \code{x} are multiples of 1000. If \code{rounding(x) = 0} then the entries of \code{x} are integers but not multiples of 10. \item If all entries of \code{x} are equal to 0, a value of 0 is returned. } } \value{ An integer. } \author{ \adrian and \rolf } \seealso{ \code{round.ppp} in package \code{spatstat.geom}. } \examples{ rounding(c(0.1, 0.3, 1.2)) rounding(c(1940, 1880, 2010)) rounding(0) } \keyword{math} spatstat.univar/man/densityAdaptiveKernel.Rd0000644000176200001440000000144414632773657021007 0ustar liggesusers\name{densityAdaptiveKernel} \alias{densityAdaptiveKernel} \title{ Adaptive Kernel Estimation of Density or Intensity } \description{ Computes an adaptive estimate of probability density or intensity using a variable-bandwidth smoothing kernel. } \usage{ densityAdaptiveKernel(X, \dots) } \arguments{ \item{X}{ Data to be smoothed. } \item{\dots}{ Additional arguments passed to methods. } } \details{ This generic function computes an adaptive kernel estimate of probability density or intensity. The function \code{densityAdaptiveKernel} is generic. The \pkg{spatstat} package family includes methods for spatial objects. } \value{ See documentation for each method. } \author{ \adrian and \tilman. } \seealso{ \code{\link{bw.abram}}. } \keyword{nonparametric} spatstat.univar/man/dkernel.Rd0000644000176200001440000000614314632773657016136 0ustar liggesusers\name{dkernel} \alias{dkernel} \alias{pkernel} \alias{qkernel} \alias{rkernel} \title{Kernel distributions and random generation} \description{Density, distribution function, quantile function and random generation for several distributions used in kernel estimation for numerical data. } \usage{ dkernel(x, kernel = "gaussian", mean = 0, sd = 1) pkernel(q, kernel = "gaussian", mean = 0, sd = 1, lower.tail = TRUE) qkernel(p, kernel = "gaussian", mean = 0, sd = 1, lower.tail = TRUE) rkernel(n, kernel = "gaussian", mean = 0, sd = 1) } \arguments{ \item{x, q}{Vector of quantiles.} \item{p}{Vector of probabilities.} \item{kernel}{ String name of the kernel. Options are \code{"gaussian"}, \code{"rectangular"}, \code{"triangular"}, \code{"epanechnikov"}, \code{"biweight"}, \code{"cosine"} and \code{"optcosine"}. (Partial matching is used). } \item{n}{Number of observations.} \item{mean}{Mean of distribution.} \item{sd}{Standard deviation of distribution.} \item{lower.tail}{logical; if \code{TRUE} (the default), then probabilities are \eqn{P(X \le x)}{P[X \le x]}, otherwise, \eqn{P(X > x)}. } } \details{ These functions give the probability density, cumulative distribution function, quantile function and random generation for several distributions used in kernel estimation for one-dimensional (numerical) data. The available kernels are those used in \code{\link[stats]{density.default}}, namely \code{"gaussian"}, \code{"rectangular"}, \code{"triangular"}, \code{"epanechnikov"}, \code{"biweight"}, \code{"cosine"} and \code{"optcosine"}. For more information about these kernels, see \code{\link[stats]{density.default}}. \code{dkernel} gives the probability density, \code{pkernel} gives the cumulative distribution function, \code{qkernel} gives the quantile function, and \code{rkernel} generates random deviates. } \value{ A numeric vector. For \code{dkernel}, a vector of the same length as \code{x} containing the corresponding values of the probability density. For \code{pkernel}, a vector of the same length as \code{x} containing the corresponding values of the cumulative distribution function. For \code{qkernel}, a vector of the same length as \code{p} containing the corresponding quantiles. For \code{rkernel}, a vector of length \code{n} containing randomly generated values. } \examples{ x <- seq(-3,3,length=100) plot(x, dkernel(x, "epa"), type="l", main=c("Epanechnikov kernel", "probability density")) plot(x, pkernel(x, "opt"), type="l", main=c("OptCosine kernel", "cumulative distribution function")) p <- seq(0,1, length=256) plot(p, qkernel(p, "biw"), type="l", main=c("Biweight kernel", "cumulative distribution function")) y <- rkernel(100, "tri") hist(y, main="Random variates from triangular density") rug(y) } \seealso{ \code{\link[stats]{density.default}}, \code{\link{kernel.factor}}, \code{\link{kernel.moment}}, \code{\link{kernel.squint}}. } \author{\adrian and \martinH. } \keyword{methods} \keyword{nonparametric} \keyword{smooth} spatstat.univar/man/densityAdaptiveKernel.default.Rd0000644000176200001440000001365714710326734022426 0ustar liggesusers\name{densityAdaptiveKernel.default} \alias{densityAdaptiveKernel.default} \title{ Adaptive Kernel Estimation of Probability Density } \description{ Computes an adaptive estimate of probability density from numeric data, using a variable-bandwidth smoothing kernel. } \usage{ \method{densityAdaptiveKernel}{default}(X, bw, \dots, weights = NULL, zerocor=c("none", "weighted", "convolution", "reflection", "bdrykern", "JonesFoster"), at = c("grid", "data"), ngroups=Inf, fast=TRUE) } \arguments{ \item{X}{ Data to be smoothed. A numeric vector. } \item{bw}{ Smoothing bandwidths. Either a numeric vector of the same length as \code{X} giving the bandwidth associated with each data value, or a \code{function} in the \R language that provides the smoothing bandwidth at any desired location. The default is to compute bandwidths using \code{\link[spatstat.univar]{bw.abram.default}}. } \item{\dots}{ Additional arguments passed to \code{\link[stats]{density.default}} controlling the range of \code{x} values at which the density must be estimated, when \code{at="grid"}. } \item{weights}{ Optional. Numeric vector of weights attached to each value in \code{X}. } \item{zerocor}{ Character string (partially matched) specifying a boundary correction. This is appropriate when \code{X} contains only positive values. } \item{at}{ String (partially matched) specifying whether to evaluate the probability density only at the data points (\code{at="data"}) or on a grid of \code{x} values (\code{at="grid"}, the default). } \item{ngroups}{ Integer, \code{Inf} or \code{NULL}. If \code{ngroups = Inf}, the density estimate will be computed exactly using C code. If \code{ngroups} is finite, then the fast subdivision technique of Davies and Baddeley (2018) will be applied. If \code{ngroups = NULL} then a default rule is used to choose an efficient number of groups. } \item{fast}{ Logical value specifying whether to use the Fast Fourier Transform to accelerate computations, when appropriate. } } \details{ This function computes an adaptive kernel estimate of probability density on the real line (if \code{zerocor="none"}) or on the positive real line (if \code{zerocor} is another value). The argument \code{bw} specifies the smoothing bandwidths to be applied to each of the points in \code{X}. It may be a numeric vector of bandwidth values, or a function yielding the bandwidth values. If the values in \code{X} are \eqn{x_1,\ldots,x_n}{x[1], ..., x[n]} and the corresponding bandwidths are \eqn{\sigma_1,\ldots,\sigma_n}{\sigma[1], ..., \sigma[n]} then the adaptive kernel estimate of intensity at a location \eqn{u} is \deqn{ \hat\lambda(u) = \sum_{i=1}^n k(u, x_i, \sigma_i) }{ \lambda(u) = sum[i] e(x[i], k(u, x[i], \sigma[i]) } where \eqn{k(u, v, \sigma)} is the value at \eqn{u} of the (possibly edge-corrected) smoothing kernel with bandwidth \eqn{\sigma} induced by a data point at \eqn{v}. Exact computation of the estimate above can be time-consuming: it takes \eqn{n} times longer than fixed-bandwidth smoothing. The partitioning method of Davies and Baddeley (2018) accelerates this computation by partitioning the range of bandwidths into \code{ngroups} intervals, correspondingly subdividing \code{X} into \code{ngroups} subsets according to bandwidth, and applying fixed-bandwidth smoothing to each subset. If \code{ngroups=NULL} then we use a default rule where \code{ngroups} is the integer part of the square root of the number of points in \code{X}, so that the computation time is only about \eqn{\sqrt{n}}{sqrt(n)} times slower than fixed-bandwidth smoothing. Any positive value of \code{ngroups} can be specified by the user. Specifying \code{ngroups=Inf} enforces exact computation of the estimate without partitioning. Specifying \code{ngroups=1} is the same as fixed-bandwidth smoothing with bandwidth \code{sigma=median(bw)}. } \section{Bandwidths and Bandwidth Selection}{ The function \code{densityAdaptiveKernel.default} computes one adaptive estimate of probability density, determined by the smoothing bandwidth values \code{bw}. Typically the bandwidth values are computed by first computing a pilot estimate of the intensity, then using \code{\link[spatstat.univar]{bw.abram.default}} to compute the vector of bandwidths according to Abramson's rule. This involves specifying a global bandwidth \code{h0}. } \value{ If \code{at="data"}, a numeric vector of the same length as \code{X}. If \code{at="grid"}, a probability density object of class \code{"density"}. } \references{ Davies, T.M. and Baddeley, A. (2018) Fast computation of spatially adaptive kernel estimates. \emph{Statistics and Computing}, \bold{28}(4), 937-956.\cr Hall, P. and Marron, J.S. (1988) Variable window width kernel density estimates of probability densities. \emph{Probability Theory and Related Fields}, \bold{80}, 37-49.\cr Silverman, B.W. (1986) \emph{Density Estimation for Statistics and Data Analysis}. Chapman and Hall, New York. } \author{ \adrian and \tilman. } \seealso{ \code{\link[spatstat.univar]{bw.abram.default}} } \examples{ xx <- rexp(100, rate=5) plot(density(xx)) curve(5 * exp(-5 * x), add=TRUE, col=3) plot(densityAdaptiveKernel(xx, at="grid")) curve(5 * exp(-5 * x), add=TRUE, col=3) plot(densityAdaptiveKernel(xx, at="grid", zerocor="w")) curve(5 * exp(-5 * x), add=TRUE, col=3) plot(densityAdaptiveKernel(xx, at="grid", zerocor="c")) curve(5 * exp(-5 * x), add=TRUE, col=3) plot(densityAdaptiveKernel(xx, at="grid", zerocor="r")) curve(5 * exp(-5 * x), add=TRUE, col=3) plot(densityAdaptiveKernel(xx, at="grid", zerocor="b")) curve(5 * exp(-5 * x), add=TRUE, col=3) plot(densityAdaptiveKernel(xx, at="grid", zerocor="J")) curve(5 * exp(-5 * x), add=TRUE, col=3) } \keyword{nonparametric} spatstat.univar/man/dkernelBC.Rd0000644000176200001440000000413214710326734016322 0ustar liggesusers\name{dkernelBC} \alias{dkernelBC} \title{ Boundary-corrected Kernel Density Function } \description{ Computes the boundary-corrected version of a smoothing kernel density function. } \usage{ dkernelBC(x, mean, sd = 1, kernel = "gaussian", zerocor = c("none", "weighted", "convolution", "reflection", "bdrykern")) } \arguments{ \item{x}{ Numeric. Values of the function argument, at which the function should be evaluated. } \item{mean}{ Numeric. The mean of the uncorrected kernel. } \item{sd}{ Numeric value. The standard deviation of the uncorrected kernel. } \item{kernel}{ Character string giving the name of the kernel as recognised by \code{\link[spatstat.univar]{match.kernel}}. } \item{zerocor}{ String (partially matched) specifying a correction for the boundary effect bias at \eqn{r=0} when estimating a density on the positive half line. Possible values are \code{"none"}, \code{"weighted"}, \code{"convolution"}, \code{"reflection"}, and \code{"bdrykern"}. } } \details{ The kernel density function identified by \code{kernel} with standard deviation \code{sd} and mean \code{mean} will be computed, and truncated onto the positive half-line. The boundary correction specified by \code{zerocor} will then be applied. The result is the vector of corrected density values. } \value{ Numeric value or numeric vector. } \author{ \adrian. } \seealso{ \code{\link{densityBC}} to compute a density estimate using the boundary-corrected kernel. \code{\link[spatstat.univar]{dkernel}} to compute the un-corrected kernel density function, and \code{\link[stats]{density.default}} to compute an uncorrected density estimate. \code{\link[spatstat.univar]{match.kernel}} for the list of recognised names of kernels. } \examples{ curve(dkernelBC(x, mean=1, zerocor="none"), to=5) curve(dkernelBC(x, mean=1, zerocor="weighted"), to=5) curve(dkernelBC(x, mean=1, zerocor="reflection"), to=5) curve(dkernelBC(x, mean=1, zerocor="convolution"), to=5) curve(dkernelBC(x, mean=1, zerocor="bdrykern"), to=5) } spatstat.univar/man/reduced.sample.Rd0000644000176200001440000000640014632773657017401 0ustar liggesusers\name{reduced.sample} \alias{reduced.sample} \title{Reduced Sample Estimator using Histogram Data} \description{ Compute the Reduced Sample estimator of a survival time distribution function, from histogram data } \usage{ reduced.sample(nco, cen, ncc, show=FALSE, uppercen=0) } \arguments{ \item{nco}{vector of counts giving the histogram of uncensored observations (those survival times that are less than or equal to the censoring time) } \item{cen}{vector of counts giving the histogram of censoring times } \item{ncc}{vector of counts giving the histogram of censoring times for the uncensored observations only } \item{uppercen}{ number of censoring times greater than the rightmost histogram breakpoint (if there are any) } \item{show}{Logical value controlling the amount of detail returned by the function value (see below) } } \value{ If \code{show = FALSE}, a numeric vector giving the values of the reduced sample estimator. If \code{show=TRUE}, a list with three components which are vectors of equal length, \item{rs}{Reduced sample estimate of the survival time c.d.f. \eqn{F(t)} } \item{numerator}{numerator of the reduced sample estimator } \item{denominator}{denominator of the reduced sample estimator } } \details{ This function is needed mainly for internal use in \pkg{spatstat}, but may be useful in other applications where you want to form the reduced sample estimator from a huge dataset. Suppose \eqn{T_i}{T[i]} are the survival times of individuals \eqn{i=1,\ldots,M} with unknown distribution function \eqn{F(t)} which we wish to estimate. Suppose these times are right-censored by random censoring times \eqn{C_i}{C[i]}. Thus the observations consist of right-censored survival times \eqn{\tilde T_i = \min(T_i,C_i)}{T*[i] = min(T[i],C[i])} and non-censoring indicators \eqn{D_i = 1\{T_i \le C_i\}}{D[i] = 1(T[i] <= C[i])} for each \eqn{i}. If the number of observations \eqn{M} is large, it is efficient to use histograms. Form the histogram \code{cen} of all censoring times \eqn{C_i}{C[i]}. That is, \code{obs[k]} counts the number of values \eqn{C_i}{C[i]} in the interval \code{(breaks[k],breaks[k+1]]} for \eqn{k > 1} and \code{[breaks[1],breaks[2]]} for \eqn{k = 1}. Also form the histogram \code{nco} of all uncensored times, i.e. those \eqn{\tilde T_i}{T*[i]} such that \eqn{D_i=1}{D[i]=1}, and the histogram of all censoring times for which the survival time is uncensored, i.e. those \eqn{C_i}{C[i]} such that \eqn{D_i=1}{D[i]=1}. These three histograms are the arguments passed to \code{kaplan.meier}. The return value \code{rs} is the reduced-sample estimator of the distribution function \eqn{F(t)}. Specifically, \code{rs[k]} is the reduced sample estimate of \code{F(breaks[k+1])}. The value is exact, i.e. the use of histograms does not introduce any approximation error. Note that, for the results to be valid, either the histogram breaks must span the censoring times, or the number of censoring times that do not fall in a histogram cell must have been counted in \code{uppercen}. } \seealso{ \code{\link{kaplan.meier}}, \code{\link{km.rs}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{nonparametric} spatstat.univar/man/transformquantiles.Rd0000644000176200001440000000573114632773657020455 0ustar liggesusers\name{transformquantiles} \alias{transformquantiles} \title{ Transform the Quantiles } \description{ Apply a transformation to the quantiles of a vector, or to the quantiles of the pixel values in a pixel image. } \usage{ transformquantiles(X, uniform = FALSE, reverse = FALSE, ...) } \arguments{ \item{X}{ A numeric vector, matrix, array, or a pixel image (object of class \code{"im"}). } \item{uniform}{ Logical value specifying whether each quantile value should be replaced by the corresponding cumulative probability (called \emph{histogram equalisation}, \emph{transformation to uniformity} or \emph{probability integral transformation}). } \item{reverse}{ Logical value specifying whether to swap the upper and lower quantiles. } \item{\dots}{ Ignored. } } \details{ The argument \code{X} may be a vector, matrix, array, or a pixel image (object of class \code{"im"}). The algorithm will first extract the entries or pixel values of \code{X} as a vector, and sort the values into ascending order. If \code{uniform=TRUE}, the entries in this vector will be replaced by the corresponding cumulative probabilities (the \code{k}th smallest value will be replaced by the number \code{(k-0.5)/n} where \code{n} is the total number of values). If \code{reverse=TRUE}, the resulting vector will be reversed so that it is in descending order (so that the \code{k}th smallest value will be swapped with the \code{k}th largest value). Finally the transformed values will be replaced into the original positions in the vector, matrix, array, or pixel image. The case \code{uniform=TRUE, reverse=FALSE} is called \emph{transformation to uniformity}, the \emph{probability integral transformation}, \emph{histogram equalisation}, or \emph{quantile transformation}. The resulting values are uniformly distributed between 0 and 1; a histogram of the values in \code{X} is flat. } \value{ Another object of the same type as \code{X}. } \author{ \spatstatAuthors. } \seealso{ To apply an arbitrary function \code{f} to the pixel values in an image, use the idiom \code{X[] <- f(X[])}. % or use \code{\link{eval.im}}. } \examples{ X <- c(3, 5, 1, 2, 4) transformquantiles(X, reverse=TRUE) transformquantiles(X, uniform=TRUE) transformquantiles(X, uniform=TRUE, reverse=TRUE) % Z <- 100 * as.im(bei.extra$grad, dimyx=c(25,50)) % opa <- par(mfrow=c(2,2)) % plot(Z,main="original") % plot(transformquantiles(Z, reverse=TRUE), main="reverse=TRUE") % plot(transformquantiles(Z, uniform=TRUE), % main="uniform=TRUE", col=grey.colors,zlim=c(0,1)) % plot(transformquantiles(Z, uniform=TRUE, reverse=TRUE), % main="uniform=TRUE, reverse=TRUE", % col=grey.colors, zlim=c(0,1)) % par(opa) } \keyword{spatial} \keyword{manip} \keyword{nonparametric} \keyword{univar} \concept{Histogram equalisation} \concept{Quantile transformation} \concept{Probability integral transformation} spatstat.univar/man/bw.abram.Rd0000644000176200001440000000260514632773657016202 0ustar liggesusers\name{bw.abram} \alias{bw.abram} \title{ Abramson's Adaptive Bandwidths } \description{ Computes adaptive smoothing bandwidths according to the inverse-square-root rule of Abramson (1982). } \usage{ bw.abram(X, h0, \dots) } \arguments{ \item{X}{ Data to be smoothed. } \item{h0}{ Global smoothing bandwidth. A numeric value. } \item{\dots}{ Additional arguments passed to methods. } } \details{ This function computes adaptive smoothing bandwidths for a dataset, using the methods of Abramson (1982) and Hall and Marron (1988). The function \code{bw.abram} is generic. There is a default method \code{\link{bw.abram.default}}. The \pkg{spatstat} package family includes methods for spatial objects. } \seealso{ \code{\link{bw.abram.default}} } \value{ See the documentation for the particular method. } \references{ Abramson, I. (1982) On bandwidth variation in kernel estimates --- a square root law. \emph{Annals of Statistics}, \bold{10}(4), 1217-1223. Hall, P. and Marron, J.S. (1988) Variable window width kernel density estimates of probability densities. \emph{Probability Theory and Related Fields}, \bold{80}, 37-49. Silverman, B.W. (1986) \emph{Density Estimation for Statistics and Data Analysis}. Chapman and Hall, New York. } \author{ \adrian. } \keyword{nonparametric} \concept{Adaptive smoothing} \concept{Bandwidth selection} spatstat.univar/man/weighted.median.Rd0000644000176200001440000000475714632773657017557 0ustar liggesusers\name{weighted.median} \alias{weighted.median} \alias{weighted.quantile} \alias{weighted.var} \title{ Weighted Median, Quantiles or Variance } \description{ Compute the median, quantiles or variance of a set of numbers which have weights associated with them. } \usage{ weighted.median(x, w, na.rm = TRUE, type=2, collapse=TRUE) weighted.quantile(x, w, probs=seq(0,1,0.25), na.rm = TRUE, type=4, collapse=TRUE) weighted.var(x, w, na.rm = TRUE) } \arguments{ \item{x}{ Data values. A vector of numeric values, for which the median or quantiles are required. } \item{w}{ Weights. A vector of nonnegative numbers, of the same length as \code{x}. } \item{probs}{ Probabilities for which the quantiles should be computed. A numeric vector of values between 0 and 1. } \item{na.rm}{ Logical. Whether to ignore \code{NA} values. } \item{type}{ Integer specifying the rule for calculating the median or quantile, corresponding to the rules available for \code{\link[stats]{quantile}}. The only valid choices are \code{type=1}, \code{2} or \code{4}. See Details. } \item{collapse}{Research use only.} } \details{ The \code{i}th observation \code{x[i]} is treated as having a weight proportional to \code{w[i]}. The weighted median is a value \code{m} such that the total weight of data less than or equal to \code{m} is equal to half the total weight. More generally, the weighted quantile with probability \code{p} is a value \code{q} such that the total weight of data less than or equal to \code{q} is equal to \code{p} times the total weight. If there is no such value, then \itemize{ \item if \code{type=1}, the next largest value is returned (this is the right-continuous inverse of the left-continuous cumulative distribution function); \item if \code{type=2}, the average of the two surrounding values is returned (the average of the right-continuous and left-continuous inverses); \item if \code{type=4}, linear interpolation is performed. } Note that the default rule for \code{weighted.median} is \code{type=2}, consistent with the traditional definition of the median, while the default for \code{weighted.quantile} is \code{type=4}. } \value{ A numeric value or vector. } \author{ \adrian. } \seealso{ \code{\link[stats]{quantile}}, \code{\link[stats]{median}}. } \examples{ x <- 1:20 w <- runif(20) weighted.median(x, w) weighted.quantile(x, w) weighted.var(x, w) } \keyword{math} spatstat.univar/man/mean.ewcdf.Rd0000644000176200001440000000413014632773657016513 0ustar liggesusers\name{mean.ewcdf} %DontDeclareMethods \alias{mean.ewcdf} \alias{mean.ecdf} \title{Mean of Empirical Cumulative Distribution Function} \description{ Calculates the mean of a (weighted or unweighted) empirical cumulative distribution function. } \usage{ \method{mean}{ecdf}(x, trim=0, \dots) \method{mean}{ewcdf}(x, trim=0, \dots) } \arguments{ \item{x}{ An empirical cumulative distribution function (object of class \code{"ecdf"} created by \code{\link[stats]{ecdf}}) or a weighted empirical cumulative distribution function (object of class \code{"ewcdf"} created by \code{\link{ewcdf}}). } \item{trim}{ The fraction (0 to 0.5) of data values to be trimmed from each end of their range, before the mean is computed. } \item{\dots}{ Ignored. } } \details{ These functions are methods for the generic \code{\link[base]{mean}} for the classes \code{"ecdf"} and \code{"ewcdf"}. They calculate the mean of the probability distribution corresponding to the cumulative distribution function \code{x}. This is equivalent to calculating the (weighted or unweighted) mean of the original data values. For \emph{weighted} empirical cumulative distribution functions (class \code{"ewcdf"}) the weights will first be normalised so that they sum to 1. The result of \code{mean.ewcdf} is always an average or weighted average or the original data values. The argument \code{trim} is interpreted as a probability under this normalised distribution; the corresponding quantiles are computed, and data outside these quantiles is deleted before calculating the weighted mean. } \value{ A single number. } \seealso{ Generic \code{\link[base]{mean}} and \code{\link[stats]{weighted.mean}}. \code{\link[stats]{ecdf}}, \code{\link{ewcdf}} to create the cumulative distribution functions. \code{\link[spatstat.univar]{stieltjes}} for integration with respect to a cumulative distribution function. } \examples{ x <- 1:5 mean(x) mean(ecdf(x)) w <- 1:5 mean(ewcdf(x, w)) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{methods} \keyword{univar} spatstat.univar/man/spatstat.univar-internal.Rd0000644000176200001440000000313314710326734021451 0ustar liggesusers\name{spatstat.univar-internal} \title{Internal Functions} \alias{as.breakpts} \alias{breakpts} \alias{breakpts.from.r} \alias{check.hist.lengths} \alias{check.bandwidth} \alias{kermom} \alias{km.rs.opt} \alias{knots.ecdf} \alias{make.even.breaks} \alias{match.kernel} \alias{plot.adaptivedensity} \alias{print.ewcdf} \alias{quantilefun.interpolatedCDF} \alias{IdenticalRowPair} \alias{IdenticalRows} \alias{StieltjesCalc} \alias{StieltjesCalc.stepfun} \description{ Undocumented Functions } \usage{ as.breakpts(\dots) breakpts(val, maxi, even, npos, step) breakpts.from.r(r) check.hist.lengths(hist, breaks) check.bandwidth(bw, descrip, fatal) kermom(m, r, kernel, mean, sd) km.rs.opt(o, cc, d, breaks, KM, RS) \method{knots}{ecdf}(Fn, \dots) make.even.breaks(bmax, npos, bstep) match.kernel(kernel) \method{plot}{adaptivedensity}(x, \dots, xlab) \method{print}{ewcdf}(x, digits, \dots) \method{quantilefun}{interpolatedCDF}(x, \dots, type) IdenticalRowPair(i,j,a,b) IdenticalRows(i,j,a,b) StieltjesCalc(M, f, \dots) \method{StieltjesCalc}{stepfun}(M, f, \dots) } \details{ These functions are not documented. } \value{ \code{as.breakpts}, \code{breakpts}, \code{breakpts.from.r} and \code{make.even.breaks} return an object of class \code{"breakpts"} which defines a sequence of breakpoints, identifies whether they are equally-spaced and so on. \code{match.kernel} returns a single character string. \code{check.hist.lengths} returns \code{NULL}. \code{quantilefun.interpolatedCDF} returns a function. The \code{print} method returns \code{NULL}. Other functions are not documented. } \keyword{internal} spatstat.univar/man/kernel.moment.Rd0000644000176200001440000000426114632773657017267 0ustar liggesusers\name{kernel.moment} \alias{kernel.moment} \title{Incomplete Moment of Smoothing Kernel} \description{ Computes the complete or incomplete \eqn{m}th moment of a smoothing kernel. } \usage{ kernel.moment(m, r, kernel = "gaussian", mean=0, sd=1/kernel.factor(kernel)) } \arguments{ \item{m}{ Exponent (order of moment). An integer. } \item{r}{ Upper limit of integration for the incomplete moment. A numeric value or numeric vector. Set \code{r=Inf} to obtain the complete moment. } \item{kernel}{ String name of the kernel. Options are \code{"gaussian"}, \code{"rectangular"}, \code{"triangular"}, \code{"epanechnikov"}, \code{"biweight"}, \code{"cosine"} and \code{"optcosine"}. (Partial matching is used). } \item{mean,sd}{ Optional numerical values giving the mean and standard deviation of the kernel. } } \details{ Kernel estimation of a probability density in one dimension is performed by \code{\link[stats]{density.default}} using a kernel function selected from the list above. For more information about these kernels, see \code{\link[stats]{density.default}}. The function \code{kernel.moment} computes the integral \deqn{ \int_{-\infty}^r t^m k(t) dt }{ integral[-Inf][r] t^m k(t) dt } where \eqn{k(t)} is the selected kernel, \eqn{r} is the upper limit of integration, and \eqn{m} is the exponent or order. Note that, if \code{mean} and \code{sd} are not specified, the calculations assume that \eqn{k(t)} is the \bold{standard form} of the kernel, which has support \eqn{[-1,1]} and standard deviation \eqn{sigma = 1/c} where \code{c = kernel.factor(kernel)}. The code uses the explicit analytic expressions when \code{m = 0, 1, 2} and numerical integration otherwise. } \value{ A single number, or a numeric vector of the same length as \code{r}. } \seealso{ \code{\link[stats]{density.default}}, \code{\link{dkernel}}, \code{\link{kernel.factor}}, \code{\link{kernel.squint}} } \examples{ kernel.moment(1, 0.1, "epa") curve(kernel.moment(2, x, "epa"), from=-1, to=1) } \author{ \adrian and \martinH. } \keyword{methods} \keyword{nonparametric} \keyword{smooth} spatstat.univar/man/whist.Rd0000644000176200001440000000467214632773657015655 0ustar liggesusers\name{whist} \alias{whist} \title{ Weighted Histogram } \description{ Computes the weighted histogram of a set of observations with a given set of weights. } \usage{ whist(x, breaks, weights = NULL, method=c("C", "interpreted")) } \arguments{ \item{x}{ Numeric vector of observed values. } \item{breaks}{ Vector of breakpoints for the histogram. } \item{weights}{ Numeric vector of weights for the observed values. } \item{method}{ Developer use only. A character string specifying whether to use internal C code (\code{method="C"}, the default) or interpreted \R code (\code{method="interpreted"}). } } \details{ This low-level function computes (but does not plot) the weighted histogram of a vector of observations \code{x} using a given vector of \code{weights}. The arguments \code{x} and \code{weights} should be numeric vectors of equal length. They may include \code{NA} or infinite values. The argument \code{breaks} should be a numeric vector whose entries are strictly increasing. These values define the boundaries between the successive histogram cells. The breaks \emph{do not} have to span the range of the observations. There are \code{N-1} histogram cells, where \code{N = length(breaks)}. An observation \code{x[i]} falls in the \code{j}th cell if \code{breaks[j] <= x[i] < breaks[j+1]} (for \code{j < N-1}) or \code{breaks[j] <= x[i] <= breaks[j+1]} (for \code{j = N-1}). The weighted histogram value \code{h[j]} for the \code{j}th cell is the sum of \code{weights[i]} for all observations \code{x[i]} that fall in the cell. Note that, in contrast to the function \code{\link{hist}}, the function \code{whist} does not require the breakpoints to span the range of the observations \code{x}. Values of \code{x} that fall outside the range of \code{breaks} are handled separately; their total weight is returned as an attribute of the histogram. } \value{ A numeric vector of length \code{N-1} containing the histogram values, where \code{N = length(breaks)}. The return value also has attributes \code{"low"} and \code{"high"} giving the total weight of all observations that are less than the lowest breakpoint, or greater than the highest breakpoint, respectively. } \examples{ x <- rnorm(100) b <- seq(-1,1,length=21) w <- runif(100) whist(x,b,w) } \author{\adrian and \rolf with thanks to Peter Dalgaard. } \keyword{arith} spatstat.univar/man/unnormdensity.Rd0000644000176200001440000000610714632773657017430 0ustar liggesusers\name{unnormdensity} \alias{unnormdensity} \title{ Weighted kernel smoother } \description{ An unnormalised version of kernel density estimation where the weights are not required to sum to 1. The weights may be positive, negative or zero. } \usage{ unnormdensity(x, ..., weights = NULL, defaults) } \arguments{ \item{x}{ Numeric vector of data } \item{\dots}{ Optional arguments passed to \code{\link[stats]{density.default}}. Arguments must be \emph{named}. }` \item{weights}{ Optional numeric vector of weights for the data. The default is equivalent to assuming a weight of 1 for each observation. } \item{defaults}{ Optional, named list of arguments passed to \code{\link[stats]{density.default}}. These will be overridden by arguments in \code{\dots}. } } \details{ This is an alternative to the standard \R kernel density estimation function \code{\link[stats]{density.default}}. The standard \code{\link[stats]{density.default}} requires the \code{weights} to be nonnegative numbers that add up to 1, and returns a probability density (a function that integrates to 1). This function \code{unnormdensity} does not impose any requirement on the \code{weights} except that they be finite. Individual weights may be positive, negative or zero. The result is a function that does not necessarily integrate to 1 and may be negative. The result is the convolution of the kernel \eqn{k} with the weighted data, \deqn{ f(x) = \sum_i w_i k(x- x_i) }{ f(x) = sum of w[i] * k(x - x[i]) } where \eqn{x_i}{x[i]} are the data points and \eqn{w_i}{w[i]} are the weights. The argument \code{weights} should be a numeric vector of the same length as \code{x}, or a single numeric value. The default is to assume a weight of 1 for each observation in \code{x}. The algorithm first selects the kernel bandwidth by applying \code{\link[stats]{density.default}} to the data \code{x} with normalised, positive weight vector \code{w = abs(weights)/sum(abs(weights))} and extracting the selected bandwidth. Then the result is computed by applying applying \code{\link[stats]{density.default}} to \code{x} twice using the normalised positive and negative parts of the weights. Note that the arguments \code{\dots} must be passed by name, i.e. in the form (\code{name=value}). Arguments that do not match an argument of \code{\link[stats]{density.default}} will be ignored \emph{silently}. } \section{Warning}{ If \code{weights} is not specified, the default is to assign a weight \eqn{w_i=1}{w[i]=1} to each observation \eqn{x_i}{x[i]}. This is not the same behaviour as in \code{\link{density.default}} which effectively assumes a weight of \eqn{1/n} for each observation \eqn{x_i}{x[i]} where \code{n=length(x)}. } \value{ Object of class \code{"density"} as described in \code{\link[stats]{density.default}}. } \author{ \adrian and \rolf } \seealso{ \code{\link[stats]{density.default}} } \examples{ d <- unnormdensity(1:3, weights=c(-1,0,1), bw=0.3) if(interactive()) plot(d) } \keyword{smooth} spatstat.univar/man/integral.density.Rd0000644000176200001440000000405314632773657017773 0ustar liggesusers\name{integral.density} \alias{integral.density} \title{ Compute Integral of One-Dimensional Kernel Density Estimate. } \description{ Compute the integral of a kernel density estimate over a specified range. } \usage{ \method{integral}{density}(f, domain = NULL, weight=NULL, ...) } \arguments{ \item{f}{ A one-dimensional probability density estimate (object of class \code{"density"}) obtained from the function \code{\link[stats]{density.default}} or from \code{\link{unnormdensity}}. } \item{domain}{ Optional. Range of values of the argument \eqn{x} over which the density \eqn{f(x)} should be integrated. A numeric vector of length 2 giving the minimum and maximum values of \eqn{x}. Infinite limits are permitted. } \item{weight}{ Optional. A \code{function(x)} specifying a weight integrand. } \item{\dots}{ Ignored. } } \details{ This is a method for the generic function \code{\link{integral}}. It computes the numerical integral \deqn{ I = \int f(x) dx }{ I = integral f(x) dx } of the density estimate \code{f}. If \code{weight} is specified, then the weighted integral \deqn{ I = \int w(x) f(x) dx }{ I = integral w(x) f(x) dx } is computed, where \eqn{w} is the function specified by \code{weight}. This function must return finite numerical values. If \code{domain} is specified, the integral is restricted to the interval of \eqn{x} values given by the \code{domain}. Integrals are calculated numerically using the trapezoidal rule restricted to the domain given. } \value{ A single numerical value. } \author{ \adrian. } \seealso{ \code{\link[stats]{density.default}} \code{\link[spatstat.univar]{quantile.density}}, \code{\link[spatstat.univar]{CDF.density}} } \examples{ x <- runif(10) d <- density(x, bw=0.1) integral(d) # should be approximately 1 integral(d, domain=c(-Inf, 0)) # mass on negative half-line ## mean of density integral(d, weight=function(x) x) } \keyword{methods} \keyword{univar} \keyword{nonparametric} \keyword{math} spatstat.univar/man/macros/0000755000176200001440000000000014710326734015466 5ustar liggesusersspatstat.univar/man/macros/newdefns.Rd0000644000176200001440000000033114757557235017600 0ustar liggesusers%% Extra macro definitions for this package \newcommand{\ournewpaper}{Baddeley, A., Davies, T.M. and Hazelton, M. (2025) Submitted for publication.} \newcommand{\ournewpapercite}{Baddeley, Davies and Hazelton (2025)} spatstat.univar/man/macros/defns.Rd0000755000176200001440000001076314632773657017103 0ustar liggesusers%% macro definitions for spatstat man pages %% Authors \newcommand{\adrian}{Adrian Baddeley \email{Adrian.Baddeley@curtin.edu.au}} \newcommand{\rolf}{Rolf Turner \email{rolfturner@posteo.net}} \newcommand{\ege}{Ege Rubak \email{rubak@math.aau.dk}} \newcommand{\spatstatAuthors}{\adrian, \rolf and \ege} \newcommand{\spatstatAuthorsComma}{\adrian, \rolf, \ege} %% Contributors with emails \newcommand{\pavel}{Pavel Grabarnik \email{pavel.grabar@issp.serpukhov.su}} \newcommand{\dominic}{Dominic Schuhmacher \email{dominic.schuhmacher@mathematik.uni-goettingen.de}, URL \code{http://dominic.schuhmacher.name/}} \newcommand{\wei}{Ang Qi Wei \email{aqw07398@hotmail.com}} \newcommand{\colette}{Marie-Colette van Lieshout \email{Marie-Colette.van.Lieshout@cwi.nl}} \newcommand{\rasmus}{Rasmus Plenge Waagepetersen \email{rw@math.auc.dk}} \newcommand{\abdollah}{Abdollah Jalilian \email{jalilian@razi.ac.ir}} \newcommand{\ottmar}{Ottmar Cronie \email{ottmar@chalmers.se}} \newcommand{\stephenEglen}{Stephen Eglen \email{S.J.Eglen@damtp.cam.ac.uk}} \newcommand{\mehdi}{Mehdi Moradi \email{m2.moradi@yahoo.com}} \newcommand{\yamei}{Ya-Mei Chang \email{yamei628@gmail.com}} \newcommand{\martinH}{Martin Hazelton \email{Martin.Hazelton@otago.ac.nz}} \newcommand{\tilman}{Tilman Davies \email{Tilman.Davies@otago.ac.nz}} % Names with accents \newcommand{\Bogsted}{\ifelse{latex}{\out{B\o gsted}}{Bogsted}} \newcommand{\Cramer}{\ifelse{latex}{\out{Cram\'er}}{Cramer}} \newcommand{\Francois}{\ifelse{latex}{\out{Fran\c{c}ois}}{Francois}} \newcommand{\Frederic}{\ifelse{latex}{\out{Fr{\'e}d{\'e}ric}}{Frederic}} \newcommand{\Hogmander}{\ifelse{latex}{\out{H{\"o}gmander}}{Hogmander}} \newcommand{\Jyvaskyla}{\ifelse{latex}{\out{Jyv\"askyl\"a}}{Jyvaskyla}} \newcommand{\Lucia}{\ifelse{latex}{\out{Luc\'{\i{}}a}}{Lucia}} \newcommand{\Matern}{\ifelse{latex}{\out{Mat\'ern}}{Matern}} \newcommand{\Moller}{\ifelse{latex}{\out{M\o ller}}{Moller}} \newcommand{\Oehlschlaegel}{\ifelse{latex}{\out{Oehlschl\"{a}gel}}{Oehlschlaegel}} \newcommand{\Prokesova}{\ifelse{latex}{\out{Proke\u{s}ov{\'{a}}}}{Prokesova}} \newcommand{\Sarkka}{\ifelse{latex}{\out{S\"{a}rkk\"{a}}}{Sarkka}} \newcommand{\Sanchez}{\ifelse{latex}{\out{S\'{a}nchez}}{Sanchez}} \newcommand{\Martin}{\ifelse{latex}{\out{Mart\'{\i}n}}{Martin}} \newcommand{\Dominguez}{\ifelse{latex}{\out{Dom\'{\i}nguez}}{Dominguez}} \newcommand{\Rodriguez}{\ifelse{latex}{\out{Rodr\'{\i}guez}}{Rodriguez}} \newcommand{\Gonzalez}{\ifelse{latex}{\out{Gonz\'{a}lez}}{Gonzalez}} %% List of all Gibbs interactions \newcommand{\GibbsInteractionsList}{\code{\link[MPKG]{AreaInter}}, \code{\link[MPKG]{BadGey}}, \code{\link[MPKG]{Concom}}, \code{\link[MPKG]{DiggleGatesStibbard}}, \code{\link[MPKG]{DiggleGratton}}, \code{\link[MPKG]{Fiksel}}, \code{\link[MPKG]{Geyer}}, \code{\link[MPKG]{Hardcore}}, \code{\link[MPKG]{HierHard}}, \code{\link[MPKG]{HierStrauss}}, \code{\link[MPKG]{HierStraussHard}}, \code{\link[MPKG]{Hybrid}}, \code{\link[MPKG]{LennardJones}}, \code{\link[MPKG]{MultiHard}}, \code{\link[MPKG]{MultiStrauss}}, \code{\link[MPKG]{MultiStraussHard}}, \code{\link[MPKG]{OrdThresh}}, \code{\link[MPKG]{Ord}}, \code{\link[MPKG]{Pairwise}}, \code{\link[MPKG]{PairPiece}}, \code{\link[MPKG]{Penttinen}}, \code{\link[MPKG]{Poisson}}, \code{\link[MPKG]{Saturated}}, \code{\link[MPKG]{SatPiece}}, \code{\link[MPKG]{Softcore}}, \code{\link[MPKG]{Strauss}}, \code{\link[MPKG]{StraussHard}} and \code{\link[MPKG]{Triplets}}} %% List of interactions recognised by RMH code \newcommand{\rmhInteractionsList}{\code{\link[MPKG]{AreaInter}}, \code{\link[MPKG]{BadGey}}, \code{\link[MPKG]{DiggleGatesStibbard}}, \code{\link[MPKG]{DiggleGratton}}, \code{\link[MPKG]{Fiksel}}, \code{\link[MPKG]{Geyer}}, \code{\link[MPKG]{Hardcore}}, \code{\link[MPKG]{Hybrid}}, \code{\link[MPKG]{LennardJones}}, \code{\link[MPKG]{MultiStrauss}}, \code{\link[MPKG]{MultiStraussHard}}, \code{\link[MPKG]{PairPiece}}, \code{\link[MPKG]{Penttinen}}, \code{\link[MPKG]{Poisson}}, \code{\link[MPKG]{Softcore}}, \code{\link[MPKG]{Strauss}}, \code{\link[MPKG]{StraussHard}} and \code{\link[MPKG]{Triplets}}} %% Frequent references \newcommand{\baddrubaturnbook}{Baddeley, A., Rubak, E. and Turner, R. (2015) \emph{Spatial Point Patterns: Methodology and Applications with R}. Chapman and Hall/CRC Press. } %% Citations of recent articles that will change rapidly \newcommand{\baddchangclustersim}{Baddeley, A. and Chang, Y.-M. (2023) Robust algorithms for simulating cluster point processes. \emph{Journal of Statistical Computation and Simulation}. In Press. DOI \code{10.1080/00949655.2023.2166045}.} spatstat.univar/man/quantilefun.Rd0000644000176200001440000000430114640451761017023 0ustar liggesusers\name{quantilefun} \alias{quantilefun} \alias{quantilefun.ecdf} \alias{quantilefun.ewcdf} \title{ Quantile Function } \description{ Return the inverse function of a cumulative distribution function. } \usage{ quantilefun(x, \dots) \method{quantilefun}{ecdf}(x, \dots, type=1) \method{quantilefun}{ewcdf}(x, \dots, type=1) } \arguments{ \item{x}{ Data for which the quantile function should be calculated. Either an object containing data (such as a pixel image) or an object representing a cumulative distribution function (of class \code{"ecdf"} or \code{"ewcdf"}). } \item{\dots}{ Other arguments passed to methods. } \item{type}{ Integer specifying the type of quantiles, as explained in \code{\link[stats]{quantile.default}}. Only types 1, 2 and 4 are currently implemented. } } \details{ Whereas the command \code{\link[stats]{quantile}} calculates the quantiles of a dataset corresponding to desired probabilities \eqn{p}, the command \code{quantilefun} returns a function which can be used to compute any quantiles of the dataset. If \code{f <- quantilefun(x)} then \code{f} is a function such that \code{f(p)} is the quantile associated with any given probability \code{p}. For example \code{f(0.5)} is the median of the original data, and \code{f(0.99)} is the 99th percentile of the original data. If \code{x} is a pixel image (object of class \code{"im"}) then the pixel values of \code{x} will be extracted and the quantile function of the pixel values is constructed. If \code{x} is an object representing a cumulative distribution function (object of class \code{"ecdf"} or \code{"ewcdf"}) then the quantile function of the original data is constructed. } \value{ A function in the \R language. } \seealso{ % \code{\link{quantilefun.im}}, \code{\link{ewcdf}}, \code{\link{quantile.ewcdf}}, \code{\link[stats]{ecdf}}, \code{\link[stats]{quantile}} } \examples{ ## numeric data z <- rnorm(50) FZ <- ecdf(z) QZ <- quantilefun(FZ) QZ(0.5) # median value of z if(interactive()) plot(QZ,xlim=c(0,1),xlab="probability",ylab="quantile of z") } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{nonparametric} spatstat.univar/man/kernel.squint.Rd0000644000176200001440000000272214632773657017313 0ustar liggesusers\name{kernel.squint} \alias{kernel.squint} \title{Integral of Squared Kernel} \description{ Computes the integral of the squared kernel, for the kernels used in density estimation for numerical data. } \usage{ kernel.squint(kernel = "gaussian", bw=1) } \arguments{ \item{kernel}{ String name of the kernel. Options are \code{"gaussian"}, \code{"rectangular"}, \code{"triangular"}, \code{"epanechnikov"}, \code{"biweight"}, \code{"cosine"} and \code{"optcosine"}. (Partial matching is used). } \item{bw}{ Bandwidth (standard deviation) of the kernel. } } \details{ Kernel estimation of a probability density in one dimension is performed by \code{\link[stats]{density.default}} using a kernel function selected from the list above. This function computes the integral of the squared kernel, \deqn{ R = \int_{-\infty}^{\infty} k(x)^2 \, {\rm d}x }{ R = integral of k(x)^2 dx from x = -infinity to x = +infinity } where \eqn{k(x)} is the kernel with bandwidth \code{bw}. } \value{ A single number. } \seealso{ \code{\link[stats]{density.default}}, \code{\link{dkernel}}, \code{\link{kernel.moment}}, \code{\link{kernel.factor}} } \examples{ kernel.squint("gaussian", 3) # integral of squared Epanechnikov kernel with half-width h=1 h <- 1 bw <- h/kernel.factor("epa") kernel.squint("epa", bw) } \author{ \adrian and \martinH. } \keyword{methods} \keyword{nonparametric} \keyword{smooth} spatstat.univar/man/bw.pow.Rd0000644000176200001440000000343514710326734015712 0ustar liggesusers\name{bw.pow} \alias{bw.pow} \title{ Variable Bandwidths Proportional to a Power of the Data Value } \description{ Computes variable smoothing bandwidths intended to be proportional to the observed data values, raised to a given power. } \usage{ bw.pow(X, h0, POW = 0.75, trim = 5, \dots) } \arguments{ \item{X}{ Data for which bandwidths should be calculated. A numeric vector of positive values. } \item{h0}{ A scalar value giving the global smoothing bandwidth in the same units as \code{X}. The default is \code{\link[stats]{bw.nrd0}(X)}. } \item{POW}{ Numeric value. The exponent of the power transformation to be applied to \code{X}. } \item{trim}{ A trimming value required to curb excessively large bandwidths. See Details. The default is sensible in most cases. } \item{\dots}{ Ignored. } } \details{ This function computes adaptive smoothing bandwidths for the data values in \code{X}. Larger data values are assigned larger bandwidths. Bandwidths are proportional to \code{X^POW}. The bandwidth at location \eqn{u} is \deqn{ h(u) = \mbox{\texttt{h0}} * \mbox{min}[ \frac{u^{\mbox{\texttt{POW}}}}{\gamma}, \mbox{\texttt{trim}} ] }{ h(u) = h0 * min(u^POW/\gamma, trim) } where \eqn{\gamma} is the geometric mean of the values \eqn{u^{\mbox{\texttt{POW}}}}{u^POW}. This allows the global bandwidth \code{h0} to be considered on the same scale as a corresponding fixed bandwidth. } \value{ A numeric vector of the same length as \code{X}. } \seealso{ \code{\link[spatstat.univar]{bw.abram}}, \code{\link[stats]{bw.nrd0}}. } % \references{ % Brainpower. % } \author{ \tilman. Adapted by \adrian. } \examples{ xx <- sort(rexp(10)) bb <- bw.pow(xx) signif(rbind(xx, bb), 3) } \keyword{nonparametric} spatstat.univar/man/spatstat.univar-package.Rd0000644000176200001440000001713614710330666021237 0ustar liggesusers\name{spatstat.univar-package} \alias{spatstat.univar-package} \alias{spatstat.univar} \docType{package} \title{The spatstat.univar Package} \description{ The \pkg{spatstat.univar} package belongs to the \pkg{spatstat} family of packages. It provides utilities for estimating the probability distribution of one-dimensional (real-valued) data. } \details{ This package is a member of the \pkg{spatstat} family of packages. It provides utilities for estimation of the probability distribution of one-dimensional (i.e. numerical, real-valued) data. The utilities include: \describe{ \item{kernel density estimation:}{ including variable-bandwidth kernels, boundary correction, bandwidth selection, unnormalised weighted densities, and cumulative distribution functions of density estimates. } \item{weighted distributions and weighted statistics:}{ including weighted empirical cumulative distributions, weighted median, weighted quantiles, calculating the CDF from a density estimate } \item{estimation for right-censored data:}{ including Kaplan-Meier, reduced-sample and other estimators of the cumulative distribution function and hazard function from right-censored data } \item{quantiles:}{ including calculation of quantiles from an empirical cumulative distribution or a kernel density estimate } \item{kernels:}{ including calculation of the probability density, cumulative distribution function, quantiles, random generation, moments and partial moments of the standard smoothing kernels } \item{heat kernel:}{ calculation of the one-dimensional heat kernel in an interval } \item{integration:}{ Numerical integration including Stieltjes integrals and indefinite integrals. } } The facilities are described in more detail below. \bold{Kernel density estimation} The package supports fixed-bandwidth and variable-bandwidth kernel estimation of probability densities from numerical data. It provides boundary corrections for kernel estimates of densities on the positive half-line (applicable when the original observations are positive numbers) for both fixed-bandwidth and variable-bandwidth estimates. If the observations have numerical weights associated with them, these weights will not be automatically normalised, and indeed the weights may be negative or zero. This is unlike the standard \R method \code{\link[stats]{density.default}}. The main functions are: \tabular{ll}{ \code{\link{unnormdensity}} \tab extension of \code{\link[stats]{density.default}} allowing weights to be negative or zero. \cr \code{\link{densityBC}} \tab fixed-bandwidth kernel estimate with optional boundary correction \cr \code{\link{densityAdaptiveKernel}} \tab adaptive (variable-bandwidth) kernel estimation (generic) \cr \code{\link{densityAdaptiveKernel.default}} \tab adaptive (variable-bandwidth) kernel estimate (method for numeric data, with optional boundary correction) \cr \code{\link{bw.abram.default}} \tab calculate data-dependent bandwidths using Abramson rule \cr \code{\link{CDF.density}} \tab cumulative distribution function from kernel density estimate } \bold{Weighted distributions and weighted statistics} Weighted versions of standard operations such as the histogram and empirical distribution function are provided: \tabular{ll}{ \code{\link{whist}} \tab weighted histogram \cr \code{\link{ewcdf}} \tab weighted empirical cumulative distribution function \cr \code{\link{mean.ewcdf}} \tab mean of weighted ecdf \cr \code{\link{quantile.ewcdf}} \tab quantiles of weighted ecdf \cr \code{\link{knots.ewcdf}} \tab jump points of weighted ecdf \cr \code{\link{weighted.median}} \tab weighted median of numeric values \cr \code{\link{weighted.quantile}} \tab weighted quantile of numeric values \cr } \bold{Estimation for right-censored data} Facilities are provided for estimating the probability distribution of right-censored lifetimes (non-negative real random variables). \tabular{ll}{ \code{\link{kaplan.meier}} \tab Kaplan-Meier estimator of cumulative distribution function and hazard rate, from right-censored data \cr \code{\link{reduced.sample}} \tab reduced-sample estimator of cumulative distribution function, from right-censored data } \bold{Quantiles} Facilities are provided for computing the quantiles of a probability distribution, given estimates of the probability density or the cumulative distribution function and so on. \tabular{ll}{ \code{\link{CDF.density}} \tab cumulative distribution function from kernel density estimate \cr \code{\link{quantile.density}} \tab quantiles of kernel density estimate \cr \code{\link{quantile.ewcdf}} \tab quantiles of weighted ecdf \cr \code{\link{quantilefun}} \tab quantiles as a function \cr \code{\link{quantilefun.ewcdf}} \tab quantiles as a function \cr \code{\link{weighted.quantile}} \tab weighted quantile of numeric values \cr \code{\link{transformquantiles}} \tab transform the quantiles of a dataset } \bold{Kernels} The standard \R function \code{\link[stats]{density.default}} recognises a list of smoothing kernels by name: \code{"gaussian"}, \code{"rectangular"}, \code{"triangular"}, \code{"epanechnikov"}, \code{"biweight"}, \code{"cosine"} and \code{"optcosine"}. For these kernels, \pkg{spatstat.univar} provides various characteristics: \tabular{ll}{ \code{\link{dkernel}} \tab probability density of the kernel \cr \code{\link{pkernel}} \tab cumulative distribution function of the kernel \cr \code{\link{qkernel}} \tab quantiles of the kernel \cr \code{\link{rkernel}} \tab generate simulated realisations from the kernel \cr \code{\link{kernel.factor}} \tab scale factor relating bandwidth to half-width of kernel \cr \code{\link{kernel.moment}} \tab partial moment of kernel \cr \code{\link{kernel.squint}} \tab integral of squared kernel \cr \code{\link{dkernelBC}} \tab evaluate the kernel with boundary correction } \bold{Heat kernels} The heat kernel in an interval can be calculated. \tabular{ll}{ \code{\link{hotrod}} \tab calculate the heat kernel in an interval } \bold{Integration} A few facilities are provided for calculating integrals of real functions. \tabular{ll}{ \code{\link{indefinteg}} \tab indefinite integral \cr \code{\link{integral.density}} \tab integral of a kernel density estimate \cr \code{\link{stieltjes}} \tab Stieltjes integral } \bold{Utilities} A few utilities for numerical data are also provided. \tabular{ll}{ \code{\link{uniquemap.default}} \tab map duplicates to unique entries \cr \code{\link{rounding.default}} \tab determine whether values have been rounded \cr \code{\link{firstdigit}} \tab leading digit in decimal representation \cr \code{\link{lastdigit}} \tab least significant digit in decimal representation \cr \code{\link{ndigits}} \tab number of digits in decimal representation } } \section{Licence}{ This library and its documentation are usable under the terms of the "GNU General Public License", a copy of which is distributed with the package. } \author{ \adrian, \tilman, \martinH, \ege, \rolf and Greg McSwiggan. } \keyword{package} \keyword{distribution} \keyword{nonparametric} \keyword{smooth} spatstat.univar/man/km.rs.Rd0000644000176200001440000000610314632773657015540 0ustar liggesusers\name{km.rs} \alias{km.rs} \title{Kaplan-Meier and Reduced Sample Estimator using Histograms} \description{ Compute the Kaplan-Meier and Reduced Sample estimators of a survival time distribution function, using histogram techniques } \usage{ km.rs(o, cc, d, breaks) } \arguments{ \item{o}{vector of observed survival times } \item{cc}{vector of censoring times } \item{d}{vector of non-censoring indicators } \item{breaks}{Vector of breakpoints to be used to form histograms. } } \value{ A list with five elements \item{rs}{Reduced-sample estimate of the survival time c.d.f. \eqn{F(t)} } \item{km}{Kaplan-Meier estimate of the survival time c.d.f. \eqn{F(t)} } \item{hazard}{corresponding Nelson-Aalen estimate of the hazard rate \eqn{\lambda(t)}{lambda(t)} } \item{r}{values of \eqn{t} for which \eqn{F(t)} is estimated } \item{breaks}{the breakpoints vector } } \details{ This function is needed mainly for internal use in \pkg{spatstat}, but may be useful in other applications where you want to form the Kaplan-Meier estimator from a huge dataset. Suppose \eqn{T_i}{T[i]} are the survival times of individuals \eqn{i=1,\ldots,M} with unknown distribution function \eqn{F(t)} which we wish to estimate. Suppose these times are right-censored by random censoring times \eqn{C_i}{C[i]}. Thus the observations consist of right-censored survival times \eqn{\tilde T_i = \min(T_i,C_i)}{T*[i] = min(T[i],C[i])} and non-censoring indicators \eqn{D_i = 1\{T_i \le C_i\}}{D[i] = 1(T[i] <= C[i])} for each \eqn{i}. The arguments to this function are vectors \code{o}, \code{cc}, \code{d} of observed values of \eqn{\tilde T_i}{T*[i]}, \eqn{C_i}{C[i]} and \eqn{D_i}{D[i]} respectively. The function computes histograms and forms the reduced-sample and Kaplan-Meier estimates of \eqn{F(t)} by invoking the functions \code{\link{kaplan.meier}} and \code{\link{reduced.sample}}. This is efficient if the lengths of \code{o}, \code{cc}, \code{d} (i.e. the number of observations) is large. The vectors \code{km} and \code{hazard} returned by \code{kaplan.meier} are (histogram approximations to) the Kaplan-Meier estimator of \eqn{F(t)} and its hazard rate \eqn{\lambda(t)}{lambda(t)}. Specifically, \code{km[k]} is an estimate of \code{F(breaks[k+1])}, and \code{lambda[k]} is an estimate of the average of \eqn{\lambda(t)}{lambda(t)} over the interval \code{(breaks[k],breaks[k+1])}. This approximation is exact only if the survival times are discrete and the histogram breaks are fine enough to ensure that each interval \code{(breaks[k],breaks[k+1])} contains only one possible value of the survival time. The vector \code{rs} is the reduced-sample estimator, \code{rs[k]} being the reduced sample estimate of \code{F(breaks[k+1])}. This value is exact, i.e. the use of histograms does not introduce any approximation error in the reduced-sample estimator. } \seealso{ \code{\link{reduced.sample}}, \code{\link{kaplan.meier}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{nonparametric} spatstat.univar/man/CDF.Rd0000644000176200001440000000245414632773657015107 0ustar liggesusers\name{CDF} \alias{CDF} \alias{CDF.density} \title{ Cumulative Distribution Function From Kernel Density Estimate } \description{ Given a kernel estimate of a probability density, compute the corresponding cumulative distribution function. } \usage{ CDF(f, \dots) \method{CDF}{density}(f, \dots, warn = TRUE) } \arguments{ \item{f}{ Density estimate (object of class \code{"density"}). } \item{\dots}{ Ignored. } \item{warn}{ Logical value indicating whether to issue a warning if the density estimate \code{f} had to be renormalised because it was computed in a restricted interval. } } \details{ \code{CDF} is generic, with a method for class \code{"density"}. This calculates the cumulative distribution function whose probability density has been estimated and stored in the object \code{f}. The object \code{f} must belong to the class \code{"density"}, and would typically have been obtained from a call to the function \code{\link[stats]{density}}. } \value{ A function, which can be applied to any numeric value or vector of values. } \author{ \spatstatAuthors } \seealso{ \code{\link[stats]{density}}, \code{\link{quantile.density}} } \examples{ b <- density(runif(10)) f <- CDF(b) f(0.5) plot(f) } \keyword{nonparametric} \keyword{univar} spatstat.univar/man/kaplan.meier.Rd0000644000176200001440000000604514632773657017061 0ustar liggesusers\name{kaplan.meier} \alias{kaplan.meier} \title{Kaplan-Meier Estimator using Histogram Data} \description{ Compute the Kaplan-Meier estimator of a survival time distribution function, from histogram data } \usage{ kaplan.meier(obs, nco, breaks, upperobs=0) } \arguments{ \item{obs}{vector of \eqn{n} integers giving the histogram of all observations (censored or uncensored survival times) } \item{nco}{vector of \eqn{n} integers giving the histogram of uncensored observations (those survival times that are less than or equal to the censoring time) } \item{breaks}{Vector of \eqn{n+1} breakpoints which were used to form both histograms. } \item{upperobs}{ Number of observations beyond the rightmost breakpoint, if any. } } \value{ A list with two elements: \item{km}{Kaplan-Meier estimate of the survival time c.d.f. \eqn{F(t)} } \item{lambda}{corresponding Nelson-Aalen estimate of the hazard rate \eqn{\lambda(t)}{lambda(t)} } These are numeric vectors of length \eqn{n}. } \details{ This function is needed mainly for internal use in \pkg{spatstat}, but may be useful in other applications where you want to form the Kaplan-Meier estimator from a huge dataset. Suppose \eqn{T_i}{T[i]} are the survival times of individuals \eqn{i=1,\ldots,M} with unknown distribution function \eqn{F(t)} which we wish to estimate. Suppose these times are right-censored by random censoring times \eqn{C_i}{C[i]}. Thus the observations consist of right-censored survival times \eqn{\tilde T_i = \min(T_i,C_i)}{T*[i] = min(T[i],C[i])} and non-censoring indicators \eqn{D_i = 1\{T_i \le C_i\}}{D[i] = 1(T[i] <= C[i])} for each \eqn{i}. If the number of observations \eqn{M} is large, it is efficient to use histograms. Form the histogram \code{obs} of all observed times \eqn{\tilde T_i}{T*[i]}. That is, \code{obs[k]} counts the number of values \eqn{\tilde T_i}{T*[i]} in the interval \code{(breaks[k],breaks[k+1]]} for \eqn{k > 1} and \code{[breaks[1],breaks[2]]} for \eqn{k = 1}. Also form the histogram \code{nco} of all uncensored times, i.e. those \eqn{\tilde T_i}{T*[i]} such that \eqn{D_i=1}{D[i]=1}. These two histograms are the arguments passed to \code{kaplan.meier}. The vectors \code{km} and \code{lambda} returned by \code{kaplan.meier} are (histogram approximations to) the Kaplan-Meier estimator of \eqn{F(t)} and its hazard rate \eqn{\lambda(t)}{lambda(t)}. Specifically, \code{km[k]} is an estimate of \code{F(breaks[k+1])}, and \code{lambda[k]} is an estimate of the average of \eqn{\lambda(t)}{lambda(t)} over the interval \code{(breaks[k],breaks[k+1])}. The histogram breaks must include \eqn{0}. If the histogram breaks do not span the range of the observations, it is important to count how many survival times \eqn{\tilde T_i}{T*[i]} exceed the rightmost breakpoint, and give this as the value \code{upperobs}. } \seealso{ \code{\link{reduced.sample}}, \code{\link{km.rs}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{nonparametric} spatstat.univar/man/uniquemap.default.Rd0000644000176200001440000000354614636752661020141 0ustar liggesusers\name{uniquemap.default} \alias{uniquemap} \alias{uniquemap.default} \alias{uniquemap.data.frame} \alias{uniquemap.matrix} \title{ Map Duplicate Entries to Unique Entries } \description{ Determine whether entries in a vector (or rows in a matrix or data frame) are duplicated, choose a unique representative for each set of duplicates, and map the duplicates to the unique representative. } \usage{ uniquemap(x) \method{uniquemap}{default}(x) \method{uniquemap}{data.frame}(x) \method{uniquemap}{matrix}(x) } \arguments{ \item{x}{ A vector, data frame or matrix, or another type of data. } } \details{ The function \code{uniquemap} is generic, with methods for point patterns, data frames, and a default method. The default method expects a vector. It determines whether any entries of the vector \code{x} are duplicated, and constructs a mapping of the indices of \code{x} so that all duplicates are mapped to a unique representative index. The result is an integer vector \code{u} such that \code{u[j] = i} if the entries \code{x[i]} and \code{x[j]} are identical and point \code{i} has been chosen as the unique representative. The entry \code{u[i] = i} means either that point \code{i} is unique, or that it has been chosen as the unique representative of its equivalence class. The method for \code{data.frame} determines whether any rows of the data frame \code{x} are duplicated, and constructs a mapping of the row indices so that all duplicate rows are mapped to a unique representative row. } \value{ An integer vector. } \author{ \spatstatAuthors. } \seealso{ \code{\link{duplicated}}. \code{uniquemap.ppp} in \pkg{spatstat.geom} } \examples{ x <- c(3, 5, 2, 4, 2, 3) uniquemap(x) df <- data.frame(A=x, B=42) uniquemap(df) z <- cbind(x, 10-x) uniquemap(z) } \keyword{spatial} \keyword{methods} spatstat.univar/man/stieltjes.Rd0000644000176200001440000000477114632773657016525 0ustar liggesusers\name{stieltjes} \alias{stieltjes} \title{Compute Integral of Function Against Cumulative Distribution} \description{ Computes the Stieltjes integral of a function \eqn{f} with respect to a function \eqn{M}. } \usage{ stieltjes(f, M, ...) } \arguments{ \item{f}{ The integrand. A function in the \R language. } \item{M}{ The cumulative function against which \code{f} will be integrated. An object of class \code{"fv"} or \code{"stepfun"}. } \item{\dots}{ Additional arguments passed to \code{f}. } } \details{ This command computes the Stieltjes integral \deqn{I = \int f(x) dM(x)}{I = integral f(x) dM(x)} of a real-valued function \eqn{f(x)} with respect to a nondecreasing function \eqn{M(x)}. One common use of the Stieltjes integral is to find the mean value of a random variable from its cumulative distribution function \eqn{F(x)}. The mean value is the Stieltjes integral of \eqn{f(x)=x} with respect to \eqn{F(x)}. The argument \code{f} should be a \code{function} in the \R language. It should accept a numeric vector argument \code{x} and should return a numeric vector of the same length. The argument \code{M} should be either a step function (object of class \code{"stepfun"}) or a function value table (object of class \code{"fv"} %, see \code{\link{fv.object}}). ). Objects of class \code{"stepfun"} are returned by \code{\link[stats]{ecdf}}, \code{\link{ewcdf}}, % \code{\link[spatstat.explore]{spatialcdf}} and other utilities. % Objects of class \code{"fv"} are returned % by the commands \code{\link[spatstat.explore]{Kest}}, \code{\link[spatstat.explore]{Gest}}, etc. } \value{ A list containing the value of the Stieltjes integral computed using each of the versions of the function \code{M}. } %\seealso{ % \code{\link[spatstat.explore]{fv.object}}. % Use \code{\link[spatstat.explore]{integral.fv}} to integrate a function % object of class \code{"fv"}. %} \examples{ x <- runif(100) w <- runif(100) H <- ewcdf(x, w) stieltjes(function(x) { x^2 }, H) % # estimate cdf of nearest neighbour distance in redwood data % G <- Gest(redwood) % # compute estimate of mean nearest neighbour distance % stieltjes(function(x){x}, G) % # estimated probability of a distance in the interval [0.1,0.2] % stieltjes(function(x,a,b){ (x >= a) & (x <= b)}, G, a=0.1, b=0.2) % # stepfun example % H <- spatialcdf(bei.extra$elev, normalise=TRUE) % stieltjes(function(x){x}, H) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.univar/man/integral.Rd0000644000176200001440000000215714632773657016320 0ustar liggesusers\name{integral} \alias{integral} \title{ Integral of a Function or Spatial Object } \description{ Computes the integral of a function or spatial object. } \usage{ integral(f, domain=NULL, \dots) } \arguments{ \item{f}{ A function, or a spatial object that can be treated as a function. } \item{domain}{ Optional. Data specifying the domain of integration. } \item{\dots}{ Arguments passed to methods. } } \details{ The function \code{integral} is generic. It calculates the integral of a function, or the integral of a spatial object that can be treated as a function. It has methods for one-dimensional functions (\code{"density"}, \code{"fv"}) and for spatial objects (\code{"im"}, \code{"msr"}, \code{"linim"}, \code{"linfun"}). } \value{ A single numeric or complex value, or a vector of such values. } \seealso{ % temporarily break links % \code{\link[spatstat.geom]{integral.im}}, % \code{\link[spatstat.geom]{integral.density}}. \code{\link{integral.density}}. \code{integral.im} in package \code{spatstat.geom}. } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.univar/man/indefinteg.Rd0000644000176200001440000000410314632773657016620 0ustar liggesusers\name{indefinteg} \alias{indefinteg} \title{ Indefinite Integral } \description{ Computes the indefinite integral of the given function. } \usage{ indefinteg(f, x, \dots, method=c("trapezoid", "quadrature"), lower=min(x), nfine=8192) } \arguments{ \item{f}{ an \R function taking a numeric first argument and returning a numeric vector of the same length. } \item{x}{ Vector of values of the argument for which the indefinite integral should be evaluated. } \item{\dots}{ additional arguments to be passed to \code{f}. } \item{method}{ String (partially matched) specifying how to compute the integrals. } \item{lower}{ Lower limit of integration. A single number. } \item{nfine}{ Number of sub-intervals to use for computation if \code{method='trapezoid'}. } } \details{ The indefinite integral of the given function \code{f} is computed numerically at each of the desired values \code{x}. The lower limit of integration is taken to be \code{min(x)}. The result is a numeric vector \code{y} of the same length as \code{x}, with entries \deqn{ y_i = \int_{\mbox{lower}}^{x_i} f(t) dt }{ y[i] = integral[lower]^(x[i]) f(t) dt } If \code{method='trapezoid'} (the default), the integrals are computed rapidly using the trapezoid rule. If \code{method='quadrature'} the integrals are computed accurately but much more slowly, using the numerical quadrature routine \code{\link[stats]{integrate}}. If \code{method='trapezoid'} the function \code{f} is first evaluated on a finer grid of values of the function argument. The fine grid contains \code{nfine} sample points. The values of the indefinite integral on the fine grid are computed using the trapezoidal approximation. Finally the values of the indefinite integral are extracted at the desired argument values \code{x}. } \value{ Numeric vector of the same length as \code{x}. } \author{ \adrian. } \seealso{ \code{\link[stats]{integrate}} } \examples{ curve(indefinteg(sin, x), to=pi) } \keyword{math} spatstat.univar/man/quantile.ewcdf.Rd0000644000176200001440000000406314640455451017406 0ustar liggesusers\name{quantile.ewcdf} \alias{quantile.ewcdf} \title{ Quantiles of Weighted Empirical Cumulative Distribution Function } \description{ Compute quantiles of a weighted empirical cumulative distribution function. } \usage{ \method{quantile}{ewcdf}(x, probs = seq(0, 1, 0.25), names = TRUE, \dots, normalise = TRUE, type=1) } \arguments{ \item{x}{ A weighted empirical cumulative distribution function (object of class \code{"ewcdf"}, produced by \code{\link{ewcdf}}) for which the quantiles are desired. } \item{probs}{ probabilities for which the quantiles are desired. A numeric vector of values between 0 and 1. } \item{names}{ Logical. If \code{TRUE}, the resulting vector of quantiles is annotated with names corresponding to \code{probs}. } \item{\dots}{ Ignored. } \item{normalise}{ Logical value indicating whether \code{x} should first be normalised so that it ranges between 0 and 1. } \item{type}{ Integer specifying the type of quantile to be calculated, as explained in \code{\link[stats]{quantile.default}}. Only types 1, 2 and 4 are currently implemented. } } \details{ This is a method for the generic \code{\link[stats]{quantile}} function for the class \code{ewcdf} of empirical weighted cumulative distribution functions. The quantile for a probability \code{p} is computed as the right-continuous inverse of the cumulative distribution function \code{x} (assuming \code{type=1}, the default). If \code{normalise=TRUE} (the default), the weighted cumulative function \code{x} is first normalised to have total mass \code{1} so that it can be interpreted as a cumulative probability distribution function. } \value{ Numeric vector of quantiles, of the same length as \code{probs}. } \seealso{ \code{\link{ewcdf}}, \code{\link[stats]{quantile}} } \examples{ z <- rnorm(50) w <- runif(50) Fun <- ewcdf(z, w) quantile(Fun, c(0.95,0.99)) } \author{ \spatstatAuthors and Kevin Ummel. } \keyword{spatial} \keyword{nonparametric} spatstat.univar/man/ewcdf.Rd0000644000176200001440000000467714632773657015614 0ustar liggesusers\name{ewcdf} \alias{ewcdf} \title{Weighted Empirical Cumulative Distribution Function} \description{ Compute a weighted version of the empirical cumulative distribution function. } \usage{ ewcdf(x, weights = NULL, normalise=TRUE, adjust=1) } \arguments{ \item{x}{Numeric vector of observations.} \item{weights}{ Optional. Numeric vector of non-negative weights for \code{x}. Defaults to equal weight 1 for each entry of \code{x}. } \item{normalise}{ Logical value indicating whether the weights should be rescaled so that they sum to 1. } \item{adjust}{ Numeric value. Adjustment factor. The weights will be multiplied by \code{adjust}. } } \details{ This is a modification of the standard function \code{\link[stats]{ecdf}} allowing the observations \code{x} to have weights. The weighted e.c.d.f. (empirical cumulative distribution function) \code{Fn} is defined so that, for any real number \code{y}, the value of \code{Fn(y)} is equal to the total weight of all entries of \code{x} that are less than or equal to \code{y}. That is \code{Fn(y) = sum(weights[x <= y])}. Thus \code{Fn} is a step function which jumps at the values of \code{x}. The height of the jump at a point \code{y} is the total weight of all entries in \code{x} number of tied observations at that value. Missing values are ignored. If \code{weights} is omitted, the default is equivalent to \code{ecdf(x)} except for the class membership. The result of \code{ewcdf} is a function, of class \code{"ewcdf"}, inheriting from the classes \code{"ecdf"} (only if \code{normalise=TRUE}) and \code{"stepfun"}. The class \code{ewcdf} has methods for \code{\link[base]{print}}, \code{\link[stats]{quantile}} and \code{\link[base]{mean}}. The inherited classes \code{ecdf} and \code{stepfun} have methods for \code{\link[base]{plot}} and \code{\link[base]{summary}}. } \value{ A function, of class \code{"ewcdf"}, inheriting from \code{"ecdf"} (if \code{normalise=TRUE}) and \code{"stepfun"}. } \author{ \spatstatAuthors. } \seealso{ \code{\link[stats]{ecdf}}. \code{\link[spatstat.univar]{quantile.ewcdf}}, \code{\link[spatstat.univar]{mean.ewcdf}}. Integrals with respect to the weighted cumulative distribution function can be computed using \code{\link[spatstat.univar]{stieltjes}}. } \examples{ x <- rnorm(100) w <- runif(100) plot(e <- ewcdf(x,w)) e } \keyword{nonparametric} \keyword{univar} spatstat.univar/man/kernel.factor.Rd0000644000176200001440000000264414632773657017251 0ustar liggesusers\name{kernel.factor} \alias{kernel.factor} \title{Scale factor for density kernel} \description{ Returns a scale factor for the kernels used in density estimation for numerical data. } \usage{ kernel.factor(kernel = "gaussian") } \arguments{ \item{kernel}{ String name of the kernel. Options are \code{"gaussian"}, \code{"rectangular"}, \code{"triangular"}, \code{"epanechnikov"}, \code{"biweight"}, \code{"cosine"} and \code{"optcosine"}. (Partial matching is used). } } \details{ Kernel estimation of a probability density in one dimension is performed by \code{\link[stats]{density.default}} using a kernel function selected from the list above. This function computes a scale constant for the kernel. For the Gaussian kernel, this constant is equal to 1. Otherwise, the constant \eqn{c} is such that the kernel with standard deviation \eqn{1} is supported on the interval \eqn{[-c,c]}. For more information about these kernels, see \code{\link[stats]{density.default}}. } \value{ A single number. } \seealso{ \code{\link[stats]{density.default}}, \code{\link{dkernel}}, \code{\link{kernel.moment}}, \code{\link{kernel.squint}} } \examples{ kernel.factor("rect") # bandwidth for Epanechnikov kernel with half-width h=1 h <- 1 bw <- h/kernel.factor("epa") } \author{\adrian and \martinH. } \keyword{methods} \keyword{nonparametric} \keyword{smooth} spatstat.univar/man/bw.taylor.Rd0000644000176200001440000000462714674426116016427 0ustar liggesusers\name{bw.taylor} \alias{bw.taylor} \title{ Bandwidth Selection for Kernel Density Estimation by Non-Random Bootstrap } \description{ Use Taylor's non-random bootstrap technique to select the bandwidth for kernel density estimation on the real line. } \usage{ bw.taylor(x, \dots, srange = NULL, useC = TRUE) } \arguments{ \item{x}{ Numeric vector. } \item{\dots}{ Ignored. } \item{srange}{ Range of bandwidths to be considered. A numeric vector of length 2. } \item{useC}{ Logical value specifying whether to use faster C code. } } \details{ This function selects a bandwidth for kernel density estimation of a probability density on the real line, using the numeric data \code{x} and assuming a Gaussian kernel. The result is the numeric value of the standard deviation of the Gaussian kernel. The function uses the method of Taylor (1989) who showed that, when using the Gaussian kernel, the optimisation criterion can be computed rapidly from the data without any randomised resampling. The domain of the probability density is assumed to be the entire real line. Boundary correction is not currently implemented. % (but modifications could % theoretically be made to allow this in exchange for an increase in % computational cost). The result of \code{bw.taylor} is a single numeric value giving the selected bandwidth. % If \code{ns} is missing or \code{NULL}, then the optimal value % is found rapidly using \code{\link[stats]{optimise}}. % If \code{ns} is an integer, then the optimisation criterion is % evaluated at \code{ns} candidate values of bandwidth, and the result % also belongs to the class \code{"bw.optim"}; it contains the % values of the optimisation criterion at all candidate bandwidths, % and can be plotted as shown in the examples. } \value{ A single numeric value. % If \code{ns} is given, the result also belongs to the class % \code{"bw.optim"}, and contains the values of the optimisation % criterion, which can be plotted using \code{plot}. } \references{ Taylor, C.C. (1989) Choice of the Smoothing Parameter in Kernel Density Estimation, \emph{Biometrika} \bold{76} 4, 705--712. } \author{ \tilman and \adrian. } \seealso{ \code{\link[stats]{bw.nrd}} in the \pkg{stats} package for standard bandwidth selectors. } \examples{ x <- rnorm(30) bw.taylor(x) } \keyword{univar} \keyword{smooth} \concept{Bandwidth selection} spatstat.univar/man/knots.ewcdf.Rd0000644000176200001440000000203714667200151016713 0ustar liggesusers\name{knots.ewcdf} \alias{knots.ewcdf} \title{ Jump Points of an Empirical Weighted Cumulative Distribution Function } \description{ Extract the knots (jump points) of an empirical weighted cumulative distribution function. } \usage{ \method{knots}{ewcdf}(Fn, \dots) } \arguments{ \item{Fn}{ An empirical weighted cumulative distribution function (object of class \code{"ewcdf"}). } \item{\dots}{ Ignored. } } \details{ The function \code{\link[stats]{knots}} is generic. This function \code{knots.ewcdf} is the method for the class \code{"ewcdf"} of empirical weighted cumulative distribution functions. Objects of class \code{"ewcdf"} are created by \code{\link{ewcdf}}. The jump points (locations of increments) of the function will be returned as a numeric vector. } \value{ Numeric vector. } \author{ \spatstatAuthors. } \seealso{ \code{\link{ewcdf}}, \code{\link{quantile.ewcdf}} } \examples{ x <- c(1, 2, 5) w <- runif(3) e <- ewcdf(x,w) knots(e) } \keyword{nonparametric} \keyword{univar} spatstat.univar/man/firstdigit.Rd0000644000176200001440000000176714633174700016652 0ustar liggesusers\name{firstdigit} \alias{firstdigit} \alias{lastdigit} \alias{ndigits} \title{ Digits in Decimal Representation } \description{ Find the first or last digit in the decimal representation of a number. } \usage{ firstdigit(x) lastdigit(x) ndigits(x) } \arguments{ \item{x}{A numeric value or numeric vector.} } \details{ \code{firstdigit(x)} finds the first (most significant) digit, \code{lastdigit(x)} finds the last (least significant) digit, and \code{ndigits(x)} finds the number of digits, in the decimal representation of each entry of \code{x}. The decimal representation is truncated at the number of digits available for double precision numbers on the hardware, usually 15. } \value{ An integer or integer vector of the same length as \code{x}. } \author{ \adrian } \seealso{ \code{\link[spatstat.univar]{rounding}} } \examples{ firstdigit(42) lastdigit(42) ndigits(42) firstdigit(-0.1234) lastdigit(-0.1234) ndigits(-0.1234) firstdigit(0) lastdigit(0) ndigits(0) } \keyword{math}spatstat.univar/man/densityBC.Rd0000644000176200001440000002544014757566113016372 0ustar liggesusers\name{densityBC} \alias{densityBC} \title{Kernel Density Estimation with Optional Boundary Correction} \description{ Fixed-bandwidth kernel density estimation on the real line, or the positive real half-line, including optional corrections for a boundary at zero. } \usage{ densityBC(x, kernel = "epanechnikov", bw=NULL, \dots, h=NULL, adjust = 1, weights = rep(1, length(x))/length(x), from, to = max(x), n = 256, zerocor = c("none", "weighted", "convolution", "reflection", "bdrykern", "JonesFoster"), fast=FALSE, internal=list()) } \arguments{ \item{x}{Numeric vector of observed values.} \item{kernel}{String specifying kernel. Options are \code{"gaussian"}, \code{"rectangular"}, \code{"triangular"}, \code{"epanechnikov"}, \code{"biweight"}, \code{"cosine"} and \code{"optcosine"}. (Partial matching is used). Options are described in the help for \code{\link[stats]{density.default}}. } \item{bw,h}{ Alternative specifications of the scale factor for the kernel. The bandwidth \code{bw} is the standard deviation of the kernel (this agrees with the argument \code{bw} in \code{\link[stats]{density.default}}). The rescale factor \code{h} is the factor by which the `standard form' of the kernel is rescaled. For the Epanechnikov kernel, \code{h = bw * sqrt(5)} is the half-width of the support, while for the Gaussian kernel, \code{h = bw} is the standard deviation. Either \code{bw} or \code{h} should be given, and should be a single numeric value, or a character string indicating a bandwidth selection rule as described in \code{\link[stats]{density.default}}. } \item{adjust}{ Numeric value used to rescale the bandwidth \code{bw} and halfwidth \code{h}. The bandwidth used is \code{adjust * bw}. This makes it easy to specify values like \sQuote{half the default} bandwidth. } \item{weights}{ Numeric vector of weights associated with \code{x}. The weights are not required to sum to 1, and will not be normalised to sum to 1. The weights may include negative values. } \item{from,to}{ Lower and upper limits of interval on which density should be computed. The default value of \code{from} is \code{from=min(x)} if \code{zerocor="none"}, and \code{from=0} otherwise. } \item{n}{ Number of \eqn{r} values for which density should be computed. } \item{zerocor}{ String (partially matched) specifying a correction for the boundary effect bias at \eqn{r=0} when estimating a density on the positive half line. Possible values are \code{"none"}, \code{"weighted"}, \code{"convolution"}, \code{"reflection"}, \code{"bdrykern"} and \code{"JonesFoster"}. } \item{fast}{ Logical value specifying whether to perform the calculation rapidly using the Fast Fourier Transform (\code{fast=TRUE}) or to use slower, exact code (\code{fast=FALSE}, the default). } \item{internal}{ Internal use only. } \item{\dots}{ Additional arguments are ignored. } } \details{ This function computes a fixed-bandwidth kernel estimate of a probability density on the real line, or the positive half-line, including optional boundary corrections for truncation of the density onto the positive half line. Weighted estimates are supported, including negative weights. Weights are not renormalised to sum to 1. The resulting probability density estimate is not renormalised to integrate to 1. Options for the smoothing kernel are described in the help for \code{\link[stats]{density.default}}. The default is the Epanechnikov (truncated quadratic) kernel. If \code{zerocor} is missing, or given as \code{"none"}, this function computes the fixed-bandwidth kernel estimator of the probability density on the real line, using \code{\link[stats]{density.default}}. The estimated probability density (unnormalised) is \deqn{ \widehat f(x) = \sum_{i=1}^n w_i \; \kappa(x - x_i) }{ f(x) = sum[i=1,...,n] w[i] * kappa(x - x[i]) } where \eqn{x_1,\ldots,x_n}{x[1], ..., x[n]} are the data values, \eqn{w_1,\ldots,w_n}{w[1], ..., w[n]} are the weights (defaulting to \eqn{w_i = 1/n}{w[i] = 1/n}), and \eqn{\kappa}{kappa} is the kernel, a probability density on the real line. If \code{zerocor} is given, the probability density is assumed to be confined to the positive half-line; the numerical values in \code{x} must all be non-negative; and a boundary correction is applied to compensate for bias arising due to truncation at the origin: \describe{ \item{\code{zerocor="weighted"}:}{ The contribution from each data point \eqn{x_i}{x[i]} is weighted by the factor \eqn{1/m(x_i)}{1/m(x[i])} where \eqn{m(x) = 1 - F(-x)} is the total mass of the kernel centred on \eqn{x} that lies in the positive half-line, and \eqn{F(x)} is the cumulative distribution function of the kernel. The corrected estimate is \deqn{ \widehat f_W(x) = \sum_{i=1}^n w_i \; \frac{\kappa(x - x_i)}{1-F(-x_i)} }{ fW(x) = sum[i=1,...,n] w[i] * kappa(x - x[i])/(1-F(-x[i])) } This is the \dQuote{cut-and-normalization} method of Gasser and \ifelse{latex}{\out{M\"{u}ller}}{Mueller} (1979). Effectively the kernel is renormalized so that it integrates to 1, and the adjusted kernel conserves mass. } \item{\code{zerocor="convolution"}:}{ The estimate of the density \eqn{f(x)} is weighted by the factor \eqn{1/m(x)} where \eqn{m(r) = 1 - F(-x)} is given above. The corrected estimate is \deqn{ \widehat f_C(x) = \sum_{i=1}^n w_i \; \frac{\kappa(x - x_i)}{1-F(-x)} }{ fC(x) = sum[i=1,...,n] w[i] * kappa(x - x[i])/(1-F(-x)) } This is the \dQuote{convolution}, \dQuote{uniform} or \dQuote{zero-order} boundary correction method often attributed to Diggle (1985). This correction does not conserve mass. It is faster to compute than the weighted correction. } \item{\code{zerocor="reflection"}:}{ if the kernel centred at data point \eqn{x_i}{x[i]} has a tail that lies on the negative half-line, this tail is reflected onto the positive half-line. The corrected estimate is \deqn{ \widehat f_R(x) = \sum_{i=1}^n w_i \; [ \kappa(x - x_i) + \kappa(-x - x_i) ] }{ fR(x) = sum[i=1,...,n] w[i] * ( kappa(x - x[i]) + kappa(-x - x[i]) ) } This is the \dQuote{reflection} method first proposed by Boneva et al (1971). This correction conserves mass. The estimated density always has zero derivative at the origin, \eqn{\widehat f_R^\prime(0) = 0}{fR'(0) = 0}, which may or may not be desirable. } \item{\code{zerocor="bdrykern"}:}{ The density estimate is computed using the Linear Boundary Kernel associated with the chosen kernel (Wand and Jones, 1995, page 47). The estimated (unnormalised) probability density is \deqn{ \widehat f_B(x) = \sum_{i=1}^n w_i \; [ A(x) + (x-x_i) B(x)] \kappa(x - x_i) }{ fB(x) = sum[i=1,...,n] w[i] * ( A(x) + (x-x[i]) B(x)) * kappa(x - x[i]) } where \eqn{A(x) = a_2(x)/D(x)}{A(x) = a[2](x)/D(x)} and \eqn{B(x) = -a_1(x)/D(x)}{B(x) = -a[1](x)/D(x)} with \eqn{D(x) = a_0(x) a_2(x) - a_1(x)^2}{D(x) = a[0](x) a[2](x) - a[1](x)^2} where \eqn{ a_k(x) = \int_{-\infty}^x t^k \kappa(t) dt. }{ a[k](x) = integral[-Inf,x] ( t^k * kappa(t) dt). } That is, when estimating the density \eqn{f(x)} for values of \eqn{x} close to zero (defined as \eqn{x < h} for all kernels except the Gaussian), the kernel contribution \eqn{k_h(x - x_i)}{k[h](x - x[i])} is multiplied by a term that is a linear function of \eqn{x - x_i}{x - x[i]}, with coefficients depending on \eqn{x}. This correction does not conserve mass and may result in negative values, but is asymptotically optimal. Computation time for this estimate is greater than for the options above. } \item{\code{zerocor="JonesFoster"}:}{ The modification of the Boundary Kernel estimate proposed by Jones and Foster (1996) is computed: \deqn{ \widehat f_{JF}(x) = \widehat f_C(x) \exp\left( \frac{\widehat f_B(x)}{\widehat f_C(r)} - 1 \right) }{ fJF(x) = fC(x) exp(fB(x)/fC(x) - 1) } where \eqn{\widehat f_C(r)}{fC(r)} is the convolution estimator and \eqn{\widehat f_B(r)}{fB(r)} is the linear boundary kernel estimator. This ensures that the estimate is always nonnegative and retains the asymptotic optimality of the linear boundary kernel. Computation time for this estimate is greater than for all the options above. } } If \code{fast=TRUE}, the calculations are performed rapidly using \code{\link[stats]{density.default}} which employs the Fast Fourier Transform. If \code{fast=FALSE} (the default), the calculations are performed exactly using slower C code. } \value{ An object of class \code{"density"} as described in the help file for \code{\link[stats]{density.default}}. It contains at least the entries \item{x }{Vector of \eqn{x} values} \item{y }{Vector of density values \eqn{y= f(x)}} } \examples{ sim.dat <- rexp(500) fhatN <- densityBC(sim.dat, "biweight", h=0.4) fhatB <- densityBC(sim.dat, "biweight", h=0.4, zerocor="bdrykern") plot(fhatN, ylim=c(0,1.1), main="density estimates") lines(fhatB, col=2) curve(dexp(x), add=TRUE, from=0, col=3) legend(2, 0.8, legend=c("fixed bandwidth", "boundary kernel", "true density"), col=1:3, lty=rep(1,3)) } \seealso{ \code{\link[stats]{density.default}}. \code{\link{dkernel}} for the kernel itself. \code{\link{densityAdaptiveKernel.default}} for adaptive (variable-bandwidth) estimation. } \references{ \ournewpaper Boneva, L.I., Kendall, D.G. and Stefanov, I. (1971) Spline transformations: three new diagnostic aids for the statistical data-analyst (with discussion). \emph{Journal of the Royal Statistical Society, Series B}, \bold{33}, 1--70. Diggle, P.J. (1985) A kernel method for smoothing point process data. \emph{Journal of the Royal Statistical Society, Series C (Applied Statistics)}, \bold{34} 138--147. Gasser, Th. and \ifelse{latex}{\out{M\"{u}ller}}{Mueller}, H.-G. (1979). Kernel estimation of regression functions. In Th. Gasser and M. Rosenblatt (editors) \emph{Smoothing Techniques for Curve Estimation}, pages 23--68. Springer, Berlin. Jones, M.C. and Foster, P.J. (1996) A simple nonnegative boundary correction method for kernel density estimation. \emph{Statistica Sinica}, \bold{6} (4) 1005--1013. Wand, M.P. and Jones, M.C. (1995) \emph{Kernel Smoothing}. Chapman and Hall. } \author{\adrian and \martinH.} \keyword{methods} \keyword{nonparametric} \keyword{smooth} spatstat.univar/man/hotrod.Rd0000644000176200001440000000265614632773657016016 0ustar liggesusers\name{hotrod} \alias{hotrod} \title{ Heat Kernel for a One-Dimensional Rod } \description{ Calculate values of the heat kernel on a one-dimensional rod. The ends of the rod may be assumed to be insulated, or absorbing. } \usage{ hotrod(len, xsource, xquery, sigma, ends=c("insulated", "absorbing"), nmax=20) } \arguments{ \item{len}{ Length of the rod. A single number or numeric vector. } \item{xsource}{ Positions of the source points, from the left end of the rod (in the same distance units as \code{len}). A single number or numeric vector. } \item{xquery}{ Positions of the query points, from the left end of the rod (in the same distance units as \code{len}). A single number or numeric vector. } \item{sigma}{ Bandwidth for kernel. A single number or a numeric vector. } \item{ends}{ Character string (partially matched) specifying whether the ends of the rod are assumed to be insulated or absorbing. } \item{nmax}{ Number of terms in the infinite sum to use. A single integer or an integer vector. } } \details{ Computes the heat kernel as an infinite sum. } \value{ Number or numeric vector. } \author{ Greg McSwiggan and \adrian. } \examples{ curve(hotrod(1, 0.1, x, 0.7)) # check it's a probability density f <- function(x) hotrod(1, 0.1, x, 0.7) integrate(f, 0, 1) ## absorbing ends curve(hotrod(1, 0.1, x, 0.7, ends="a")) } \keyword{math} spatstat.univar/man/bw.abram.default.Rd0000644000176200001440000001315314632773657017625 0ustar liggesusers\name{bw.abram.default} \alias{bw.abram.default} \title{ Abramson's Adaptive Bandwidths For Numeric Data } \description{ Computes adaptive smoothing bandwidths for numeric data, according to the inverse-square-root rule of Abramson (1982). } \usage{ \method{bw.abram}{default}(X, h0, \dots, at = c("data", "grid"), pilot = NULL, hp = h0, trim = 5, smoother = density.default) } \arguments{ \item{X}{ Data for which bandwidths should be calculated. A numeric vector. } \item{h0}{ A scalar value giving the global smoothing bandwidth in the same units as \code{X}. The default is \code{h0=\link[stats]{bw.nrd0}(X)}. } \item{\dots}{ Arguments passed to \code{\link[stats]{density.default}} (or to \code{smoother}) controlling the range of values \code{x} at which the density will be estimated, when \code{at="grid"}. } \item{at}{ Character string (partially matched) specifying whether to compute bandwidth values only at the data points of \code{X} (\code{at = 'data'}, the default) or on a grid of \code{x} values (\code{at = 'grid'}). } \item{pilot}{ Optional. Specification of a pilot density (possibly unnormalised). Either a numeric vector giving the pilot density for each data point of \code{X}, a \code{function} in the \R language, or a probability density estimate (object of class \code{"density"}). If \code{pilot=NULL} the pilot density is computed by applying fixed-bandwidth density estimation to \code{X} using bandwidth \code{hp}. } \item{hp}{ Optional. A scalar pilot bandwidth, used for estimation of the pilot density, if \code{pilot} is not given. } \item{trim}{ A trimming value required to curb excessively large bandwidths. See Details. The default is sensible in most cases. } \item{smoother}{ Smoother for the pilot. A function or character string, specifying the function to be used to compute the pilot estimate when \code{pilot} is \code{NULL}. } } \details{ This function computes adaptive smoothing bandwidths using the methods of Abramson (1982) and Hall and Marron (1988). The function \code{\link[spatstat.univar]{bw.abram}} is generic. The function \code{bw.abram.default} documented here is the default method which is designed for numeric data. If \code{at="data"} (the default) a smoothing bandwidth is computed for each data point in \code{X}. Alternatively if \code{at="grid"} a smoothing bandwidth is computed for a grid of \code{x} values. Under the Abramson-Hall-Marron rule, the bandwidth at location \eqn{u} is \deqn{ h(u) = \mbox{\texttt{h0}} * \mbox{min}[ \frac{\tilde{f}(u)^{-1/2}}{\gamma}, \mbox{\texttt{trim}} ] }{ h(u) = h0 * min(\tilde{f}(u)^{-1/2}/\gamma, trim) } where \eqn{\tilde{f}(u)} is a pilot estimate of the probability density. The variable bandwidths are rescaled by \eqn{\gamma}, the geometric mean of the \eqn{\tilde{f}(u)^{-1/2}} terms evaluated at the data; this allows the global bandwidth \code{h0} to be considered on the same scale as a corresponding fixed bandwidth. The trimming value \code{trim} has the same interpretation as the required `clipping' of the pilot density at some small nominal value (see Hall and Marron, 1988), to necessarily prevent extreme bandwidths (which can occur at very isolated observations). The pilot density or intensity is determined as follows: \itemize{ \item If \code{pilot} is a \code{function} in the \R language, this is taken as the pilot density. \item If \code{pilot} is a probability density estimate (object of class \code{"density"} produced by \code{\link[stats]{density.default}}) then this is taken as the pilot density. \item If \code{pilot} is \code{NULL}, then the pilot intensity is computed as a fixed-bandwidth kernel intensity estimate using \code{\link{density.default}} applied to the data \code{X} using the pilot bandwidth \code{hp}. } In each case the pilot density is renormalised to become a probability density, and then the Abramson rule is applied. Instead of calculating the pilot as a fixed-bandwidth density estimate, the user can specify another density estimation procedure using the argument \code{smoother}. This should be either a function or the character string name of a function. It will replace \code{\link{density.default}} as the function used to calculate the pilot estimate. The pilot estimate will be computed as \code{smoother(X, sigma=hp, ...)} if \code{pilot} is \code{NULL}, or \code{smoother(pilot, sigma=hp, ...)} if \code{pilot} is a point pattern. If \code{smoother} does not recognise the argument name \code{sigma} for the smoothing bandwidth, then \code{hp} is effectively ignored. } \value{ Either a numeric vector of the same length as \code{X} giving the Abramson bandwidth for each point (when \code{at = "data"}, the default), or a \code{function} giving the Abramson bandwidths as a function of location. } \seealso{ \code{\link[spatstat.univar]{bw.abram}}, \code{\link[stats]{bw.nrd0}}. } \references{ Abramson, I. (1982) On bandwidth variation in kernel estimates --- a square root law. \emph{Annals of Statistics}, \bold{10}(4), 1217-1223. Hall, P. and Marron, J.S. (1988) Variable window width kernel density estimates of probability densities. \emph{Probability Theory and Related Fields}, \bold{80}, 37-49. Silverman, B.W. (1986) \emph{Density Estimation for Statistics and Data Analysis}. Chapman and Hall, New York. } \author{ \tilman. Adapted by \adrian. } \examples{ xx <- rexp(20) bw.abram(xx) } \keyword{nonparametric} spatstat.univar/DESCRIPTION0000644000176200001440000000425214762030413015131 0ustar liggesusersPackage: spatstat.univar Version: 3.1-2 Date: 2025-03-05 Title: One-Dimensional Probability Distribution Support for the 'spatstat' Family Authors@R: c(person("Adrian", "Baddeley", role = c("aut", "cre", "cph"), email = "Adrian.Baddeley@curtin.edu.au", comment = c(ORCID="0000-0001-9499-8382")), person(c("Tilman", "M."), "Davies", role = c("aut", "ctb", "cph"), email = "Tilman.Davies@otago.ac.nz", comment = c(ORCID="0000-0003-0565-1825")), person(c("Martin", "L."), "Hazelton", role = c("aut", "ctb", "cph"), email = "Martin.Hazelton@otago.ac.nz", comment = c(ORCID="0000-0001-7831-725X")), person("Ege", "Rubak", role = c("aut", "cph"), email = "rubak@math.aau.dk", comment=c(ORCID="0000-0002-6675-533X")), person("Rolf", "Turner", role = c("aut", "cph"), email="rolfturner@posteo.net", comment=c(ORCID="0000-0001-5521-5218")), person("Greg", "McSwiggan", role = c("ctb", "cph"))) Maintainer: Adrian Baddeley Depends: R (>= 3.5.0), stats Imports: spatstat.utils (>= 3.1-2) Description: Estimation of one-dimensional probability distributions including kernel density estimation, weighted empirical cumulative distribution functions, Kaplan-Meier and reduced-sample estimators for right-censored data, heat kernels, kernel properties, quantiles and integration. License: GPL (>= 2) URL: http://spatstat.org/ NeedsCompilation: yes ByteCompile: true BugReports: https://github.com/spatstat/spatstat.univar/issues Packaged: 2025-03-05 04:43:32 UTC; adrian Author: Adrian Baddeley [aut, cre, cph] (), Tilman M. Davies [aut, ctb, cph] (), Martin L. Hazelton [aut, ctb, cph] (), Ege Rubak [aut, cph] (), Rolf Turner [aut, cph] (), Greg McSwiggan [ctb, cph] Repository: CRAN Date/Publication: 2025-03-05 11:10:03 UTC